mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-07-14 15:10:21 +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
|
||||
tags
|
||||
|
@ -34,7 +34,11 @@ data Key = Key { keyId :: !Word
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
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)
|
||||
deriving Show
|
||||
|
||||
@ -109,7 +113,11 @@ data NodeEntry
|
||||
deriving Show
|
||||
|
||||
-- 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 = foldl' build mempty where
|
||||
@ -205,9 +213,9 @@ graphToDot graph = header <> graphContent <> "}"
|
||||
case mEdge of
|
||||
Nothing -> " HREF=\"\""
|
||||
Just _ -> " HREF=\"#" <> keyStrEsc edgeKey <> "\""
|
||||
edgeToolTip =
|
||||
elToolTip =
|
||||
foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite
|
||||
el = "<TR><TD TOOLTIP=\"" <> edgeToolTip
|
||||
el = "<TR><TD TOOLTIP=\"" <> elToolTip
|
||||
<> "\" ALIGN=\"LEFT\" CELLPADDING=\"1\" BGCOLOR=\""
|
||||
<> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
|
||||
<> href
|
||||
|
@ -138,6 +138,8 @@ modifyBinds nameMap entryName =
|
||||
(modifyBinding nameMap entryName)
|
||||
|
||||
-- | 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
|
||||
:: DebugNames
|
||||
-> M.Map Ghc.Name (Maybe Ghc.FastString, Propagation)
|
||||
@ -295,6 +297,8 @@ modifyBinding nameMap entryName
|
||||
alts
|
||||
|
||||
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
|
||||
|
||||
mkWhereBindName :: Ghc.TcM Ghc.Name
|
||||
@ -435,6 +439,11 @@ updateDebugIpInFunBind whereVarName
|
||||
#if !(MIN_VERSION_ghc(9,0,0))
|
||||
updateMatch x = x
|
||||
#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
|
||||
|
||||
-- | 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
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
pattern RealSrcLoc' loc = RealSrcLoc loc Nothing
|
||||
pattern RealSrcLoc' loc <- RealSrcLoc loc _
|
||||
#else
|
||||
pattern RealSrcLoc' loc = RealSrcLoc loc
|
||||
#endif
|
||||
|
Loading…
Reference in New Issue
Block a user