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