mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-09-11 09:05:34 +03:00
add IP update for PatBinds
This commit is contained in:
parent
8747fe00c4
commit
b6094ff6c7
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
|||||||
dist-newstyle
|
dist-newstyle
|
||||||
|
tags
|
||||||
|
@ -34,7 +34,11 @@ data Key = Key { keyId :: !Word
|
|||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
data LogEntry
|
data LogEntry
|
||||||
= Entry Key (Maybe Key) (Maybe SrcCodeLoc) (Maybe SrcCodeLoc)
|
= Entry
|
||||||
|
Key
|
||||||
|
(Maybe Key)
|
||||||
|
(Maybe SrcCodeLoc) -- definition site
|
||||||
|
(Maybe SrcCodeLoc) -- call site
|
||||||
| Trace Key BS.ByteString (Maybe SrcCodeLoc)
|
| Trace Key BS.ByteString (Maybe SrcCodeLoc)
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
@ -109,7 +113,11 @@ data NodeEntry
|
|||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
-- Remembers the order in which the elements were inserted
|
-- Remembers the order in which the elements were inserted
|
||||||
type Graph = M.Map Key (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
|
type Graph =
|
||||||
|
M.Map Key ( Min Int -- order
|
||||||
|
, [NodeEntry] -- contents
|
||||||
|
, Alt Maybe SrcCodeLoc -- definition site
|
||||||
|
)
|
||||||
|
|
||||||
buildGraph :: [LogEntry] -> Graph
|
buildGraph :: [LogEntry] -> Graph
|
||||||
buildGraph = foldl' build mempty where
|
buildGraph = foldl' build mempty where
|
||||||
@ -205,9 +213,9 @@ graphToDot graph = header <> graphContent <> "}"
|
|||||||
case mEdge of
|
case mEdge of
|
||||||
Nothing -> " HREF=\"\""
|
Nothing -> " HREF=\"\""
|
||||||
Just _ -> " HREF=\"#" <> keyStrEsc edgeKey <> "\""
|
Just _ -> " HREF=\"#" <> keyStrEsc edgeKey <> "\""
|
||||||
edgeToolTip =
|
elToolTip =
|
||||||
foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite
|
foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite
|
||||||
el = "<TR><TD TOOLTIP=\"" <> edgeToolTip
|
el = "<TR><TD TOOLTIP=\"" <> elToolTip
|
||||||
<> "\" ALIGN=\"LEFT\" CELLPADDING=\"1\" BGCOLOR=\""
|
<> "\" ALIGN=\"LEFT\" CELLPADDING=\"1\" BGCOLOR=\""
|
||||||
<> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
|
<> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
|
||||||
<> href
|
<> href
|
||||||
|
@ -138,6 +138,8 @@ modifyBinds nameMap entryName =
|
|||||||
(modifyBinding nameMap entryName)
|
(modifyBinding nameMap entryName)
|
||||||
|
|
||||||
-- | Instrument value bindings that have a signature with a debug pred.
|
-- | Instrument value bindings that have a signature with a debug pred.
|
||||||
|
-- This gets applied to both top level bindings as well as arbitrarily nested
|
||||||
|
-- value bindings.
|
||||||
modifyValBinds
|
modifyValBinds
|
||||||
:: DebugNames
|
:: DebugNames
|
||||||
-> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
|
-> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
|
||||||
@ -295,6 +297,8 @@ modifyBinding nameMap entryName
|
|||||||
alts
|
alts
|
||||||
|
|
||||||
pure bnd{Ghc.fun_matches = mg{ Ghc.mg_alts = newAlts }}
|
pure bnd{Ghc.fun_matches = mg{ Ghc.mg_alts = newAlts }}
|
||||||
|
-- modifyBinding nameMap entryName
|
||||||
|
-- bnd@Ghc.PatBind{} = DT.trace "PAT BIND" pure bnd
|
||||||
modifyBinding _ _ bnd = pure bnd
|
modifyBinding _ _ bnd = pure bnd
|
||||||
|
|
||||||
mkWhereBindName :: Ghc.TcM Ghc.Name
|
mkWhereBindName :: Ghc.TcM Ghc.Name
|
||||||
@ -435,6 +439,11 @@ updateDebugIpInFunBind whereVarName
|
|||||||
#if !(MIN_VERSION_ghc(9,0,0))
|
#if !(MIN_VERSION_ghc(9,0,0))
|
||||||
updateMatch x = x
|
updateMatch x = x
|
||||||
#endif
|
#endif
|
||||||
|
updateDebugIpInFunBind whereVarName
|
||||||
|
b@Ghc.PatBind{ Ghc.pat_rhs = g@Ghc.GRHSs{ Ghc.grhssGRHSs = grhss } }
|
||||||
|
= b { Ghc.pat_rhs =
|
||||||
|
g{ Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS whereVarName) <$> grhss }
|
||||||
|
}
|
||||||
updateDebugIpInFunBind _ b = b
|
updateDebugIpInFunBind _ b = b
|
||||||
|
|
||||||
-- | Produce the contents of the where binding that contains the new debug IP
|
-- | Produce the contents of the where binding that contains the new debug IP
|
||||||
|
@ -214,7 +214,7 @@ pattern HsQualTy' x lctx body
|
|||||||
|
|
||||||
pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc
|
pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc
|
||||||
#if MIN_VERSION_ghc(9,0,0)
|
#if MIN_VERSION_ghc(9,0,0)
|
||||||
pattern RealSrcLoc' loc = RealSrcLoc loc Nothing
|
pattern RealSrcLoc' loc <- RealSrcLoc loc _
|
||||||
#else
|
#else
|
||||||
pattern RealSrcLoc' loc = RealSrcLoc loc
|
pattern RealSrcLoc' loc = RealSrcLoc loc
|
||||||
#endif
|
#endif
|
||||||
|
Loading…
Reference in New Issue
Block a user