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