Pass DynFlags down to bWord
[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 DynFlags
45 import MkGraph
46 import BlockId
47 import CmmExpr
48 import CmmUtils
49 import FastString
50 import Id
51 import VarEnv
52 import Control.Monad
53 import Name
54 import StgSyn
55 import Outputable
56
57 -------------------------------------
58 -- Non-void types
59 -------------------------------------
60 -- We frequently need the invariant that an Id or a an argument
61 -- is of a non-void type. This type is a witness to the invariant.
62
63 newtype NonVoid a = NonVoid a
64 deriving (Eq, Show)
65
66 instance (Outputable a) => Outputable (NonVoid a) where
67 ppr (NonVoid a) = ppr a
68
69 isVoidId :: Id -> Bool
70 isVoidId = isVoidRep . idPrimRep
71
72 nonVoidIds :: [Id] -> [NonVoid Id]
73 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
74
75 -------------------------------------
76 -- Manipulating CgIdInfo
77 -------------------------------------
78
79 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
80 mkCgIdInfo id lf expr
81 = CgIdInfo { cg_id = id, cg_lf = lf
82 , cg_loc = CmmLoc expr,
83 cg_tag = lfDynTag lf }
84
85 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
86 litIdInfo dflags id lf lit
87 = CgIdInfo { cg_id = id, cg_lf = lf
88 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag)
89 , cg_tag = tag }
90 where
91 tag = lfDynTag lf
92
93 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
94 lneIdInfo dflags id regs
95 = CgIdInfo { cg_id = id, cg_lf = lf
96 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs)
97 , cg_tag = lfDynTag lf }
98 where
99 lf = mkLFLetNoEscape
100 blk_id = mkBlockId (idUnique id)
101
102
103 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
104 rhsIdInfo id lf_info
105 = do { reg <- newTemp gcWord
106 ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) }
107
108 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
109 mkRhsInit dflags reg lf_info expr
110 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag lf_info))
111
112 idInfoToAmode :: CgIdInfo -> CmmExpr
113 -- Returns a CmmExpr for the *tagged* pointer
114 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
115 idInfoToAmode cg_info
116 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
117
118 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
119 -- A tag adds a byte offset to the pointer
120 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
121
122 cgIdInfoId :: CgIdInfo -> Id
123 cgIdInfoId = cg_id
124
125 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
126 cgIdInfoLF = cg_lf
127
128 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
129 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
130 maybeLetNoEscape _other = Nothing
131
132
133
134 ---------------------------------------------------------
135 -- The binding environment
136 --
137 -- There are three basic routines, for adding (addBindC),
138 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
139 ---------------------------------------------------------
140
141 addBindC :: Id -> CgIdInfo -> FCode ()
142 addBindC name stuff_to_bind = do
143 binds <- getBinds
144 setBinds $ extendVarEnv binds name stuff_to_bind
145
146 addBindsC :: [CgIdInfo] -> FCode ()
147 addBindsC new_bindings = do
148 binds <- getBinds
149 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
150 binds
151 new_bindings
152 setBinds new_binds
153
154 getCgIdInfo :: Id -> FCode CgIdInfo
155 getCgIdInfo id
156 = do { -- Try local bindings first
157 ; local_binds <- getBinds
158 ; case lookupVarEnv local_binds id of {
159 Just info -> return info ;
160 Nothing -> do
161
162 { -- Try top-level bindings
163 static_binds <- getStaticBinds
164 ; case lookupVarEnv static_binds id of {
165 Just info -> return info ;
166 Nothing ->
167
168 -- Should be imported; make up a CgIdInfo for it
169 let
170 name = idName id
171 in
172 if isExternalName name then do
173 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
174 dflags <- getDynFlags
175 return (litIdInfo dflags id (mkLFImported id) ext_lbl)
176 else
177 -- Bug
178 cgLookupPanic id
179 }}}}
180
181 cgLookupPanic :: Id -> FCode a
182 cgLookupPanic id
183 = do static_binds <- getStaticBinds
184 local_binds <- getBinds
185 pprPanic "StgCmmEnv: variable not found"
186 (vcat [ppr id,
187 ptext (sLit "static binds for:"),
188 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
189 ptext (sLit "local binds for:"),
190 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
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 dflags <- getDynFlags
218 let reg = idToReg dflags nvid
219 addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
220 return reg
221
222 rebindToReg :: NonVoid Id -> FCode LocalReg
223 -- Like bindToReg, but the Id is already in scope, so
224 -- get its LF info from the envt
225 rebindToReg nvid@(NonVoid id)
226 = do { info <- getCgIdInfo id
227 ; bindToReg nvid (cgIdInfoLF info) }
228
229 bindArgToReg :: NonVoid Id -> FCode LocalReg
230 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
231
232 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
233 bindArgsToRegs args = mapM bindArgToReg args
234
235 idToReg :: DynFlags -> NonVoid Id -> LocalReg
236 -- Make a register from an Id, typically a function argument,
237 -- free variable, or case binder
238 --
239 -- We re-use the Unique from the Id to make it easier to see what is going on
240 --
241 -- By now the Ids should be uniquely named; else one would worry
242 -- about accidental collision
243 idToReg dflags (NonVoid id)
244 = LocalReg (idUnique id)
245 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
246 _ -> primRepCmmType dflags (idPrimRep id))
247
248