graph-trace 0.1.0.1 → 0.1.0.2

raw patch · 9 files changed

+137/−122 lines, 9 filesdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• graph-trace.cabal +3/−4
• src/Graph/Trace.hs +5/−0
• src/Graph/Trace/Internal/GhcFacade.hs +79/−3
• src/Graph/Trace/Internal/Instrument.hs +22/−5
• src/Graph/Trace/Internal/RuntimeRep.hs +9/−27
• src/Graph/Trace/Internal/Solver.hs +4/−0
• src/Graph/Trace/Internal/TH.hs +0/−74
• src/Graph/Trace/Internal/Trace.hs +11/−9

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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                     )

@@ -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

@@ -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

@@ -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

@@ -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