1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{-# LANGUAGE TupleSections #-}
-- This module contains functions which implement
-- the -finfo-table-map and -fdistinct-constructor-tables flags
module GHC.Stg.Debug(collectDebugInformation) where
import GHC.Prelude
import GHC.Core
import GHC.Stg.Syntax
import GHC.Types.Id
import GHC.Core.DataCon
import GHC.Types.IPE
import GHC.Unit.Module
import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan)
import GHC.Data.FastString
import GHC.Driver.Session
import GHC.Driver.Ppr
import Control.Monad (when)
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import GHC.Types.Unique.Map
import GHC.Types.SrcLoc
import Control.Applicative
data SpanWithLabel = SpanWithLabel RealSrcSpan String
data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }
type M a = ReaderT R (State InfoTableProvMap) a
withSpan :: (RealSrcSpan, String) -> M a -> M a
withSpan (new_s, new_l) act = local maybe_replace act
where
maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }
-- prefer spans from the current module
| Just (unpackFS $ srcSpanFile old_s) == ml_hs_file cur_mod
, Just (unpackFS $ srcSpanFile new_s) /= ml_hs_file cur_mod
= r
maybe_replace r
= r { rSpan = Just (SpanWithLabel new_s new_l) }
collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
collectDebugInformation dflags ml bs =
runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap
collectTop :: StgTopBinding -> M StgTopBinding
collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t
collectTop tb = return tb
collectStgBind :: StgBinding -> M StgBinding
collectStgBind (StgNonRec bndr rhs) = do
rhs' <- collectStgRhs bndr rhs
return (StgNonRec bndr rhs')
collectStgBind (StgRec pairs) = do
es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs
return (StgRec es)
collectStgRhs :: Id -> StgRhs -> M StgRhs
collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
e' <- collectExpr e
recordInfo bndr e'
return $ StgRhsClosure ext cc us bs e'
collectStgRhs _bndr (StgRhsCon cc dc args) = do
--n' <- incDc dc ticks
return (StgRhsCon cc dc args)
recordInfo :: Id -> StgExpr -> M ()
recordInfo bndr new_rhs = do
modLoc <- asks rModLocation
let
thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
-- A span from the ticks surrounding the new_rhs
best_span = quickSourcePos thisFile new_rhs
-- A back-up span if the bndr had a source position, many do not (think internally generated ids)
bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr)))
<$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))
recordStgIdPosition bndr best_span bndr_span
collectExpr :: StgExpr -> M StgExpr
collectExpr = go
where
go (StgApp occ as) = return $ StgApp occ as
go (StgLit lit) = return $ StgLit lit
go (StgConApp dc as tys) = do
-- n' <- incDc dc []
return (StgConApp dc as tys)
go (StgOpApp op as ty) = return (StgOpApp op as ty)
go (StgCase scrut bndr ty alts) =
StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts
go (StgLet ext bind body) = do
bind' <- collectStgBind bind
body' <- go body
return (StgLet ext bind' body')
go (StgLetNoEscape ext bind body) = do
bind' <- collectStgBind bind
body' <- go body
return (StgLetNoEscape ext bind' body')
go (StgTick tick e) = do
let k = case tick of
SourceNote ss fp -> withSpan (ss, fp)
_ -> id
e' <- k (go e)
return (StgTick tick e')
collectAlt :: StgAlt -> M StgAlt
collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e
-- | Try to find the best source position surrounding a 'StgExpr'. The
-- heuristic strips ticks from the current expression until it finds one which
-- is from the module currently being compiled. This is the same method that
-- the DWARF information uses to give locations to info tables.
--
-- It is usually a better alternative than using the 'RealSrcSpan' which is carefully
-- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather
-- than looking at the parent context like 'withSpan'
quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel
quickSourcePos cur_mod (StgTick (SourceNote ss m) e)
| srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m)
| otherwise = quickSourcePos cur_mod e
quickSourcePos _ _ = Nothing
recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
recordStgIdPosition id best_span ss = do
dflags <- asks rDynFlags
when (gopt Opt_InfoTableMap dflags) $ do
let tyString = showPpr dflags (idType id)
cc <- asks rSpan
--Useful for debugging why a certain Id gets given a certain span
--pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
case best_span <|> cc <|> ss of
Nothing -> return ()
Just (SpanWithLabel rss d) ->
lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)})
|
