Cleanup StgCmm pass
[ghc.git] / compiler / codeGen / StgCmmEnv.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation: the binding environment
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8 module StgCmmEnv (
9 CgIdInfo,
10
11 litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
12 idInfoToAmode,
13
14 NonVoid(..), unsafe_stripNV, isVoidId, nonVoidIds,
15
16 addBindC, addBindsC,
17
18 bindArgsToRegs, bindToReg, rebindToReg,
19 bindArgToReg, idToReg,
20 getArgAmode, getNonVoidArgAmodes,
21 getCgIdInfo,
22 maybeLetNoEscape,
23 ) where
24
25 #include "HsVersions.h"
26
27 import TyCon
28 import StgCmmMonad
29 import StgCmmUtils
30 import StgCmmClosure
31
32 import CLabel
33
34 import DynFlags
35 import MkGraph
36 import BlockId
37 import CmmExpr
38 import CmmUtils
39 import FastString
40 import Id
41 import VarEnv
42 import Control.Monad
43 import Name
44 import StgSyn
45 import Outputable
46
47 -------------------------------------
48 -- Non-void types
49 -------------------------------------
50 -- We frequently need the invariant that an Id or a an argument
51 -- is of a non-void type. This type is a witness to the invariant.
52
53 newtype NonVoid a = NonVoid a
54 deriving (Eq, Show)
55
56 -- Use with care; if used inappropriately, it could break invariants.
57 unsafe_stripNV :: NonVoid a -> a
58 unsafe_stripNV (NonVoid a) = a
59
60 instance (Outputable a) => Outputable (NonVoid a) where
61 ppr (NonVoid a) = ppr a
62
63 isVoidId :: Id -> Bool
64 isVoidId = isVoidRep . idPrimRep
65
66 nonVoidIds :: [Id] -> [NonVoid Id]
67 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
68
69 -------------------------------------
70 -- Manipulating CgIdInfo
71 -------------------------------------
72
73 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
74 mkCgIdInfo id lf expr
75 = CgIdInfo { cg_id = id, cg_lf = lf
76 , cg_loc = CmmLoc expr }
77
78 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
79 litIdInfo dflags id lf lit
80 = CgIdInfo { cg_id = id, cg_lf = lf
81 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
82 where
83 tag = lfDynTag dflags lf
84
85 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
86 lneIdInfo dflags id regs
87 = CgIdInfo { cg_id = id, cg_lf = lf
88 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
89 where
90 lf = mkLFLetNoEscape
91 blk_id = mkBlockId (idUnique id)
92
93
94 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
95 rhsIdInfo id lf_info
96 = do dflags <- getDynFlags
97 reg <- newTemp (gcWord dflags)
98 return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
99
100 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
101 mkRhsInit dflags reg lf_info expr
102 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
103
104 idInfoToAmode :: CgIdInfo -> CmmExpr
105 -- Returns a CmmExpr for the *tagged* pointer
106 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
107 idInfoToAmode cg_info
108 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
109
110 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
111 -- A tag adds a byte offset to the pointer
112 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
113
114 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
115 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
116 maybeLetNoEscape _other = Nothing
117
118
119
120 ---------------------------------------------------------
121 -- The binding environment
122 --
123 -- There are three basic routines, for adding (addBindC),
124 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
125 ---------------------------------------------------------
126
127 addBindC :: CgIdInfo -> FCode ()
128 addBindC stuff_to_bind = do
129 binds <- getBinds
130 setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
131
132 addBindsC :: [CgIdInfo] -> FCode ()
133 addBindsC new_bindings = do
134 binds <- getBinds
135 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
136 binds
137 new_bindings
138 setBinds new_binds
139
140 getCgIdInfo :: Id -> FCode CgIdInfo
141 getCgIdInfo id
142 = do { dflags <- getDynFlags
143 ; local_binds <- getBinds -- Try local bindings first
144 ; case lookupVarEnv local_binds id of {
145 Just info -> return info ;
146 Nothing -> do {
147
148 -- Should be imported; make up a CgIdInfo for it
149 let name = idName id
150 ; if isExternalName name then
151 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
152 in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
153 else
154 cgLookupPanic id -- Bug
155 }}}
156
157 cgLookupPanic :: Id -> FCode a
158 cgLookupPanic id
159 = do local_binds <- getBinds
160 pprPanic "StgCmmEnv: variable not found"
161 (vcat [ppr id,
162 ptext (sLit "local binds for:"),
163 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
164 ])
165
166
167 --------------------
168 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
169 getArgAmode (NonVoid (StgVarArg var)) =
170 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
171 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
172
173 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
174 -- NB: Filters out void args,
175 -- so the result list may be shorter than the argument list
176 getNonVoidArgAmodes [] = return []
177 getNonVoidArgAmodes (arg:args)
178 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
179 | otherwise = do { amode <- getArgAmode (NonVoid arg)
180 ; amodes <- getNonVoidArgAmodes args
181 ; return ( amode : amodes ) }
182
183 ------------------------------------------------------------------------
184 -- Interface functions for binding and re-binding names
185 ------------------------------------------------------------------------
186
187 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
188 -- Bind an Id to a fresh LocalReg
189 bindToReg nvid@(NonVoid id) lf_info
190 = do dflags <- getDynFlags
191 let reg = idToReg dflags nvid
192 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
193 return reg
194
195 rebindToReg :: NonVoid Id -> FCode LocalReg
196 -- Like bindToReg, but the Id is already in scope, so
197 -- get its LF info from the envt
198 rebindToReg nvid@(NonVoid id)
199 = do { info <- getCgIdInfo id
200 ; bindToReg nvid (cg_lf info) }
201
202 bindArgToReg :: NonVoid Id -> FCode LocalReg
203 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
204
205 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
206 bindArgsToRegs args = mapM bindArgToReg args
207
208 idToReg :: DynFlags -> NonVoid Id -> LocalReg
209 -- Make a register from an Id, typically a function argument,
210 -- free variable, or case binder
211 --
212 -- We re-use the Unique from the Id to make it easier to see what is going on
213 --
214 -- By now the Ids should be uniquely named; else one would worry
215 -- about accidental collision
216 idToReg dflags (NonVoid id)
217 = LocalReg (idUnique id)
218 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
219 _ -> primRepCmmType dflags (idPrimRep id))
220
221