ghc/compiler/simplStg/SRT.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4
   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.
   8
   9 \begin{code}
  10 module SRT( computeSRTs ) where
  11
  12 #include "HsVersions.h"
  13
  14 import StgSyn
  15 import Id               ( Id )
  16 import VarSet
  17 import BasicTypes       ( TopLevelFlag(..), isTopLevel )
  18 import Util             ( mapAccumL )
  19
  20 #ifdef DEBUG
  21 import Util             ( lengthIs )
  22 import Outputable
  23 #endif
  24 \end{code}
  25
  26 \begin{code}
  27 computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
  28   -- The incoming bindingd are filled with SRTEntries in their SRT slots
  29   -- the outgoing ones have NoSRT/SRT values instead
  30
  31 computeSRTs binds = map srtTopBind binds
  32 \end{code}
  33
  34 -----------------------------------------------------------------------------
  35 Algorithm for figuring out SRT layout.
  36
  37 Our functions have type
  38
  39 srtExpr :: SrtOffset            -- Next free offset within the SRT
  40         -> StgExpr              -- Expression to analyse
  41         -> (StgExpr,            -- (e) newly annotated expression
  42             SrtIds,             -- (s) SRT required for this expression (reversed)
  43             SrtOffset)          -- (o) new offset
  44
  45 We build a single SRT for a recursive binding group, which is why the
  46 SRT building is done at the binding level rather than the
  47 StgRhsClosure level.
  48
  49 The SRT is built up in reverse order, to avoid too many expensive
  50 appends.  We therefore reverse the SRT before returning it, so that
  51 the offsets will be from the beginning of the SRT.
  52
  53 -----------------------------------------------------------------------------
  54 Top-level Bindings
  55
  56 A function whose CafInfo is NoCafRefs will have an empty SRT, and its
  57 closure will not appear in the SRT of any other function (unless we're
  58 compiling without optimisation and the CafInfos haven't been emitted
  59 in the interface files).
  60
  61 Top-Level recursive groups
  62
  63 This gets a bit complicated, but the general idea is that we want a
  64 single SRT for the whole group, and we'd rather not have recursive
  65 references in it if at all possible.
  66
  67 We collect all the global references for the group, and filter out
  68 those that are binders in the group and not CAFs themselves.  Why is
  69 it done this way?
  70
  71         - if all the bindings in the group just refer to each other,
  72           and none of them are CAFs, we'd like to get an empty SRT.
  73
  74         - if any of the bindings in the group refer to a CAF, this will
  75           appear in the SRT.
  76
  77 Hmm, that probably makes no sense.
  78
  79 \begin{code}
  80 type SrtOffset = Int
  81 type SrtIds    = [Id]  -- An *reverse-ordered* list of the Ids needed in the SRT
  82
  83 srtTopBind :: StgBinding -> (StgBinding, SrtIds)
  84
  85 srtTopBind bind
  86   = srtBind TopLevel 0 bind     =: \ (bind', srt, off) ->
  87     if isConBind bind'
  88         then (bind', [])           -- Don't need an SRT for a static constructor
  89         else (bind', reverse srt)  -- The 'reverse' is because the SRT is
  90                                    -- built up reversed, for efficiency's sake
  91
  92 isConBind (StgNonRec _ _ r) = isConRhs r
  93 isConBind (StgRec _ bs)     = all isConRhs (map snd bs)
  94
  95 isConRhs (StgRhsCon _ _ _) = True
  96 isConRhs _                 = False
  97
  98 srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
  99         -> (StgBinding, SrtIds, SrtOffset)
 100
 101 srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs)
 102   = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
 103   where
 104     (new_rhs,  rhs_srt,  rhs_off)  = srtRhs off rhs
 105     (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
 106
 107
 108 srtBind top off (StgRec (SRTEntries rhss_cafs) pairs)
 109   = (StgRec srt_info new_pairs, this_srt, body_off)
 110   where
 111     ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
 112
 113     do_bind (off,srt) (bndr,rhs)
 114         = srtRhs off rhs                =: \(rhs', srt', off') ->
 115           ((off', srt'++srt), (bndr, rhs'))
 116
 117     non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
 118
 119     filtered_rhss_cafs
 120         | isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
 121         | otherwise      = rhss_cafs
 122
 123     (srt_info, this_srt, body_off)
 124          = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
 125
 126 caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
 127 caf_rhs _ = False
 128 \end{code}
 129
 130 -----------------------------------------------------------------------------
 131 Right Hand Sides
 132
 133 \begin{code}
 134 srtRhs  :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
 135
 136 srtRhs off (StgRhsClosure cc bi free_vars u args body)
 137   = srtExpr off body                    =: \(body, srt, off) ->
 138     (StgRhsClosure cc bi free_vars u args body, srt, off)
 139
 140 srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
 141 \end{code}
 142
 143 -----------------------------------------------------------------------------
 144 Expressions
 145
 146 \begin{code}
 147 srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
 148
 149 srtExpr off e@(StgApp f args)       = (e, [], off)
 150 srtExpr off e@(StgLit l)            = (e, [], off)
 151 srtExpr off e@(StgConApp con args)  = (e, [], off)
 152 srtExpr off e@(StgOpApp op args ty) = (e, [], off)
 153
 154 srtExpr off (StgSCC cc expr) =
 155    srtExpr off expr     =: \(expr, srt, off) ->
 156    (StgSCC cc expr, srt, off)
 157
 158 srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
 159  = srtCaseAlts off alts         =: \(alts, alts_srt, alts_off) ->
 160    let
 161         (srt_info, this_srt, scrut_off)
 162                 = constructSRT cafs_in_alts alts_srt off alts_off
 163    in
 164    srtExpr scrut_off scrut      =: \(scrut, scrut_srt, case_off) ->
 165
 166    (StgCase scrut live1 live2 uniq srt_info alts,
 167     scrut_srt ++ this_srt,
 168     case_off)
 169
 170 srtExpr off (StgLet bind body)
 171   = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
 172     srtExpr body_off body       =: \ (body', expr_srt, let_off) ->
 173     (StgLet bind' body', expr_srt ++ bind_srt, let_off)
 174
 175 srtExpr off (StgLetNoEscape live1 live2 bind body)
 176   = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
 177     srtExpr body_off body       =: \ (body', expr_srt, let_off) ->
 178     (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)
 179
 180 #ifdef DEBUG
 181 srtExpr off expr = pprPanic "srtExpr" (ppr expr)
 182 #endif
 183 \end{code}
 184
 185 -----------------------------------------------------------------------------
 186 Construct an SRT.
 187
 188 Construct the SRT at this point from its sub-SRTs and any new global
 189 references which aren't already contained in one of the sub-SRTs (and
 190 which are "live").
 191
 192 \begin{code}
 193 constructSRT caf_refs sub_srt initial_offset current_offset
 194    = let
 195        extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs)
 196        this_srt   = extra_refs ++ sub_srt
 197
 198         -- Add the length of the new entries to the
 199         -- current offset to get the next free offset in the global SRT.
 200        new_offset = current_offset + length extra_refs
 201        srt_length = new_offset - initial_offset
 202
 203        srt_info | srt_length == 0 = NoSRT
 204                 | otherwise       = SRT initial_offset srt_length
 205
 206    in ASSERT( this_srt `lengthIs` srt_length )
 207       (srt_info, this_srt, new_offset)
 208 \end{code}
 209
 210 -----------------------------------------------------------------------------
 211 Case Alternatives
 212
 213 \begin{code}
 214 srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
 215
 216 srtCaseAlts off (StgAlgAlts t alts dflt)
 217   = srtDefault off dflt                                 =: \ ((dflt_off, dflt_srt), dflt') ->
 218     mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts       =: \ ((alts_off, alts_srt), alts') ->
 219     (StgAlgAlts t alts' dflt', alts_srt, alts_off)
 220
 221 srtCaseAlts off (StgPrimAlts t alts dflt)
 222   = srtDefault off dflt                                 =: \ ((dflt_off, dflt_srt), dflt') ->
 223     mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts      =: \ ((alts_off, alts_srt), alts') ->
 224     (StgPrimAlts t alts' dflt', alts_srt, alts_off)
 225
 226 srtAlgAlt (off,srt) (con,args,used,rhs)
 227   = srtExpr off rhs     =: \(rhs', rhs_srt, rhs_off) ->
 228     ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
 229
 230 srtPrimAlt (off,srt) (lit,rhs)
 231   = srtExpr off rhs     =: \(rhs', rhs_srt, rhs_off) ->
 232     ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
 233
 234 srtDefault off StgNoDefault
 235   = ((off,[]), StgNoDefault)
 236 srtDefault off (StgBindDefault rhs)
 237   = srtExpr off rhs     =: \(rhs', srt, off) ->
 238     ((off,srt), StgBindDefault rhs')
 239 \end{code}
 240
 241 -----------------------------------------------------------------------------
 242 Misc stuff
 243
 244 \begin{code}
 245 a =: k  = k a
 246 \end{code}