2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
5 Run through the STG code and compute the Static Reference Table for
6 each let-binding. At the same time, we figure out which top-level
7 bindings have no CAF references, and record the fact in their IdInfo.
10 module SRT( computeSRTs ) where
12 #include "HsVersions.h"
18 import Util ( sortLt )
19 import Maybes ( orElse )
20 import Maybes ( expectJust )
21 import Bitmap ( intsToBitmap )
34 computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
35 -- The incoming bindingd are filled with SRTEntries in their SRT slots
36 -- the outgoing ones have NoSRT/SRT values instead
38 computeSRTs binds = srtTopBinds emptyVarEnv binds
40 -- --------------------------------------------------------------------------
43 srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
45 srtTopBinds env [] = []
46 srtTopBinds env (StgNonRec b rhs : binds) =
47 (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
49 (rhs', srt) = srtTopRhs b rhs
50 env' = maybeExtendEnv env b rhs
51 srt' = applyEnvList env srt
52 srtTopBinds env (StgRec bs : binds) =
53 (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
55 (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
57 srts' = map (applyEnvList env) srts
59 -- Shorting out indirections in SRTs: if a binding has an SRT with a single
60 -- element in it, we just inline it with that element everywhere it occurs
63 -- This is in a way a generalisation of the CafInfo. CafInfo says
64 -- whether a top-level binding has *zero* CAF references, allowing us
65 -- to omit it from SRTs. Here, we pick up bindings with *one* CAF
66 -- reference, and inline its SRT everywhere it occurs. We could pass
67 -- this information across module boundaries too, but we currently
70 maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
71 | [one] <- varSetElems cafs
72 = extendVarEnv env bndr (applyEnv env one)
73 maybeExtendEnv env bndr _ = env
75 applyEnvList :: IdEnv Id -> [Id] -> [Id]
76 applyEnvList env = map (applyEnv env)
78 applyEnv env id = lookupVarEnv env id `orElse` id
80 -- ---- Top-level right hand sides:
82 srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
84 srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
85 srtTopRhs binder rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
86 = (srtRhs table rhs, elems)
88 elems = varSetElems cafs
89 table = mkVarEnv (zip elems [0..])
93 srtBind :: IdEnv Int -> StgBinding -> StgBinding
95 srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
96 srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
98 -- ---- Right Hand Sides:
100 srtRhs :: IdEnv Int -> StgRhs -> StgRhs
102 srtRhs table e@(StgRhsCon cc con args) = e
103 srtRhs table (StgRhsClosure cc bi free_vars u (SRTEntries cafs) args body)
104 = StgRhsClosure cc bi free_vars u (constructSRT table cafs) args
105 $! (srtExpr table body)
107 -- ---------------------------------------------------------------------------
110 srtExpr :: IdEnv Int -> StgExpr -> StgExpr
112 srtExpr table e@(StgApp f args) = e
113 srtExpr table e@(StgLit l) = e
114 srtExpr table e@(StgConApp con args) = e
115 srtExpr table e@(StgOpApp op args ty) = e
117 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
119 srtExpr table (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
121 expr' = srtExpr table scrut
122 srt_info = constructSRT table cafs_in_alts
123 alts' = srtCaseAlts table alts
125 StgCase expr' live1 live2 uniq srt_info alts'
127 srtExpr table (StgLet bind body)
128 = srtBind table bind =: \ bind' ->
129 srtExpr table body =: \ body' ->
132 srtExpr table (StgLetNoEscape live1 live2 bind body)
133 = srtBind table bind =: \ bind' ->
134 srtExpr table body =: \ body' ->
135 StgLetNoEscape live1 live2 bind' body'
138 srtExpr table expr = pprPanic "srtExpr" (ppr expr)
144 srtCaseAlts :: IdEnv Int -> StgCaseAlts -> StgCaseAlts
146 srtCaseAlts table (StgAlgAlts t alts dflt)
147 = (StgAlgAlts t $! map (srtAlgAlt table) alts) $! srtDefault table dflt
149 srtCaseAlts table (StgPrimAlts t alts dflt)
150 = (StgPrimAlts t $! map (srtPrimAlt table) alts) $! srtDefault table dflt
152 srtAlgAlt table (con,args,used,rhs)
153 = (,,,) con args used $! srtExpr table rhs
155 srtPrimAlt table (lit,rhs)
156 = (,) lit $! srtExpr table rhs
158 srtDefault table StgNoDefault = StgNoDefault
159 srtDefault table (StgBindDefault rhs)
160 = StgBindDefault $! srtExpr table rhs
162 -----------------------------------------------------------------------------
163 -- Construct an SRT bitmap.
165 constructSRT :: IdEnv Int -> IdSet -> SRT
166 constructSRT table entries
167 | isEmptyVarSet entries = NoSRT
168 | otherwise = SRT offset len bitmap
170 ints = map (expectJust "constructSRT" . lookupVarEnv table)
171 (varSetElems entries)
172 sorted_ints = sortLt (<) ints
173 offset = head sorted_ints
174 bitmap_entries = map (subtract offset) sorted_ints
175 len = last bitmap_entries + 1
176 bitmap = intsToBitmap len bitmap_entries
178 -- ---------------------------------------------------------------------------