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 where
  11
  12 #include "HsVersions.h"
  13
  14 import Id        ( Id, idCafInfo )
  15 import IdInfo    ( CafInfo(..) )
  16 import StgSyn
  17
  18 import UniqFM
  19 import UniqSet
  20 import Panic
  21
  22 #ifdef DEBUG
  23 import Outputable
  24 #endif
  25 \end{code}
  26
  27 \begin{code}
  28 computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
  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         :: SrtOffset            -- next free offset within the SRT
  38         -> (UniqSet Id,         -- global refs in the continuation
  39             UniqFM (UniqSet Id))-- global refs in let-no-escaped variables
  40 {- * -} -> StgExpr              -- expression to analyse
  41
  42         -> (StgExpr,            -- (e) newly annotated expression
  43             UniqSet Id,         -- (g) global refs from this expression
  44             [Id],               -- (s) SRT required for this expression
  45             SrtOffset)          -- (o) new offset
  46
  47 (g) is a set containing all local top-level and imported ids referred
  48 to by the expression (e), which have MayHaveCafRefs in their CafInfo.
  49
  50 We build a single SRT for a recursive binding group, which is why the
  51 SRT building is done at the binding level rather than the
  52 StgRhsClosure level.
  53
  54 The SRT is built up in reverse order, to avoid too many expensive
  55 appends.  We therefore reverse the SRT before returning it, so that
  56 the offsets will be from the beginning of the SRT.
  57
  58 -----------------------------------------------------------------------------
  59 Top-level Bindings
  60
  61 A function whose CafInfo is NoCafRefs will have an empty SRT, and its
  62 closure will not appear in the SRT of any other function (unless we're
  63 compiling without optimisation and the CafInfos haven't been emitted
  64 in the interface files).
  65
  66 Top-Level recursive groups
  67
  68 This gets a bit complicated, but the general idea is that we want a
  69 single SRT for the whole group, and we'd rather not have recursive
  70 references in it if at all possible.
  71
  72 We collect all the global references for the group, and filter out
  73 those that are binders in the group and not CAFs themselves.  Why is
  74 it done this way?
  75
  76         - if all the bindings in the group just refer to each other,
  77           and none of them are CAFs, we'd like to get an empty SRT.
  78
  79         - if any of the bindings in the group refer to a CAF, this will
  80           appear in the SRT.
  81
  82 Hmm, that probably makes no sense.
  83
  84 \begin{code}
  85 srtTopBind
  86         :: StgBinding
  87         -> (StgBinding,                 -- the new binding
  88             [Id])                       -- the SRT for this binding
  89
  90 srtTopBind (StgNonRec binder rhs) =
  91
  92    -- no need to use circularity for non-recursive bindings
  93    srtRhs (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
  94                                         =: \(rhs, g, srt, off) ->
  95    let
  96         filtered_g = uniqSetToList g
  97         extra_refs = filter (`notElem` srt) filtered_g
  98         bind_srt   = reverse (extra_refs ++ srt)
  99    in
 100    ASSERT2(null bind_srt || mayHaveCafRefs binder, ppr binder)
 101
 102    case rhs of
 103         StgRhsClosure _ _ _ _ _ _ _ ->
 104             (StgNonRec binder (attach_srt_rhs rhs 0 (length bind_srt)),
 105              bind_srt)
 106
 107         -- don't output an SRT for the constructor
 108         StgRhsCon _ _ _    -> (StgNonRec binder rhs, [])
 109
 110
 111 srtTopBind (StgRec bs) =
 112     ASSERT(null bind_srt || all mayHaveCafRefs binders)
 113     (attach_srt_bind (StgRec new_bs) 0 (length bind_srt), bind_srt)
 114   where
 115     (binders,rhss) = unzip bs
 116
 117     non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
 118
 119     (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
 120
 121     -- filter out ourselves from the global references: it makes no
 122     -- sense to refer recursively to our SRT unless the recursive
 123     -- reference is required by a nested SRT.
 124     filtered_g = filter (\id -> id `notElem` non_caf_binders) (uniqSetToList g)
 125     extra_refs = filter (`notElem` srt) filtered_g
 126     bind_srt = reverse (extra_refs ++ srt)
 127
 128     doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
 129     doBinds ((binder,rhs):binds) new_binds g srt off =
 130         srtRhs (emptyUniqSet,emptyUFM) off rhs
 131                                 =: \(rhs, rhs_g, rhs_srt, off) ->
 132         let
 133             g'   = unionUniqSets rhs_g g
 134             srt' = rhs_srt ++ srt
 135         in
 136         doBinds binds ((binder,rhs):new_binds) g' srt' off
 137
 138 caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True
 139 caf_rhs _ = False
 140 \end{code}
 141
 142 -----------------------------------------------------------------------------
 143 Non-top-level bindings
 144
 145 \begin{code}
 146 srtBind :: (UniqSet Id, UniqFM (UniqSet Id))
 147         -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
 148
 149 srtBind cont_refs off (StgNonRec binder rhs) =
 150   srtRhs cont_refs off rhs   =: \(rhs, g, srt, off) ->
 151   (StgNonRec binder rhs, g, srt, off)
 152
 153 srtBind cont_refs off (StgRec binds) =
 154   (StgRec new_binds, g, srt, new_off)
 155   where
 156     -- process each binding
 157     (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
 158
 159     doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
 160     doBinds ((binder,rhs):binds) g srt off new_binds =
 161         srtRhs cont_refs off rhs   =: \(rhs, g', srt', off) ->
 162         doBinds binds (unionUniqSets g g') (srt'++srt) off
 163                 ((binder,rhs):new_binds)
 164 \end{code}
 165
 166 -----------------------------------------------------------------------------
 167 Right Hand Sides
 168
 169 \begin{code}
 170 srtRhs  :: (UniqSet Id, UniqFM (UniqSet Id))
 171         -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
 172
 173 srtRhs cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
 174     srtExpr cont off body       =: \(body, g, srt, off) ->
 175     (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
 176
 177 srtRhs cont off e@(StgRhsCon cc con args) =
 178     (e, getGlobalRefs args, [], off)
 179 \end{code}
 180
 181 -----------------------------------------------------------------------------
 182 Expressions
 183
 184 \begin{code}
 185 srtExpr :: (UniqSet Id, UniqFM (UniqSet Id))
 186         -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
 187
 188 srtExpr (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
 189   where global_refs =
 190                 cont `unionUniqSets`
 191                 getGlobalRefs (StgVarArg f:args) `unionUniqSets`
 192                 lookupPossibleLNE lne f
 193
 194 srtExpr (cont,lne) off e@(StgLit l) = (e, cont, [], off)
 195
 196 srtExpr (cont,lne) off e@(StgConApp con args) =
 197    (e, cont `unionUniqSets` getGlobalRefs args, [], off)
 198
 199 srtExpr (cont,lne) off e@(StgPrimApp op args ty) =
 200    (e, cont `unionUniqSets` getGlobalRefs args, [], off)
 201
 202 srtExpr c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
 203    srtCaseAlts c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
 204
 205         -- construct the SRT for this case
 206    let (this_srt, scrut_off) = construct_srt alts_g alts_srt alts_off in
 207
 208         -- global refs in the continuation is alts_g.
 209    srtExpr (alts_g,lne) scrut_off scrut
 210                                 =: \(scrut, scrut_g, scrut_srt, case_off) ->
 211    let
 212         g = unionUniqSets alts_g scrut_g
 213         srt = scrut_srt ++ this_srt
 214         srt_info = case length this_srt of
 215                         0   -> NoSRT
 216                         len -> SRT off len
 217    in
 218    (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
 219
 220 srtExpr cont off (StgLet bind body) =
 221    srtLet cont off bind body StgLet (\_ cont -> cont)
 222
 223 srtExpr cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
 224   = srtLet cont off b body (StgLetNoEscape live1 live2) calc_cont
 225   where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g)
 226
 227 -- for recursive let-no-escapes, we do *two* passes, the first time
 228 -- just to extract the list of global refs, and the second time we actually
 229 -- construct the SRT now that we know what global refs should be in
 230 -- the various let-no-escape continuations.
 231 srtExpr conts@(cont,lne) off
 232         (StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
 233   = srtBind conts off bind =: \(_, g, _, _) ->
 234     let
 235         lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
 236         calc_cont _ conts = conts
 237     in
 238     srtLet (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
 239
 240
 241 srtExpr cont off (StgSCC cc expr) =
 242    srtExpr cont off expr        =: \(expr, g, srt, off) ->
 243    (StgSCC cc expr, g, srt, off)
 244
 245 #ifdef DEBUG
 246 srtExpr cont off expr = pprPanic "srtExpr" (ppr expr)
 247 #else
 248 srtExpr cont off expr = panic "srtExpr"
 249 #endif
 250 \end{code}
 251
 252 -----------------------------------------------------------------------------
 253 Let-expressions
 254
 255 This is quite complicated stuff...
 256
 257 \begin{code}
 258 srtLet cont off bind body let_constr calc_cont
 259
 260  -- If the bindings are all constructors, then we don't need to
 261  -- buid an SRT at all...
 262  | all_con_binds bind =
 263    srtBind cont off bind        =: \(bind, bind_g, bind_srt, off) ->
 264    srtExpr cont off body        =: \(body, body_g, body_srt, off) ->
 265    let
 266         g   = unionUniqSets bind_g body_g
 267         srt = body_srt ++ bind_srt
 268    in
 269    (let_constr bind body, g, srt, off)
 270
 271  -- we have some closure bindings...
 272  | otherwise =
 273
 274     -- first, find the sub-SRTs in the binding
 275    srtBind cont off bind        =: \(bind, bind_g, bind_srt, bind_off) ->
 276
 277     -- construct the SRT for this binding
 278    let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in
 279
 280     -- get the new continuation information (if a let-no-escape)
 281    let new_cont = calc_cont bind_g cont in
 282
 283     -- now find the SRTs in the body
 284    srtExpr new_cont body_off body  =: \(body, body_g, body_srt, let_off) ->
 285
 286    let
 287         -- union all the global references together
 288        let_g   = unionUniqSets bind_g body_g
 289
 290         -- concatenate the sub-SRTs
 291        let_srt = body_srt ++ this_srt
 292
 293         -- attach the SRT info to the binding
 294        bind' = attach_srt_bind bind off (length this_srt)
 295    in
 296    (let_constr bind' body, let_g, let_srt, let_off)
 297 \end{code}
 298
 299 -----------------------------------------------------------------------------
 300 Construct an SRT.
 301
 302 Construct the SRT at this point from its sub-SRTs and any new global
 303 references which aren't already contained in one of the sub-SRTs (and
 304 which are "live").
 305
 306 \begin{code}
 307 construct_srt global_refs sub_srt current_offset
 308    = let
 309        extra_refs = filter (`notElem` sub_srt) (uniqSetToList global_refs)
 310        this_srt = extra_refs ++ sub_srt
 311
 312         -- Add the length of the new entries to the
 313         -- current offset to get the next free offset in the global SRT.
 314        new_offset = current_offset + length extra_refs
 315    in (this_srt, new_offset)
 316 \end{code}
 317
 318 -----------------------------------------------------------------------------
 319 Case Alternatives
 320
 321 \begin{code}
 322 srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id))
 323         -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
 324
 325 srtCaseAlts cont off (StgAlgAlts t alts dflt) =
 326    srtAlgAlts cont off alts [] emptyUniqSet []
 327                                   =: \(alts, alts_g, alts_srt, off) ->
 328    srtDefault cont off dflt       =: \(dflt, dflt_g, dflt_srt, off) ->
 329    let
 330         g   = unionUniqSets alts_g dflt_g
 331         srt = dflt_srt ++ alts_srt
 332    in
 333    (StgAlgAlts t alts dflt, g, srt, off)
 334
 335 srtCaseAlts cont off (StgPrimAlts t alts dflt) =
 336    srtPrimAlts cont off alts [] emptyUniqSet []
 337                                    =: \(alts, alts_g, alts_srt, off) ->
 338    srtDefault cont off dflt        =: \(dflt, dflt_g, dflt_srt, off) ->
 339    let
 340         g   = unionUniqSets alts_g dflt_g
 341         srt = dflt_srt ++ alts_srt
 342    in
 343    (StgPrimAlts t alts dflt, g, srt, off)
 344
 345 srtAlgAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
 346 srtAlgAlts cont off ((con,args,used,rhs):alts) new_alts g srt =
 347    srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
 348    let
 349         g'   = unionUniqSets rhs_g g
 350         srt' = rhs_srt ++ srt
 351    in
 352    srtAlgAlts cont off alts ((con,args,used,rhs) : new_alts) g' srt'
 353
 354 srtPrimAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
 355 srtPrimAlts cont off ((lit,rhs):alts) new_alts g srt =
 356    srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
 357    let
 358         g'   = unionUniqSets rhs_g g
 359         srt' = rhs_srt ++ srt
 360    in
 361    srtPrimAlts cont off alts ((lit,rhs) : new_alts) g' srt'
 362
 363 srtDefault cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
 364 srtDefault cont off (StgBindDefault rhs) =
 365    srtExpr cont off rhs =: \(rhs, g, srt, off) ->
 366    (StgBindDefault rhs, g, srt, off)
 367 \end{code}
 368
 369 -----------------------------------------------------------------------------
 370
 371 Here we decide which Id's to place in the static reference table.  An
 372 internal top-level id will be in the environment with the appropriate
 373 CafInfo, so we use that if available.  An imported top-level Id will
 374 have the CafInfo attached.  Otherwise, we just ignore the Id.
 375
 376 \begin{code}
 377 getGlobalRefs :: [StgArg] -> UniqSet Id
 378 getGlobalRefs args = mkUniqSet (concat (map globalRefArg args))
 379
 380 globalRefArg :: StgArg -> [Id]
 381 globalRefArg (StgVarArg id)
 382   | mayHaveCafRefs id = [id]
 383   | otherwise         = []
 384 globalRefArg _ = []
 385
 386 mayHaveCafRefs id
 387  = case idCafInfo id of
 388         MayHaveCafRefs -> True
 389         NoCafRefs      -> False
 390 \end{code}
 391
 392 -----------------------------------------------------------------------------
 393 Misc stuff
 394
 395 \begin{code}
 396 attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding
 397 attach_srt_bind (StgNonRec binder rhs) off len =
 398         StgNonRec binder (attach_srt_rhs rhs off len)
 399 attach_srt_bind (StgRec binds) off len =
 400         StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ]
 401
 402 attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs
 403 attach_srt_rhs (StgRhsCon cc con args) off length
 404   = StgRhsCon cc con args
 405 attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length
 406   = StgRhsClosure cc bi srt free upd args rhs
 407   where
 408         srt | length == 0 = NoSRT
 409             | otherwise   = SRT off length
 410
 411
 412 all_con_binds (StgNonRec x rhs) = con_rhs rhs
 413 all_con_binds (StgRec bs) = all con_rhs (map snd bs)
 414
 415 con_rhs (StgRhsCon _ _ _) = True
 416 con_rhs _ = False
 417
 418
 419 a =: k  = k a
 420 \end{code}
 421
 422 -----------------------------------------------------------------------------
 423 Fix up the SRT's in a let-no-escape.
 424
 425 (for a description of let-no-escapes, see CgLetNoEscape.lhs)
 426
 427 Here's the problem: a let-no-escape isn't represented by an activation
 428 record on the stack.  It seems either very difficult or impossible to
 429 get the liveness bitmap right in the info table, so we don't do it
 430 this way (the liveness mask isn't constant).
 431
 432 So, the question is how does the garbage collector get access to the
 433 SRT for the rhs of the let-no-escape?  It can't see an info table, so
 434 it must get the SRT from somewhere else.  Here's an example:
 435
 436    let-no-escape x = .... f ....
 437    in  case blah of
 438            p -> .... x ... g ....
 439
 440 (f and g are global).  Suppose we garbage collect while evaluating
 441 'blah'.  The stack will contain an activation record for the case,
 442 which will point to an SRT containing [g] (according to our SRT
 443 algorithm above).  But, since the case continuation can call x, and
 444 hence f, the SRT should really be [f,g].
 445
 446 another example:
 447
 448    let-no-escape {-rec-} z =  \x -> case blah of
 449                                       p1 ->  .... f ...
 450                                       p2 ->  case blah2 of
 451                                                 p -> .... (z x') ...
 452    in ....
 453
 454 if we GC while evaluating blah2, then the case continuation on the
 455 stack needs to refer to [f] in its SRT, because we can reach f by
 456 calling z recursively.
 457
 458 FIX:
 459
 460 We keep track of the global references made by each let-no-escape in
 461 scope, so we can expand them every time the let-no-escape is
 462 referenced.
 463
 464 \begin{code}
 465 lookupPossibleLNE lne_env f =
 466   case lookupUFM lne_env f of
 467         Nothing   -> emptyUniqSet
 468         Just refs -> refs
 469 \end{code}