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