graph-trace 0.1.0.0 → 0.1.0.1

raw patch · 5 files changed

+123/−138 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• graph-trace.cabal +3/−2
• src/Graph/Trace/Internal/RuntimeRep.hs +7/−94
• src/Graph/Trace/Internal/TH.hs +74/−0
• src/Graph/Trace/Internal/Trace.hs +10/−11
• src/Graph/Trace/Internal/Types.hs +29/−31

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               graph-trace-version:            0.1.0.0+version:            0.1.0.1  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==8.10.7+tested-with: GHC==9.2.1, GHC==9.0.1, GHC==9.0.2, GHC==8.10.7  library   default-language: Haskell2010@@ -38,6 +38,7 @@     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-prim

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if MIN_VERSION_ghc(9,0,0)@@ -16,8 +17,11 @@ 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. Handles linearity as well.+-- 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@@ -26,96 +30,5 @@   lpId :: forall (a :: TYPE r). a -> a #endif -#if MIN_VERSION_ghc(9,0,0)-instance LPId LiftedRep One where-  lpId x = x-instance LPId LiftedRep Many where-  lpId x = x-instance LPId UnliftedRep One where-  lpId x = x-instance LPId UnliftedRep Many where-  lpId x = x-instance LPId IntRep One where-  lpId x = x-instance LPId IntRep Many where-  lpId x = x-instance LPId Int8Rep One where-  lpId x = x-instance LPId Int8Rep Many where-  lpId x = x-instance LPId Int16Rep One where-  lpId x = x-instance LPId Int16Rep Many where-  lpId x = x-instance LPId Int32Rep One where-  lpId x = x-instance LPId Int32Rep Many where-  lpId x = x-instance LPId Int64Rep One where-  lpId x = x-instance LPId Int64Rep Many where-  lpId x = x-instance LPId WordRep One where-  lpId x = x-instance LPId WordRep Many where-  lpId x = x-instance LPId Word8Rep One where-  lpId x = x-instance LPId Word8Rep Many where-  lpId x = x-instance LPId Word16Rep One where-  lpId x = x-instance LPId Word16Rep Many where-  lpId x = x-instance LPId Word32Rep One where-  lpId x = x-instance LPId Word32Rep Many where-  lpId x = x-instance LPId Word64Rep One where-  lpId x = x-instance LPId Word64Rep Many where-  lpId x = x-instance LPId AddrRep One where-  lpId x = x-instance LPId AddrRep Many where-  lpId x = x-instance LPId FloatRep One where-  lpId x = x-instance LPId FloatRep Many where-  lpId x = x-instance LPId DoubleRep One where-  lpId x = x-instance LPId DoubleRep Many where-  lpId x = x-#else-instance LPId LiftedRep where-  lpId = id-instance LPId UnliftedRep where-  lpId x = x-instance LPId IntRep where-  lpId x = x-instance LPId Int8Rep where-  lpId x = x-instance LPId Int16Rep where-  lpId x = x-instance LPId Int32Rep where-  lpId x = x-instance LPId Int64Rep where-  lpId x = x-instance LPId WordRep where-  lpId x = x-instance LPId Word8Rep where-  lpId x = x-instance LPId Word16Rep where-  lpId x = x-instance LPId Word32Rep where-  lpId x = x-instance LPId Word64Rep where-  lpId x = x-instance LPId AddrRep where-  lpId x = x-instance LPId FloatRep where-  lpId x = x-instance LPId DoubleRep where-  lpId x = x-#endif++$(concat <$> traverse (makeInstancesForRep ''LPId 'lpId) allRuntimeReps)

