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