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 Maybes ( orElse, expectJust )
19 import Bitmap ( intsToBitmap )
31 computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
32 -- The incoming bindingd are filled with SRTEntries in their SRT slots
33 -- the outgoing ones have NoSRT/SRT values instead
35 computeSRTs binds = srtTopBinds emptyVarEnv binds
37 -- --------------------------------------------------------------------------
40 srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
42 srtTopBinds env [] = []
43 srtTopBinds env (StgNonRec b rhs : binds) =
44 (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
46 (rhs', srt) = srtTopRhs b rhs
47 env' = maybeExtendEnv env b rhs
48 srt' = applyEnvList env srt
49 srtTopBinds env (StgRec bs : binds) =
50 (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
52 (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
54 srts' = map (applyEnvList env) srts
56 -- Shorting out indirections in SRTs: if a binding has an SRT with a single
57 -- element in it, we just inline it with that element everywhere it occurs
60 -- This is in a way a generalisation of the CafInfo. CafInfo says
61 -- whether a top-level binding has *zero* CAF references, allowing us
62 -- to omit it from SRTs. Here, we pick up bindings with *one* CAF
63 -- reference, and inline its SRT everywhere it occurs. We could pass
64 -- this information across module boundaries too, but we currently
67 maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
68 | [one] <- varSetElems cafs
69 = extendVarEnv env bndr (applyEnv env one)
70 maybeExtendEnv env bndr _ = env
72 applyEnvList :: IdEnv Id -> [Id] -> [Id]
73 applyEnvList env = map (applyEnv env)
75 applyEnv env id = lookupVarEnv env id `orElse` id
77 -- ---- Top-level right hand sides:
79 srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
81 srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
82 srtTopRhs binder rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
83 = (srtRhs table rhs, elems)
85 elems = varSetElems cafs
86 table = mkVarEnv (zip elems [0..])
90 srtBind :: IdEnv Int -> StgBinding -> StgBinding
92 srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
93 srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
95 -- ---- Right Hand Sides:
97 srtRhs :: IdEnv Int -> StgRhs -> StgRhs
99 srtRhs table e@(StgRhsCon cc con args) = e
100 srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
101 = StgRhsClosure cc bi free_vars u (constructSRT table srt) args
102 $! (srtExpr table body)
104 -- ---------------------------------------------------------------------------
107 srtExpr :: IdEnv Int -> StgExpr -> StgExpr
109 srtExpr table e@(StgApp f args) = e
110 srtExpr table e@(StgLit l) = e
111 srtExpr table e@(StgConApp con args) = e
112 srtExpr table e@(StgOpApp op args ty) = e
114 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
116 srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
118 srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
119 = StgCase expr' live1 live2 uniq srt' alt_type alts'
121 expr' = srtExpr table scrut
122 srt' = constructSRT table srt
123 alts' = map (srtAlt table) alts
125 srtExpr table (StgLet bind body)
126 = srtBind table bind =: \ bind' ->
127 srtExpr table body =: \ body' ->
130 srtExpr table (StgLetNoEscape live1 live2 bind body)
131 = srtBind table bind =: \ bind' ->
132 srtExpr table body =: \ body' ->
133 StgLetNoEscape live1 live2 bind' body'
136 srtExpr table expr = pprPanic "srtExpr" (ppr expr)
139 srtAlt :: IdEnv Int -> StgAlt -> StgAlt
140 srtAlt table (con,args,used,rhs)
141 = (,,,) con args used $! srtExpr table rhs
143 -----------------------------------------------------------------------------
144 -- Construct an SRT bitmap.
146 constructSRT :: IdEnv Int -> SRT -> SRT
147 constructSRT table (SRTEntries entries)
148 | isEmptyVarSet entries = NoSRT
149 | otherwise = SRT offset len bitmap
151 ints = map (expectJust "constructSRT" . lookupVarEnv table)
152 (varSetElems entries)
153 sorted_ints = sortLe (<=) ints
154 offset = head sorted_ints
155 bitmap_entries = map (subtract offset) sorted_ints
156 len = last bitmap_entries + 1
157 bitmap = intsToBitmap len bitmap_entries
159 -- ---------------------------------------------------------------------------