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 {-# OPTIONS -fno-warn-incomplete-patterns #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 module SRT( computeSRTs ) where
19 -- XXX This define is a bit of a hack, and should be done more nicely
20 #define FAST_STRING_NOT_NEEDED 1
21 #include "HsVersions.h"
27 import Maybes ( orElse, expectJust )
38 computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
39 -- The incoming bindingd are filled with SRTEntries in their SRT slots
40 -- the outgoing ones have NoSRT/SRT values instead
42 computeSRTs binds = srtTopBinds emptyVarEnv binds
44 -- --------------------------------------------------------------------------
47 srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
50 srtTopBinds env (StgNonRec b rhs : binds) =
51 (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
53 (rhs', srt) = srtTopRhs b rhs
54 env' = maybeExtendEnv env b rhs
55 srt' = applyEnvList env srt
56 srtTopBinds env (StgRec bs : binds) =
57 (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
59 (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
61 srts' = map (applyEnvList env) srts
63 -- Shorting out indirections in SRTs: if a binding has an SRT with a single
64 -- element in it, we just inline it with that element everywhere it occurs
67 -- This is in a way a generalisation of the CafInfo. CafInfo says
68 -- whether a top-level binding has *zero* CAF references, allowing us
69 -- to omit it from SRTs. Here, we pick up bindings with *one* CAF
70 -- reference, and inline its SRT everywhere it occurs. We could pass
71 -- this information across module boundaries too, but we currently
74 maybeExtendEnv ::IdEnv Id -> Id -> StgRhs -> IdEnv Id
75 maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
76 | [one] <- varSetElems cafs
77 = extendVarEnv env bndr (applyEnv env one)
78 maybeExtendEnv env _ _ = env
80 applyEnvList :: IdEnv Id -> [Id] -> [Id]
81 applyEnvList env = map (applyEnv env)
83 applyEnv :: IdEnv Id -> Id -> Id
84 applyEnv env id = lookupVarEnv env id `orElse` id
86 -- ---- Top-level right hand sides:
88 srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
90 srtTopRhs _ rhs@(StgRhsCon _ _ _) = (rhs, [])
91 srtTopRhs _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
92 = (srtRhs table rhs, elems)
94 elems = varSetElems cafs
95 table = mkVarEnv (zip elems [0..])
99 srtBind :: IdEnv Int -> StgBinding -> StgBinding
101 srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
102 srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
104 -- ---- Right Hand Sides:
106 srtRhs :: IdEnv Int -> StgRhs -> StgRhs
108 srtRhs _ e@(StgRhsCon _ _ _) = e
109 srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
110 = StgRhsClosure cc bi free_vars u (constructSRT table srt) args
111 $! (srtExpr table body)
113 -- ---------------------------------------------------------------------------
116 srtExpr :: IdEnv Int -> StgExpr -> StgExpr
118 srtExpr _ e@(StgApp _ _) = e
119 srtExpr _ e@(StgLit _) = e
120 srtExpr _ e@(StgConApp _ _) = e
121 srtExpr _ e@(StgOpApp _ _ _) = e
123 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
125 srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
127 srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
128 = StgCase expr' live1 live2 uniq srt' alt_type alts'
130 expr' = srtExpr table scrut
131 srt' = constructSRT table srt
132 alts' = map (srtAlt table) alts
134 srtExpr table (StgLet bind body)
135 = srtBind table bind =: \ bind' ->
136 srtExpr table body =: \ body' ->
139 srtExpr table (StgLetNoEscape live1 live2 bind body)
140 = srtBind table bind =: \ bind' ->
141 srtExpr table body =: \ body' ->
142 StgLetNoEscape live1 live2 bind' body'
144 srtExpr _table expr = pprPanic "srtExpr" (ppr expr)
146 srtAlt :: IdEnv Int -> StgAlt -> StgAlt
147 srtAlt table (con,args,used,rhs)
148 = (,,,) con args used $! srtExpr table rhs
150 -----------------------------------------------------------------------------
151 -- Construct an SRT bitmap.
153 constructSRT :: IdEnv Int -> SRT -> SRT
154 constructSRT table (SRTEntries entries)
155 | isEmptyVarSet entries = NoSRT
156 | otherwise = seqBitmap bitmap $ SRT offset len bitmap
158 ints = map (expectJust "constructSRT" . lookupVarEnv table)
159 (varSetElems entries)
160 sorted_ints = sortLe (<=) ints
161 offset = head sorted_ints
162 bitmap_entries = map (subtract offset) sorted_ints
163 len = last bitmap_entries + 1
164 bitmap = intsToBitmap len bitmap_entries
166 -- ---------------------------------------------------------------------------
169 (=:) :: a -> (a -> b) -> b