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