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