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