2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
7 #include "HsVersions.h"
10 CgBindings(..), CgIdInfo(..){-dubiously concrete-},
11 StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-},
13 maybeAStkLoc, maybeBStkLoc,
15 stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
16 letNoEscapeIdInfo, idInfoToAmode,
20 bindNewToAStack, bindNewToBStack,
21 bindNewToNode, bindNewToReg, bindArgsToRegs,
22 bindNewToTemp, bindNewPrimToAmode,
23 getAtomAmode, getAtomAmodes,
24 getCAddrModeAndInfo, getCAddrMode,
25 getCAddrModeIfVolatile, getVolatileRegs,
26 rebindToAStack, rebindToBStack
28 -- and to make a self-sufficient interface...
34 import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
35 import CLabel ( mkClosureLabel, CLabel )
37 import Id ( getIdPrimRep, toplevelishId, isDataCon, Id )
38 import Maybes ( catMaybes, Maybe(..) )
39 import UniqSet -- ( setToList )
45 %************************************************************************
47 \subsection[Bindery-datatypes]{Data types}
49 %************************************************************************
51 @(CgBinding a b)@ is a type of finite maps from a to b.
53 The assumption used to be that @lookupCgBind@ must get exactly one
54 match. This is {\em completely wrong} in the case of compiling
55 letrecs (where knot-tying is used). An initial binding is fed in (and
56 never evaluated); eventually, a correct binding is put into the
57 environment. So there can be two bindings for a given name.
60 type CgBindings = IdEnv CgIdInfo
63 = MkCgIdInfo Id -- Id that this is the info for
72 | RegLoc MagicId -- in one of the magic registers
73 -- (probably {Int,Float,Char,etc}Reg
75 | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
77 | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
82 | VirAStkLoc VirtualSpAOffset
83 | VirBStkLoc VirtualSpBOffset
85 | StableAmodeLoc CAddrMode
87 -- these are so StableLoc can be abstract:
89 maybeAStkLoc (VirAStkLoc offset) = Just offset
90 maybeAStkLoc _ = Nothing
92 maybeBStkLoc (VirBStkLoc offset) = Just offset
93 maybeBStkLoc _ = Nothing
96 %************************************************************************
98 \subsection[Bindery-idInfo]{Manipulating IdInfo}
100 %************************************************************************
103 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
104 heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
105 tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
107 letNoEscapeIdInfo i spa spb lf_info
108 = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
110 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
112 newTempAmodeAndIdInfo name lf_info
113 = (temp_amode, temp_idinfo)
115 uniq = getItsUnique name
116 temp_amode = CTemp uniq (getIdPrimRep name)
117 temp_idinfo = tempIdInfo name uniq lf_info
119 idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
120 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
122 idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode
124 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
125 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
127 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
128 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
130 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
131 = returnFC (CVal (NodeRel nd_off) kind)
132 -- Virtual offsets from Node increase into the closures,
133 -- and so do Node-relative offsets (which we want in the CVal),
134 -- so there is no mucking about to do to the offset.
136 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
137 = getHpRelOffset hp_off `thenFC` \ rel_hp ->
138 returnFC (CAddr rel_hp)
140 idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
141 = getSpARelOffset i `thenFC` \ rel_spA ->
142 returnFC (CVal rel_spA kind)
144 idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
145 = getSpBRelOffset i `thenFC` \ rel_spB ->
146 returnFC (CVal rel_spB kind)
149 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
153 %************************************************************************
155 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
157 %************************************************************************
159 We sometimes want to nuke all the volatile bindings; we must be sure
160 we don't leave any (NoVolatile, NoStable) binds around...
163 nukeVolatileBinds :: CgBindings -> CgBindings
164 nukeVolatileBinds binds
165 = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
167 keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
168 keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
169 = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
173 %************************************************************************
175 \subsection[lookup-interface]{Interface functions to looking up bindings}
177 %************************************************************************
179 I {\em think} all looking-up is done through @getCAddrMode(s)@.
182 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
184 getCAddrModeAndInfo name
185 | not (isLocallyDefined name)
186 = returnFC (global_amode, mkLFImported name)
189 = returnFC (global_amode, mkConLFInfo name)
191 | otherwise = -- *might* be a nested defn: in any case, it's something whose
192 -- definition we will know about...
193 lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
194 idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
195 returnFC (amode, lf_info)
197 global_amode = CLbl (mkClosureLabel name) kind
198 kind = getIdPrimRep name
200 getCAddrMode :: Id -> FCode CAddrMode
202 = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
207 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
208 getCAddrModeIfVolatile name
209 | toplevelishId name = returnFC Nothing
211 = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
213 NoStableLoc -> -- Aha! So it is volatile!
214 idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
215 returnFC (Just amode)
217 a_stable_loc -> returnFC Nothing
220 @getVolatileRegs@ gets a set of live variables, and returns a list of
221 all registers on which these variables depend. These are the regs
222 which must be saved and restored across any C calls. If a variable is
223 both in a volatile location (depending on a register) {\em and} a
224 stable one (notably, on the stack), we modify the current bindings to
225 forget the volatile one.
228 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
231 = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
232 returnFC (catMaybes stuff)
235 = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
237 -- commoned-up code...
239 = if not (isVolatileReg reg) then
240 -- Potentially dies across C calls
241 -- For now, that's everything; we leave
242 -- it to the save-macros to decide which
243 -- regs *really* need to be saved.
247 NoStableLoc -> returnFC (Just reg) -- got one!
249 -- has both volatile & stable locations;
250 -- force it to rely on the stable location
251 modifyBindC var nuke_vol_bind `thenC`
255 RegLoc reg -> consider_reg reg
256 VirHpLoc _ -> consider_reg Hp
257 VirNodeLoc _ -> consider_reg node
258 non_reg_loc -> returnFC Nothing
260 nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
261 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
265 getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
266 getAtomAmodes [] = returnFC []
267 getAtomAmodes (atom:atoms)
268 = getAtomAmode atom `thenFC` \ amode ->
269 getAtomAmodes atoms `thenFC` \ amodes ->
270 returnFC ( amode : amodes )
272 getAtomAmode :: StgArg -> FCode CAddrMode
274 getAtomAmode (StgVarArg var) = getCAddrMode var
275 getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
278 %************************************************************************
280 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
282 %************************************************************************
285 bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
286 bindNewToAStack (name, offset)
289 info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
291 bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
292 bindNewToBStack (name, offset)
295 info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
296 -- B-stack things shouldn't need lambda-form info!
298 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
299 bindNewToNode name offset lf_info
302 info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
304 -- Create a new temporary whose unique is that in the id,
305 -- bind the id to it, and return the addressing mode for the
307 bindNewToTemp :: Id -> FCode CAddrMode
309 = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
310 -- This is used only for things we don't know
311 -- anything about; values returned by a case statement,
314 addBindC name id_info `thenC`
317 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
318 bindNewToReg name magic_id lf_info
321 info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
323 bindNewToLit name lit
326 info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
328 bindArgsToRegs :: [Id] -> [MagicId] -> Code
329 bindArgsToRegs args regs
330 = listCs (zipWithEqual bind args regs)
332 arg `bind` reg = bindNewToReg arg reg mkLFArgument
335 @bindNewPrimToAmode@ works only for certain addressing modes, because
336 those are the only ones we've needed so far!
339 bindNewPrimToAmode :: Id -> CAddrMode -> Code
340 bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
342 -- LFinfo is irrelevant for primitives
343 bindNewPrimToAmode name (CTemp uniq kind)
344 = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
345 -- LFinfo is irrelevant for primitives
347 bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
349 bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
350 = bindNewToBStack (name, offset)
352 bindNewPrimToAmode name (CVal (NodeRel offset) _)
353 = bindNewToNode name offset (panic "bindNewPrimToAmode node")
354 -- See comment on idInfoPiecesToAmode for VirNodeLoc
357 bindNewPrimToAmode name amode
358 = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode)))
363 rebindToAStack :: Id -> VirtualSpAOffset -> Code
364 rebindToAStack name offset
365 = modifyBindC name replace_stable_fn
367 replace_stable_fn (MkCgIdInfo i vol stab einfo)
368 = MkCgIdInfo i vol (VirAStkLoc offset) einfo
370 rebindToBStack :: Id -> VirtualSpBOffset -> Code
371 rebindToBStack name offset
372 = modifyBindC name replace_stable_fn
374 replace_stable_fn (MkCgIdInfo i vol stab einfo)
375 = MkCgIdInfo i vol (VirBStkLoc offset) einfo