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..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. @@ -17,28 +15,17 @@ 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 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 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 -------------------------------------------------------------------------------} @@ -48,26 +35,13 @@ data TracerEnv = TracerEnv { , tracerEnvNames :: Names } -newtype Instrument a = Wrap { unwrap :: ReaderT TracerEnv TcM a } - deriving newtype - ( -- base - Functor - , Applicative - , Monad - , MonadIO - -- exceptions - , MonadThrow - , MonadCatch - , MonadMask - -- 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 @@ -79,16 +53,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 @@ -97,7 +82,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 @@ -127,13 +112,13 @@ 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 -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..d7060eb 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs @@ -7,14 +7,10 @@ module Plugin.TraceForeignCalls.Util.GHC ( , throwSimpleError , printSimpleWarning -- * Names - , resolveTHName + , resolveVarName + , resolveTcName ) where -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Data.String -import Language.Haskell.TH qualified as TH - import GHC hiding (getNamePprCtx) import GHC.Plugins hiding (getNamePprCtx, getHscEnv) @@ -22,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 @@ -39,9 +35,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' -------------------------------------------------------------------------------} @@ -56,9 +49,6 @@ getNamePprCtx = getDiagOpts :: HasHscEnv m => m DiagOpts getDiagOpts = initDiagOpts <$> getDynFlags -getNameCache :: HasHscEnv m => m NameCache -getNameCache = hsc_NC <$> getHscEnv - {------------------------------------------------------------------------------- Errors and warnings -------------------------------------------------------------------------------} @@ -96,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/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 b3a3012..83290bf 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 @@ -43,8 +38,6 @@ common lang library import: lang - other-extensions: - TemplateHaskell exposed-modules: Plugin.TraceForeignCalls other-modules: @@ -54,10 +47,9 @@ 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 + -- dependencies intentionally kept at a minimum + -- (we want to be able to build the boot libs with this plugin) + , ghc >= 9.6 && < 9.7 test-suite test-trace-foreign-calls import: