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 VarEnv
  18 import Maybes           ( orElse, expectJust )
  19 import Bitmap           ( intsToBitmap )
  20
  21 #ifdef DEBUG
  22 import Outputable
  23 #endif
  24
  25 import List
  26
  27 import Util
  28 \end{code}
  29
  30 \begin{code}
  31 computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
  32   -- The incoming bindingd are filled with SRTEntries in their SRT slots
  33   -- the outgoing ones have NoSRT/SRT values instead
  34
  35 computeSRTs binds = srtTopBinds emptyVarEnv binds
  36
  37 -- --------------------------------------------------------------------------
  38 -- Top-level Bindings
  39
  40 srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
  41
  42 srtTopBinds env [] = []
  43 srtTopBinds env (StgNonRec b rhs : binds) =
  44   (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
  45   where
  46     (rhs', srt) = srtTopRhs b rhs
  47     env' = maybeExtendEnv env b rhs
  48     srt' = applyEnvList env srt
  49 srtTopBinds env (StgRec bs : binds) =
  50   (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
  51   where
  52     (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
  53     bndrs = map fst bs
  54     srts' = map (applyEnvList env) srts
  55
  56 -- Shorting out indirections in SRTs:  if a binding has an SRT with a single
  57 -- element in it, we just inline it with that element everywhere it occurs
  58 -- in other SRTs.
  59 --
  60 -- This is in a way a generalisation of the CafInfo.  CafInfo says
  61 -- whether a top-level binding has *zero* CAF references, allowing us
  62 -- to omit it from SRTs.  Here, we pick up bindings with *one* CAF
  63 -- reference, and inline its SRT everywhere it occurs.  We could pass
  64 -- this information across module boundaries too, but we currently
  65 -- don't.
  66
  67 maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
  68   | [one] <- varSetElems cafs
  69   = extendVarEnv env bndr (applyEnv env one)
  70 maybeExtendEnv env bndr _ = env
  71
  72 applyEnvList :: IdEnv Id -> [Id] -> [Id]
  73 applyEnvList env = map (applyEnv env)
  74
  75 applyEnv env id = lookupVarEnv env id `orElse` id
  76
  77 -- ----  Top-level right hand sides:
  78
  79 srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
  80
  81 srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
  82 srtTopRhs binder rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
  83   = (srtRhs table rhs, elems)
  84   where
  85         elems = varSetElems cafs
  86         table = mkVarEnv (zip elems [0..])
  87
  88 -- ---- Binds:
  89
  90 srtBind :: IdEnv Int -> StgBinding -> StgBinding
  91
  92 srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
  93 srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
  94
  95 -- ---- Right Hand Sides:
  96
  97 srtRhs :: IdEnv Int -> StgRhs -> StgRhs
  98
  99 srtRhs table e@(StgRhsCon cc con args) = e
 100 srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
 101   = StgRhsClosure cc bi free_vars u (constructSRT table srt) args
 102         $! (srtExpr table body)
 103
 104 -- ---------------------------------------------------------------------------
 105 -- Expressions
 106
 107 srtExpr :: IdEnv Int -> StgExpr -> StgExpr
 108
 109 srtExpr table e@(StgApp f args)         = e
 110 srtExpr table e@(StgLit l)              = e
 111 srtExpr table e@(StgConApp con args)    = e
 112 srtExpr table e@(StgOpApp op args ty)   = e
 113
 114 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
 115
 116 srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
 117
 118 srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
 119  = StgCase expr' live1 live2 uniq srt' alt_type alts'
 120  where
 121    expr' = srtExpr table scrut
 122    srt'  = constructSRT table srt
 123    alts' = map (srtAlt table) alts
 124
 125 srtExpr table (StgLet bind body)
 126   = srtBind table bind =: \ bind' ->
 127     srtExpr table body             =: \ body' ->
 128     StgLet bind' body'
 129
 130 srtExpr table (StgLetNoEscape live1 live2 bind body)
 131   = srtBind table bind =: \ bind' ->
 132     srtExpr table body             =: \ body' ->
 133     StgLetNoEscape live1 live2 bind' body'
 134
 135 #ifdef DEBUG
 136 srtExpr table expr = pprPanic "srtExpr" (ppr expr)
 137 #endif
 138
 139 srtAlt :: IdEnv Int -> StgAlt -> StgAlt
 140 srtAlt table (con,args,used,rhs)
 141   = (,,,) con args used $! srtExpr table rhs
 142
 143 -----------------------------------------------------------------------------
 144 -- Construct an SRT bitmap.
 145
 146 constructSRT :: IdEnv Int -> SRT -> SRT
 147 constructSRT table (SRTEntries entries)
 148  | isEmptyVarSet entries = NoSRT
 149  | otherwise  = SRT offset len bitmap
 150   where
 151     ints = map (expectJust "constructSRT" . lookupVarEnv table)
 152                 (varSetElems entries)
 153     sorted_ints = sortLe (<=) ints
 154     offset = head sorted_ints
 155     bitmap_entries = map (subtract offset) sorted_ints
 156     len = last bitmap_entries + 1
 157     bitmap = intsToBitmap len bitmap_entries
 158
 159 -- ---------------------------------------------------------------------------
 160 -- Misc stuff
 161
 162 a =: k  = k a
 163
 164 \end{code}