2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
7 #include "HsVersions.h"
10 SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
11 StableLoc, VolatileLoc,
13 maybeAStkLoc, maybeBStkLoc,
15 stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
16 letNoEscapeIdInfo, idInfoToAmode,
20 bindNewToAStack, bindNewToBStack,
21 bindNewToNode, bindNewToReg, bindArgsToRegs,
22 bindNewToTemp, bindNewPrimToAmode,
23 getArgAmode, getArgAmodes,
24 getCAddrModeAndInfo, getCAddrMode,
25 getCAddrModeIfVolatile, getVolatileRegs,
26 rebindToAStack, rebindToBStack
30 IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
35 import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
36 import CLabel ( mkStaticClosureLabel, mkClosureLabel )
37 import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
38 import HeapOffs ( SYN_IE(VirtualHeapOffset),
39 SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
41 import Id ( idPrimRep, toplevelishId, isDataCon,
42 mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
44 GenId{-instance NamedThing-}
46 import Maybes ( catMaybes )
47 import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
49 import PprAbsC ( pprAmode )
51 import PprStyle ( PprStyle(..) )
52 import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
53 import Unpretty ( uppShow )
54 import Util ( zipWithEqual, panic )
58 %************************************************************************
60 \subsection[Bindery-datatypes]{Data types}
62 %************************************************************************
64 @(CgBinding a b)@ is a type of finite maps from a to b.
66 The assumption used to be that @lookupCgBind@ must get exactly one
67 match. This is {\em completely wrong} in the case of compiling
68 letrecs (where knot-tying is used). An initial binding is fed in (and
69 never evaluated); eventually, a correct binding is put into the
70 environment. So there can be two bindings for a given name.
73 type CgBindings = IdEnv CgIdInfo
76 = MkCgIdInfo Id -- Id that this is the info for
85 | RegLoc MagicId -- in one of the magic registers
86 -- (probably {Int,Float,Char,etc}Reg
88 | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
90 | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
95 | VirAStkLoc VirtualSpAOffset
96 | VirBStkLoc VirtualSpBOffset
98 | StableAmodeLoc CAddrMode
100 -- these are so StableLoc can be abstract:
102 maybeAStkLoc (VirAStkLoc offset) = Just offset
103 maybeAStkLoc _ = Nothing
105 maybeBStkLoc (VirBStkLoc offset) = Just offset
106 maybeBStkLoc _ = Nothing
109 %************************************************************************
111 \subsection[Bindery-idInfo]{Manipulating IdInfo}
113 %************************************************************************
116 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
117 heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
118 tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
120 letNoEscapeIdInfo i spa spb lf_info
121 = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
123 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
125 newTempAmodeAndIdInfo name lf_info
126 = (temp_amode, temp_idinfo)
129 temp_amode = CTemp uniq (idPrimRep name)
130 temp_idinfo = tempIdInfo name uniq lf_info
132 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
133 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
135 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
137 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
138 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
140 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
141 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
143 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
144 = returnFC (CVal (NodeRel nd_off) kind)
145 -- Virtual offsets from Node increase into the closures,
146 -- and so do Node-relative offsets (which we want in the CVal),
147 -- so there is no mucking about to do to the offset.
149 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
150 = getHpRelOffset hp_off `thenFC` \ rel_hp ->
151 returnFC (CAddr rel_hp)
153 idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
154 = getSpARelOffset i `thenFC` \ rel_spA ->
155 returnFC (CVal rel_spA kind)
157 idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
158 = getSpBRelOffset i `thenFC` \ rel_spB ->
159 returnFC (CVal rel_spB kind)
162 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
166 %************************************************************************
168 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
170 %************************************************************************
172 We sometimes want to nuke all the volatile bindings; we must be sure
173 we don't leave any (NoVolatile, NoStable) binds around...
176 nukeVolatileBinds :: CgBindings -> CgBindings
177 nukeVolatileBinds binds
178 = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
180 keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
181 keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
182 = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
186 %************************************************************************
188 \subsection[lookup-interface]{Interface functions to looking up bindings}
190 %************************************************************************
192 I {\em think} all looking-up is done through @getCAddrMode(s)@.
195 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
197 getCAddrModeAndInfo id
198 | not (isLocallyDefined name) || isWiredInName name
199 {- Why the "isWiredInName"?
200 Imagine you are compiling GHCbase.hs (a module that
201 supplies some of the wired-in values). What can
202 happen is that the compiler will inject calls to
203 (e.g.) GHCbase.unpackPS, where-ever it likes -- it
204 assumes those values are ubiquitously available.
205 The main point is: it may inject calls to them earlier
206 in GHCbase.hs than the actual definition...
208 = returnFC (global_amode, mkLFImported id)
210 | otherwise = -- *might* be a nested defn: in any case, it's something whose
211 -- definition we will know about...
212 lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
213 idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
214 returnFC (amode, lf_info)
217 global_amode = CLbl (mkClosureLabel id) kind
220 getCAddrMode :: Id -> FCode CAddrMode
222 = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
227 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
228 getCAddrModeIfVolatile name
229 | toplevelishId name = returnFC Nothing
231 = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
233 NoStableLoc -> -- Aha! So it is volatile!
234 idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
235 returnFC (Just amode)
237 a_stable_loc -> returnFC Nothing
240 @getVolatileRegs@ gets a set of live variables, and returns a list of
241 all registers on which these variables depend. These are the regs
242 which must be saved and restored across any C calls. If a variable is
243 both in a volatile location (depending on a register) {\em and} a
244 stable one (notably, on the stack), we modify the current bindings to
245 forget the volatile one.
248 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
251 = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
252 returnFC (catMaybes stuff)
255 = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
257 -- commoned-up code...
259 = if not (isVolatileReg reg) then
260 -- Potentially dies across C calls
261 -- For now, that's everything; we leave
262 -- it to the save-macros to decide which
263 -- regs *really* need to be saved.
267 NoStableLoc -> returnFC (Just reg) -- got one!
269 -- has both volatile & stable locations;
270 -- force it to rely on the stable location
271 modifyBindC var nuke_vol_bind `thenC`
275 RegLoc reg -> consider_reg reg
276 VirHpLoc _ -> consider_reg Hp
277 VirNodeLoc _ -> consider_reg node
278 non_reg_loc -> returnFC Nothing
280 nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
281 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
285 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
286 getArgAmodes [] = returnFC []
287 getArgAmodes (atom:atoms)
288 = getArgAmode atom `thenFC` \ amode ->
289 getArgAmodes atoms `thenFC` \ amodes ->
290 returnFC ( amode : amodes )
292 getArgAmode :: StgArg -> FCode CAddrMode
294 getArgAmode (StgConArg var)
295 {- Why does this case differ from StgVarArg?
296 Because the program might look like this:
297 data Foo a = Empty | Baz a
298 f a x = let c = Empty! a
300 Now, when we go Core->Stg, we drop the type applications,
301 so we can inline c, giving
303 Now we are referring to Empty as an argument (rather than in an STGCon),
304 so we'll look it up with getCAddrMode. We want to return an amode for
305 the static closure that we make for nullary constructors. But if we blindly
306 go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
308 This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
311 If the constructor Baz isn't inlined we simply want to treat it like any other
312 identifier, with a top level definition. We don't want to spot that it's a constructor.
318 are treated differently; the former is a call to a bog standard function while the
319 latter uses the specially-labelled, pre-defined info tables etc for the constructor.
321 The way to think of this case in getArgAmode is that
324 App f (StgCon Empty [])
326 = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
328 getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
330 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
333 %************************************************************************
335 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
337 %************************************************************************
340 bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
341 bindNewToAStack (name, offset)
344 info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
346 bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
347 bindNewToBStack (name, offset)
350 info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
351 -- B-stack things shouldn't need lambda-form info!
353 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
354 bindNewToNode name offset lf_info
357 info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
359 -- Create a new temporary whose unique is that in the id,
360 -- bind the id to it, and return the addressing mode for the
362 bindNewToTemp :: Id -> FCode CAddrMode
364 = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
365 -- This is used only for things we don't know
366 -- anything about; values returned by a case statement,
369 addBindC name id_info `thenC`
372 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
373 bindNewToReg name magic_id lf_info
376 info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
378 bindNewToLit name lit
381 info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
383 bindArgsToRegs :: [Id] -> [MagicId] -> Code
384 bindArgsToRegs args regs
385 = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
387 arg `bind` reg = bindNewToReg arg reg mkLFArgument
390 @bindNewPrimToAmode@ works only for certain addressing modes, because
391 those are the only ones we've needed so far!
394 bindNewPrimToAmode :: Id -> CAddrMode -> Code
395 bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
397 -- LFinfo is irrelevant for primitives
398 bindNewPrimToAmode name (CTemp uniq kind)
399 = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
400 -- LFinfo is irrelevant for primitives
402 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
404 bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
405 = bindNewToBStack (name, offset)
407 bindNewPrimToAmode name (CVal (NodeRel offset) _)
408 = bindNewToNode name offset (panic "bindNewPrimToAmode node")
409 -- See comment on idInfoPiecesToAmode for VirNodeLoc
412 bindNewPrimToAmode name amode
413 = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode)))
418 rebindToAStack :: Id -> VirtualSpAOffset -> Code
419 rebindToAStack name offset
420 = modifyBindC name replace_stable_fn
422 replace_stable_fn (MkCgIdInfo i vol stab einfo)
423 = MkCgIdInfo i vol (VirAStkLoc offset) einfo
425 rebindToBStack :: Id -> VirtualSpBOffset -> Code
426 rebindToBStack name offset
427 = modifyBindC name replace_stable_fn
429 replace_stable_fn (MkCgIdInfo i vol stab einfo)
430 = MkCgIdInfo i vol (VirBStkLoc offset) einfo