From 4faad25cfac31ebd3c4c5a704c2613bb2dbd572f Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 25 Apr 2024 09:59:57 +0200 Subject: [PATCH 1/4] Remove dependency on exceptions --- README.md | 1 - .../src/Plugin/TraceForeignCalls/Instrument.hs | 5 ----- trace-foreign-calls/trace-foreign-calls.cabal | 1 - 3 files changed, 7 deletions(-) diff --git a/README.md b/README.md index c8cc6d6..9c02af6 100644 --- a/README.md +++ b/README.md @@ -162,4 +162,3 @@ cc-options: -pthread An example is `crypton`, see [crypton#33](https://github.com/kazu-yamamoto/crypton/pull/33) for details. - diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index d40660f..2ac7ebe 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -17,7 +17,6 @@ module Plugin.TraceForeignCalls.Instrument ( ) where import Control.Monad -import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Reader @@ -55,10 +54,6 @@ newtype Instrument a = Wrap { unwrap :: ReaderT TracerEnv TcM a } , Applicative , Monad , MonadIO - -- exceptions - , MonadThrow - , MonadCatch - , MonadMask -- ghc , HasDynFlags , MonadThings diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index b3a3012..ad27f8b 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -54,7 +54,6 @@ library hs-source-dirs: src build-depends: - , exceptions >= 0.10 && < 0.11 , ghc >= 9.6 && < 9.7 , template-haskell >= 2.20 && < 2.21 , transformers >= 0.6 && < 0.7 From 9ab82510f6272358d0394a0f78ee57a7aeb34a6d Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 25 Apr 2024 10:08:57 +0200 Subject: [PATCH 2/4] Remove dependency on `transformers` --- .../Plugin/TraceForeignCalls/Instrument.hs | 52 +++++++++---------- .../src/Plugin/TraceForeignCalls/Util/GHC.hs | 5 -- trace-foreign-calls/trace-foreign-calls.cabal | 3 +- 3 files changed, 27 insertions(+), 33 deletions(-) diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index 2ac7ebe..5d67884 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -18,15 +18,11 @@ module Plugin.TraceForeignCalls.Instrument ( import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader import GHC -import GHC.Plugins +import GHC.Plugins hiding (getHscEnv) -import GHC.Driver.Hooks import GHC.Tc.Types -import GHC.Types.TyThing import GHC.Utils.Logger import Plugin.TraceForeignCalls.Options @@ -47,22 +43,13 @@ data TracerEnv = TracerEnv { , tracerEnvNames :: Names } -newtype Instrument a = Wrap { unwrap :: ReaderT TracerEnv TcM a } - deriving newtype - ( -- base - Functor - , Applicative - , Monad - , MonadIO - -- ghc - , HasDynFlags - , MonadThings - -- trace-foreign-calls - , HasHscEnv - ) +newtype Instrument a = Wrap { unwrap :: TracerEnv -> TcM a } liftTcM :: TcM a -> Instrument a -liftTcM = Wrap . lift +liftTcM = Wrap . const + +getTracerEnv :: Instrument TracerEnv +getTracerEnv = Wrap return runInstrument :: forall a. [String] -> Instrument a -> TcM a runInstrument rawOptions ma = do @@ -74,16 +61,27 @@ runInstrument rawOptions ma = do , tracerEnvNames = mkNames } - runReaderT (unwrap ma) tracerEnv + unwrap ma tracerEnv {------------------------------------------------------------------------------- - Manual instances - - Unfortunately many classes in GHC do not provide instances for transformers. + Instances -------------------------------------------------------------------------------} -instance HasHooks Instrument where getHooks = liftTcM getHooks -instance HasModule Instrument where getModule = liftTcM getModule +instance Functor Instrument where + fmap = liftM + +instance Applicative Instrument where + pure x = Wrap $ \_env -> return x + (<*>) = ap + +instance Monad Instrument where + x >>= f = Wrap $ \env -> unwrap x env >>= \a -> unwrap (f a) env + +instance MonadIO Instrument where + liftIO = liftTcM . liftIO + +instance HasDynFlags Instrument where getDynFlags = liftTcM getDynFlags +instance HasHscEnv Instrument where getHscEnv = liftTcM getHscEnv instance HasLogger Instrument where getLogger = liftTcM getLogger instance MonadUnique Instrument where getUniqueSupplyM = liftTcM getUniqueSupplyM @@ -92,7 +90,7 @@ instance MonadUnique Instrument where getUniqueSupplyM = liftTcM getUniqueSupply -------------------------------------------------------------------------------} asksOption :: (Options -> a) -> Instrument a -asksOption f = Wrap $ asks (f . tracerEnvOptions) +asksOption f = f . tracerEnvOptions <$> getTracerEnv whenOption :: (Options -> Bool) -> Instrument a -> Instrument (Maybe a) whenOption f ma = do @@ -131,4 +129,4 @@ mkNames = Names { } findName :: (Names -> TcM Name) -> Instrument Name -findName f = Wrap $ ReaderT $ f . tracerEnvNames +findName f = Wrap $ f . tracerEnvNames diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs index a103de3..48dfaaf 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs @@ -10,8 +10,6 @@ module Plugin.TraceForeignCalls.Util.GHC ( , resolveTHName ) where -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader import Data.String import Language.Haskell.TH qualified as TH @@ -39,9 +37,6 @@ class (MonadIO m, HasDynFlags m) => HasHscEnv m where instance HasHscEnv TcM where getHscEnv = env_top <$> getEnv -instance HasHscEnv m => HasHscEnv (ReaderT r m) where - getHscEnv = lift getHscEnv - {------------------------------------------------------------------------------- Internal auxiliary: using the 'HscEnv' -------------------------------------------------------------------------------} diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index ad27f8b..a5c6dd4 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -54,9 +54,10 @@ library hs-source-dirs: src build-depends: + -- dependencies intentionally kept at a minimum + -- (we want to be able to build the boot libs with this plugin) , ghc >= 9.6 && < 9.7 , template-haskell >= 2.20 && < 2.21 - , transformers >= 0.6 && < 0.7 test-suite test-trace-foreign-calls import: From 8e580ad134ddabf679db53719a58af2b2d346418 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 25 Apr 2024 10:12:31 +0200 Subject: [PATCH 3/4] Simplify `.cabal` file --- trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs | 1 + trace-foreign-calls/trace-foreign-calls.cabal | 5 ----- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs index 0dfbab4..9d4ac04 100644 --- a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs +++ b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CApiFFI #-} {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls -fplugin-opt Plugin.TraceForeignCalls:dump-generated #-} diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index a5c6dd4..8d270a4 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -25,14 +25,9 @@ source-repository head common lang build-depends: - -- ghc 9.6 base >= 4.18 && < 4.19 default-language: GHC2021 - default-extensions: - CApiFFI - DerivingStrategies - UndecidableInstances ghc-options: -Wall -Wredundant-constraints From 0e72ca6a6dcf356fd65ffce43db1d396174a3cb5 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 25 Apr 2024 10:18:36 +0200 Subject: [PATCH 4/4] Remove dependency on `template-haskell` --- .../Plugin/TraceForeignCalls/Instrument.hs | 20 +++------ .../src/Plugin/TraceForeignCalls/Util/GHC.hs | 44 ++++++++++--------- trace-foreign-calls/trace-foreign-calls.cabal | 5 +-- 3 files changed, 31 insertions(+), 38 deletions(-) diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index 5d67884..b565ff6 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | Instrumentation monad -- -- Intended for unqualified import. @@ -28,12 +26,6 @@ import GHC.Utils.Logger import Plugin.TraceForeignCalls.Options import Plugin.TraceForeignCalls.Util.GHC --- For name resolution -import Debug.Trace qualified -import Control.Exception qualified -import System.IO.Unsafe qualified -import GHC.Stack qualified - {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} @@ -120,12 +112,12 @@ data Names = Names { mkNames :: Names mkNames = Names { - nameTraceEventIO = resolveTHName 'Debug.Trace.traceEventIO - , nameEvaluate = resolveTHName 'Control.Exception.evaluate - , nameUnsafePerformIO = resolveTHName 'System.IO.Unsafe.unsafePerformIO - , nameHasCallStack = resolveTHName ''GHC.Stack.HasCallStack - , nameCallStack = resolveTHName 'GHC.Stack.callStack - , namePrettyCallStack = resolveTHName 'GHC.Stack.prettyCallStack + nameTraceEventIO = resolveVarName "Debug.Trace" "traceEventIO" + , nameEvaluate = resolveVarName "GHC.IO" "evaluate" + , nameUnsafePerformIO = resolveVarName "GHC.IO.Unsafe" "unsafePerformIO" + , nameHasCallStack = resolveTcName "GHC.Stack.Types" "HasCallStack" + , nameCallStack = resolveVarName "GHC.Stack" "callStack" + , namePrettyCallStack = resolveVarName "GHC.Exception" "prettyCallStack" } findName :: (Names -> TcM Name) -> Instrument Name diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs index 48dfaaf..d7060eb 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs @@ -7,12 +7,10 @@ module Plugin.TraceForeignCalls.Util.GHC ( , throwSimpleError , printSimpleWarning -- * Names - , resolveTHName + , resolveVarName + , resolveTcName ) where -import Data.String -import Language.Haskell.TH qualified as TH - import GHC hiding (getNamePprCtx) import GHC.Plugins hiding (getNamePprCtx, getHscEnv) @@ -20,10 +18,10 @@ import GHC.Data.IOEnv import GHC.Driver.Config.Diagnostic import GHC.Driver.Errors import GHC.Driver.Errors.Types +import GHC.Rename.Env import GHC.Runtime.Context import GHC.Tc.Types import GHC.Types.Error -import GHC.Types.Name.Cache import GHC.Utils.Error import GHC.Utils.Logger @@ -51,9 +49,6 @@ getNamePprCtx = getDiagOpts :: HasHscEnv m => m DiagOpts getDiagOpts = initDiagOpts <$> getDynFlags -getNameCache :: HasHscEnv m => m NameCache -getNameCache = hsc_NC <$> getHscEnv - {------------------------------------------------------------------------------- Errors and warnings -------------------------------------------------------------------------------} @@ -91,19 +86,28 @@ printSimpleWarning l doc = do {------------------------------------------------------------------------------- Names + + If we use 'Qual' for the 'RdrName' then the module needs to have that module + imported. We could /add/ the import, but that has problems of its own + (spurious warnings). We therefore use 'Orig'; this does mean we need to + provide a unit, but we only lok things up from base (we'd have to change this + once we have the ghc-internals split). It also means we have to import the + definition from the /defining/ module, rather than it's true "home base" (it's + canonical exporting module). + + A much simpler approach is to depend on TH to resolve names, and use + 'thNameToGhcNameIO'. However, at present the resulting dependency on + @template-haskell@ would make the plugin unuseable for base or the boot + modules. -------------------------------------------------------------------------------} -resolveTHName :: HasHscEnv m => TH.Name -> m Name -resolveTHName name = do - nameCache <- getNameCache - mResolved <- liftIO $ thNameToGhcNameIO nameCache name - case mResolved of - Just name' -> - return name' - Nothing -> - throwSimpleError noSrcSpan $ hcat [ - "Could not resolve TH name " - , fromString $ show name - ] +resolveVarName :: String -> String -> TcM Name +resolveVarName = resolveName mkVarOcc +resolveTcName :: String -> String -> TcM Name +resolveTcName = resolveName mkTcOcc +-- | Internal generalization +resolveName :: (String -> OccName) -> String -> String -> TcM Name +resolveName f modl name = + lookupOccRn $ Orig (mkModule baseUnit (mkModuleName modl)) (f name) diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index 8d270a4..83290bf 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -38,8 +38,6 @@ common lang library import: lang - other-extensions: - TemplateHaskell exposed-modules: Plugin.TraceForeignCalls other-modules: @@ -51,8 +49,7 @@ library build-depends: -- dependencies intentionally kept at a minimum -- (we want to be able to build the boot libs with this plugin) - , ghc >= 9.6 && < 9.7 - , template-haskell >= 2.20 && < 2.21 + , ghc >= 9.6 && < 9.7 test-suite test-trace-foreign-calls import: