FIX #1744: ignore the byte-order mark at the beginning of a file
[ghc-hetmet.git] / 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/Commentary/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}