diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for graph-trace +## 0.1.0.2 -- 2023-03-16 + +* Support GHC 9.4.x and 9.6.x + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/graph-trace.cabal b/graph-trace.cabal --- a/graph-trace.cabal +++ b/graph-trace.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: graph-trace -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Trace the call graph of a program @@ -25,7 +25,7 @@ copyright: Copyright (C) 2022 Aaron Allen category: tooling, debug, development, graph, plugin extra-source-files: CHANGELOG.md -tested-with: GHC==9.2.1, GHC==9.0.1, GHC==9.0.2, GHC==8.10.7 +tested-with: GHC==9.6.1, GHC==9.4.4, GHC==9.2.1, GHC==9.0.1, GHC==9.0.2, GHC==8.10.7 library default-language: Haskell2010 @@ -38,9 +38,8 @@ Graph.Trace.Internal.Instrument Graph.Trace.Internal.Predicates Graph.Trace.Internal.RuntimeRep - Graph.Trace.Internal.TH build-depends: base >= 4.9 && < 5 - , ghc >= 8.0.0 && < 9.4.0 + , ghc >= 8.0.0 && < 9.7.0 , ghc-prim , ghc-boot , containers diff --git a/src/Graph/Trace.hs b/src/Graph/Trace.hs --- a/src/Graph/Trace.hs +++ b/src/Graph/Trace.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} module Graph.Trace ( plugin , module DT @@ -31,7 +32,11 @@ findImportedModule moduleName = do hscEnv <- Ghc.getTopEnv result <- liftIO $ +#if MIN_VERSION_ghc(9,4,0) + Ghc.findImportedModule hscEnv (Ghc.mkModuleName moduleName) Ghc.NoPkgQual +#else Ghc.findImportedModule hscEnv (Ghc.mkModuleName moduleName) Nothing +#endif case result of Ghc.Found _ m -> pure m _ -> error $ "unable to find module: " <> moduleName diff --git a/src/Graph/Trace/Internal/GhcFacade.hs b/src/Graph/Trace/Internal/GhcFacade.hs --- a/src/Graph/Trace/Internal/GhcFacade.hs +++ b/src/Graph/Trace/Internal/GhcFacade.hs @@ -19,7 +19,7 @@ , pattern L' ) where -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) import GHC.Builtin.Names as Ghc import GHC.Builtin.Types as Ghc import GHC.Core.Class as Ghc @@ -28,6 +28,69 @@ import GHC.Data.Bag as Ghc import qualified GHC.Data.EnumSet as EnumSet import GHC.Data.FastString as Ghc +import GHC.Driver.Plugins as Ghc hiding (TcPlugin, DefaultingPlugin) +import GHC.Driver.Session as Ghc +import GHC.Hs as Ghc hiding (FunDep) +import GHC.Iface.Env as Ghc +import GHC.LanguageExtensions as Ghc hiding (UnicodeSyntax) +import GHC.Rename.Expr as Ghc +import GHC.Tc.Types as Ghc +import GHC.Tc.Types.Constraint as Ghc +import GHC.Tc.Types.Evidence as Ghc +import GHC.Tc.Types.Origin as Ghc +import GHC.Tc.Utils.Monad as Ghc +import GHC.ThToHs as Ghc +import GHC.Types.Basic as Ghc +import GHC.Types.Fixity as Ghc +import GHC.Types.Name as Ghc hiding (varName) +import GHC.Types.PkgQual as Ghc +import GHC.Types.SrcLoc as Ghc +import GHC.Types.Unique.Supply as Ghc +import GHC.Unit.Finder as Ghc +import GHC.Unit.Types as Ghc +import GHC.Utils.Outputable as Ghc + +#elif MIN_VERSION_ghc(9,4,0) +import GHC.Builtin.Names as Ghc +import GHC.Builtin.Types as Ghc +import GHC.Core.Class as Ghc +import GHC.Core.Make as Ghc +import GHC.Core.Type as Ghc +import GHC.Data.Bag as Ghc +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.FastString as Ghc +import GHC.Driver.Plugins as Ghc hiding (TcPlugin, DefaultingPlugin) +import GHC.Driver.Session as Ghc +import GHC.Hs as Ghc hiding (FunDep) +import GHC.Iface.Env as Ghc +import GHC.LanguageExtensions as Ghc hiding (UnicodeSyntax) +import GHC.Rename.Expr as Ghc +import GHC.Tc.Types as Ghc +import GHC.Tc.Types.Constraint as Ghc +import GHC.Tc.Types.Evidence as Ghc +import GHC.Tc.Types.Origin as Ghc +import GHC.Tc.Utils.Monad as Ghc +import GHC.ThToHs as Ghc +import GHC.Types.Basic as Ghc +import GHC.Types.Fixity as Ghc +import GHC.Types.Name as Ghc hiding (varName) +import GHC.Types.PkgQual as Ghc +import GHC.Types.SrcLoc as Ghc +import GHC.Types.Unique.Supply as Ghc +import GHC.Unit.Finder as Ghc +import GHC.Unit.Module.Name as Ghc +import GHC.Unit.Types as Ghc +import GHC.Utils.Outputable as Ghc + +#elif MIN_VERSION_ghc(9,2,0) +import GHC.Builtin.Names as Ghc +import GHC.Builtin.Types as Ghc +import GHC.Core.Class as Ghc +import GHC.Core.Make as Ghc +import GHC.Core.Type as Ghc +import GHC.Data.Bag as Ghc +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.FastString as Ghc import GHC.Driver.Plugins as Ghc hiding (TcPlugin) import GHC.Driver.Session as Ghc import GHC.Hs as Ghc hiding (FunDep) @@ -128,7 +191,14 @@ , fun_id' , fun_matches' } = -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,6,0) + FunBind fun_ext' fun_id' fun_matches' +pattern FunBind' + :: XFunBind GhcRn GhcRn + -> LIdP GhcRn + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> HsBindLR GhcRn GhcRn +#elif MIN_VERSION_ghc(9,0,0) FunBind fun_ext' fun_id' fun_matches' [] pattern FunBind' :: XFunBind GhcRn GhcRn @@ -210,7 +280,13 @@ -> Maybe (LHsContext GhcRn) -> LHsType GhcRn -> HsType GhcRn -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) +pattern HsQualTy' x lctx body + <- HsQualTy x (Just -> lctx) body + where + HsQualTy' x Nothing body = HsQualTy x (noLocA []) body + HsQualTy' x (Just lctx) body = HsQualTy x lctx body +#elif MIN_VERSION_ghc(9,2,0) pattern HsQualTy' x lctx body = HsQualTy x lctx body #else diff --git a/src/Graph/Trace/Internal/Instrument.hs b/src/Graph/Trace/Internal/Instrument.hs --- a/src/Graph/Trace/Internal/Instrument.hs +++ b/src/Graph/Trace/Internal/Instrument.hs @@ -107,7 +107,7 @@ (Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn) modifyBinding nameMap debugNames bnd@Ghc.FunBind { Ghc.fun_id = Ghc.L' loc name - , Ghc.fun_matches = mg@(Ghc.MG _ alts _) } + , Ghc.fun_matches = mg@(Ghc.MG { Ghc.mg_alts = alts }) } | Just (mUserKey, prop) <- M.lookup name nameMap = do let key = case mUserKey of @@ -131,7 +131,11 @@ collectName = \case Ghc.VarPat _ (Ghc.unLoc -> name) | M.member name nameMap -> S.singleton name +#if MIN_VERSION_ghc(9,6,0) + Ghc.AsPat _ (Ghc.unLoc -> name) _ _ +#else Ghc.AsPat _ (Ghc.unLoc -> name) _ +#endif | M.member name nameMap -> S.singleton name _ -> mempty vars = Syb.everything (<>) (Syb.mkQ mempty collectName) pat @@ -154,7 +158,12 @@ , Ghc.fun_id' = Ghc.noLocA' whereBindName , Ghc.fun_matches' = Ghc.MG +#if MIN_VERSION_ghc(9,6,0) + { Ghc.mg_ext = Ghc.Generated +#else { Ghc.mg_ext = Ghc.NoExtField + , Ghc.mg_origin = Ghc.Generated +#endif , Ghc.mg_alts = Ghc.noLocA' [Ghc.noLocA' Ghc.Match { Ghc.m_ext = Ghc.emptyEpAnn @@ -167,7 +176,12 @@ , Ghc.m_grhss = Ghc.GRHSs { Ghc.grhssExt = Ghc.emptyComments' , Ghc.grhssGRHSs = - [ Ghc.noLoc $ Ghc.GRHS + [ +#if MIN_VERSION_ghc(9,4,0) + Ghc.noLocA $ Ghc.GRHS +#else + Ghc.noLoc $ Ghc.GRHS +#endif Ghc.emptyEpAnn [] whereBindExpr @@ -177,7 +191,6 @@ } } ] - , Ghc.mg_origin = Ghc.Generated } } @@ -386,8 +399,7 @@ (Deep, _) -> Deep _ -> newProp --- | Wraps an expression with the 'entry' function. '$' is used to apply it --- because it has same special impredicative type properties in ghc 9.2+. +-- | Wraps an expression with the 'entry' function. emitEntryEvent :: Ghc.Name -> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn) @@ -419,8 +431,13 @@ Ghc.HsIPBinds Ghc.emptyEpAnn $ Ghc.IPBinds Ghc.NoExtField [ Ghc.noLocA' $ Ghc.IPBind +#if MIN_VERSION_ghc(9,4,0) + Ghc.NoExtField + (Ghc.noLocA' $ Ghc.HsIPName "_debug_ip") +#else Ghc.emptyEpAnn (Left . Ghc.noLoc $ Ghc.HsIPName "_debug_ip") +#endif (Ghc.noLocA' . Ghc.HsVar Ghc.NoExtField $ Ghc.noLocA' whereBindName ) diff --git a/src/Graph/Trace/Internal/RuntimeRep.hs b/src/Graph/Trace/Internal/RuntimeRep.hs --- a/src/Graph/Trace/Internal/RuntimeRep.hs +++ b/src/Graph/Trace/Internal/RuntimeRep.hs @@ -1,34 +1,16 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -#if MIN_VERSION_ghc(9,0,0) -{-# LANGUAGE LinearTypes #-} -#endif -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Graph.Trace.Internal.RuntimeRep - ( LPId(..) + ( Lev ) where import GHC.Exts -#if MIN_VERSION_ghc(9,0,0) -import GHC.Types (Multiplicity(..)) -#endif -import Graph.Trace.Internal.TH (allRuntimeReps, makeInstancesForRep) - --- | Levity polymorphic id function. Doesn't cover all runtime reps, in --- particular unboxed products and sums with more than 2 elements. Handles --- linearity as well. -#if MIN_VERSION_ghc(9,0,0) -class LPId (r :: RuntimeRep) (m :: Multiplicity) where - lpId :: forall (a :: TYPE r). a %m -> a -#else -class LPId (r :: RuntimeRep) where - lpId :: forall (a :: TYPE r). a -> a -#endif - +class DummyConstraint +instance DummyConstraint -$(concat <$> traverse (makeInstancesForRep ''LPId 'lpId) allRuntimeReps) +-- | Allows for a levity polymorphic value to be used in an argument position. +-- This trick was taken from Ed Kmett's `unboxed` library. +type Lev (a :: TYPE rep) = DummyConstraint => a diff --git a/src/Graph/Trace/Internal/Solver.hs b/src/Graph/Trace/Internal/Solver.hs --- a/src/Graph/Trace/Internal/Solver.hs +++ b/src/Graph/Trace/Internal/Solver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Graph.Trace.Internal.Solver ( tcPlugin ) where @@ -11,6 +12,9 @@ { Ghc.tcPluginInit = pure () , Ghc.tcPluginStop = \_ -> pure () , Ghc.tcPluginSolve = const tcPluginSolver +#if MIN_VERSION_ghc(9,4,0) + , Ghc.tcPluginRewrite = mempty +#endif } debuggerIpKey :: Ghc.FastString diff --git a/src/Graph/Trace/Internal/TH.hs b/src/Graph/Trace/Internal/TH.hs deleted file mode 100644 --- a/src/Graph/Trace/Internal/TH.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} -module Graph.Trace.Internal.TH - ( makeInstancesForRep - , allRuntimeReps - ) where - -import Control.Monad -import Data.Traversable -import GHC.Exts -#if MIN_VERSION_ghc(9,0,0) -import GHC.Types (Multiplicity(..)) -#endif -import Language.Haskell.TH - --- | A splice for generating instances for a given RuntimeRep -makeInstancesForRep :: Name -> Name -> Q Type -> Q [InstanceDec] -makeInstancesForRep cls meth rep = do - let instTypes = -#if MIN_VERSION_ghc(9,0,0) - [ conT cls `appT` rep `appT` [t| One |] - , conT cls `appT` rep `appT` [t| Many |] - ] -#else - [ conT cls `appT` rep ] -#endif - for instTypes $ \instType -> do - x <- newName "x" - instanceD (pure []) instType - [ funD meth [clause [varP x] (normalB $ varE x) []] ] - --- | RuntimeReps to generate instances for -runtimeReps :: [Q Type] -runtimeReps = - [ [t| LiftedRep |] - , [t| UnliftedRep |] - , [t| IntRep |] - , [t| Int8Rep |] - , [t| Int16Rep |] - , [t| Int32Rep |] - , [t| Int64Rep |] - , [t| WordRep |] - , [t| Word8Rep |] - , [t| Word16Rep |] - , [t| Word32Rep |] - , [t| Word64Rep |] - , [t| AddrRep |] - , [t| FloatRep |] - , [t| DoubleRep |] - ] - -tupleReps :: [[Q Type]] -tupleReps = do - len <- [0..2] - replicateM len runtimeReps - -unboxedTupleReps :: [Q Type] -unboxedTupleReps = map go tupleReps where - go tupleRep = do - tys <- sequence tupleRep - let list = foldr (AppT . AppT PromotedConsT) PromotedNilT tys - conT 'TupleRep `appT` pure list - -unboxedSumReps :: [Q Type] -unboxedSumReps = map go tupleReps where - go tupleRep = do - tys <- sequence tupleRep - let list = foldr (AppT . AppT PromotedConsT) PromotedNilT tys - conT 'SumRep `appT` pure list - --- Does not include SIMD vectors b/c they are platform dependent -allRuntimeReps :: [Q Type] -allRuntimeReps = runtimeReps <> unboxedTupleReps <> unboxedSumReps diff --git a/src/Graph/Trace/Internal/Trace.hs b/src/Graph/Trace/Internal/Trace.hs --- a/src/Graph/Trace/Internal/Trace.hs +++ b/src/Graph/Trace/Internal/Trace.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} # if MIN_VERSION_ghc(9,0,0) {-# LANGUAGE LinearTypes #-} @@ -28,7 +30,7 @@ import System.IO import System.IO.Unsafe (unsafePerformIO) -import Graph.Trace.Internal.RuntimeRep (LPId(..)) +import Graph.Trace.Internal.RuntimeRep (Lev) import Graph.Trace.Internal.Types mkTraceEvent :: DebugIP => String -> Maybe Event @@ -94,17 +96,17 @@ -- | Emits a message to the log signaling a function invocation entry #if MIN_VERSION_ghc(9,0,0) - :: forall rep m (a :: TYPE rep). (DebugIP, LPId rep m) - => a %m -> a + :: forall rep m (a :: TYPE rep). DebugIP + => Lev a %m -> a #else - :: forall rep (a :: TYPE rep). (DebugIP, LPId rep) - => a -> a + :: forall rep (a :: TYPE rep). DebugIP + => Lev a -> a #endif -entry = +entry x = case ?_debug_ip of - Nothing -> lpId + Nothing -> x Just ip - | omitTraces (propagation ip) -> lpId + | omitTraces (propagation ip) -> x | otherwise -> let !() = unsafePerformIO $ do let ev = EntryEvent @@ -114,7 +116,7 @@ -- need to call popCallStack here to get actual call site (callStackToCallSite $ popCallStack callStack) writeEventToLog ev - in lpId + in x {-# NOINLINE entry #-} omitTraces :: Propagation -> Bool