@@ -0,0 +1,74 @@+{-# 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

@@ -20,7 +20,7 @@  import           Control.Concurrent.MVar import           Control.Monad-import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy.Char8 as BSL8 import           GHC.Exts import           GHC.Stack (callStack, popCallStack)@@ -42,12 +42,12 @@       (callStackToCallSite . popCallStack $ popCallStack callStack)  writeEventToLog :: Event -> IO ()--- forcing msg is required here since the file MVar could be entagled with it writeEventToLog event = seq fileLock $   withMVar fileLock $ \h ->-    BSL.hPut h . (<> "\n") $ eventToLogStr event+    BSB.hPutBuilder h . (<> "\n") $ eventToLogStr event  unsafeWriteTrace :: DebugIP => String -> a -> a+-- forcing msg is required here since the file MVar could be entagled with it unsafeWriteTrace !msg thing =   unsafePerformIO $ do     case mkTraceEvent msg of@@ -107,14 +107,13 @@       | omitTraces (propagation ip) -> lpId       | otherwise ->         let !() = unsafePerformIO $ do-              withMVar fileLock $ \h -> do-                let ev = EntryEvent-                           (currentTag ip)-                           (previousTag ip)-                           (definitionSite ip)-                           -- need to call popCallStack here to get actual call site-                           (callStackToCallSite $ popCallStack callStack)-                BSL.hPut h . (<> "\n") $ eventToLogStr ev+              let ev = EntryEvent+                         (currentTag ip)+                         (previousTag ip)+                         (definitionSite ip)+                         -- need to call popCallStack here to get actual call site+                         (callStackToCallSite $ popCallStack callStack)+              writeEventToLog ev          in lpId {-# NOINLINE entry  #-} 

@@ -30,7 +30,7 @@   ) where  import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSL8+import qualified Data.ByteString.Builder as BSB import           GHC.Stack import           GHC.TypeLits import qualified Language.Haskell.TH.Syntax as TH@@ -105,41 +105,39 @@         }     _ -> Nothing +sep :: BSB.Builder+sep = BSB.char8 '§'+ -- | Serialize an Event. The § character is used as both a separator and -- terminator. Don't use this character in trace messages, it will break!-eventToLogStr :: Event -> BSL.ByteString-eventToLogStr (EntryEvent current mPrevious mDefSite mCallSite) =-  BSL8.intercalate "§"-    [ "entry"-    , keyStr current-    , BSL8.pack . show $ invocationId current-    , maybe "" keyStr mPrevious-    , maybe "" (BSL8.pack . show . invocationId) mPrevious-    , srcCodeLocToLogStr mDefSite-    , srcCodeLocToLogStr mCallSite-    ] <> "§"-eventToLogStr (TraceEvent current message mCallSite) =-  BSL8.intercalate "§"-    [ "trace"-    , keyStr current-    , BSL8.pack . show $ invocationId current-    , message-    , srcCodeLocToLogStr mCallSite-    ] <> "§"+eventToLogStr :: Event -> BSB.Builder+eventToLogStr (EntryEvent current mPrevious mDefSite mCallSite)+   = BSB.stringUtf8 "entry" <> sep+  <> keyStr current <> sep+  <> BSB.wordDec (invocationId current) <> sep+  <> foldMap keyStr mPrevious <> sep+  <> foldMap (BSB.wordDec . invocationId) mPrevious <> sep+  <> srcCodeLocToLogStr mDefSite <> sep+  <> srcCodeLocToLogStr mCallSite <> sep+eventToLogStr (TraceEvent current message mCallSite)+   = BSB.stringUtf8 "trace" <> sep+  <> keyStr current <> sep+  <> BSB.wordDec (invocationId current) <> sep+  <> BSB.lazyByteString message <> sep+  <> srcCodeLocToLogStr mCallSite <> sep -srcCodeLocToLogStr :: Maybe SrcCodeLoc -> BSL.ByteString-srcCodeLocToLogStr mLoc =-  BSL8.intercalate "§"-    [ foldMap (BSL8.pack . srcModule) mLoc-    , foldMap (BSL8.pack . show . srcLine) mLoc-    , foldMap (BSL8.pack . show . srcCol) mLoc-    ]+srcCodeLocToLogStr :: Maybe SrcCodeLoc -> BSB.Builder+srcCodeLocToLogStr mLoc+   = foldMap (BSB.stringUtf8 . srcModule) mLoc <> sep+  <> foldMap (BSB.intDec . srcLine) mLoc <> sep+  <> foldMap (BSB.intDec . srcCol) mLoc -keyStr :: DebugTag -> BSL.ByteString+keyStr :: DebugTag -> BSB.Builder keyStr-  = either-      BSL8.pack-      BSL8.pack+  = BSB.stringUtf8+  . either+      id+      id   . debugKey  data DebugNames =