2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[CgBindery]{Utility functions related to doing @CgBindings@}
10 StableLoc, VolatileLoc,
12 cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
14 stableIdInfo, heapIdInfo,
15 taggedStableIdInfo, taggedHeapIdInfo,
16 letNoEscapeIdInfo, idInfoToAmode,
25 bindArgsToStack, rebindToStack,
26 bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
28 getArgAmode, getArgAmodes,
30 getCAddrModeIfVolatile, getVolatileRegs,
34 #include "HsVersions.h"
45 import PprCmm ( {- instance Outputable -} )
62 %************************************************************************
64 \subsection[Bindery-datatypes]{Data types}
66 %************************************************************************
68 @(CgBinding a b)@ is a type of finite maps from a to b.
70 The assumption used to be that @lookupCgBind@ must get exactly one
71 match. This is {\em completely wrong} in the case of compiling
72 letrecs (where knot-tying is used). An initial binding is fed in (and
73 never evaluated); eventually, a correct binding is put into the
74 environment. So there can be two bindings for a given name.
77 type CgBindings = IdEnv CgIdInfo
81 { cg_id :: Id -- Id that this is the info for
82 -- Can differ from the Id at occurrence sites by
83 -- virtue of being externalised, for splittable C
85 , cg_vol :: VolatileLoc
87 , cg_lf :: LambdaFormInfo
88 , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode
91 mkCgIdInfo id vol stb lf
92 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
93 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
96 | Just con <- isDataConWorkId_maybe id,
97 {- Is this an identifier for a static constructor closure? -}
98 isNullaryRepDataCon con
99 {- If yes, is this a nullary constructor?
100 If yes, we assume that the constructor is evaluated and can
108 voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
109 , cg_stb = VoidLoc, cg_lf = mkLFArgument id
110 , cg_rep = VoidArg, cg_tag = 0 }
111 -- Used just for VoidRep things
113 data VolatileLoc -- These locations die across a call
115 | RegLoc CmmReg -- In one of the registers (global or local)
116 | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
117 | VirNodeLoc ByteOff -- Cts of offset indirect from Node
118 -- ie *(Node+offset).
119 -- NB. Byte offset, because we subtract R1's
120 -- tag from the offset.
122 mkTaggedCgIdInfo id vol stb lf con
123 = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
124 cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con }
127 @StableLoc@ encodes where an Id can be found, used by
128 the @CgBindings@ environment in @CgBindery@.
134 | VirStkLoc VirtualSpOffset -- The thing is held in this
137 | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
138 -- value is this stack pointer
139 -- (as opposed to the contents of the slot)
142 | VoidLoc -- Used only for VoidRep variables. They never need to
143 -- be saved, so it makes sense to treat treat them as
144 -- having a stable location
148 instance Outputable CgIdInfo where
149 ppr (CgIdInfo id rep vol stb lf _) -- TODO, pretty pring the tag info
150 = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
152 instance Outputable VolatileLoc where
153 ppr NoVolatileLoc = empty
154 ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r
155 ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
156 ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
158 instance Outputable StableLoc where
159 ppr NoStableLoc = empty
160 ppr VoidLoc = ptext SLIT("void")
161 ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
162 ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v
163 ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
166 %************************************************************************
168 \subsection[Bindery-idInfo]{Manipulating IdInfo}
170 %************************************************************************
173 stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
174 heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
175 letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
176 stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
177 nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info
178 regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
180 taggedStableIdInfo id amode lf_info con
181 = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con
182 taggedHeapIdInfo id offset lf_info con
183 = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con
184 untagNodeIdInfo id offset lf_info tag
185 = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info
188 idInfoToAmode :: CgIdInfo -> FCode CmmExpr
190 = case cg_vol info of {
191 RegLoc reg -> returnFC (CmmReg reg) ;
192 VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off)
194 VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off
195 ; return $! maybeTag off };
199 StableLoc amode -> returnFC $! maybeTag amode
200 VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
201 ; return (CmmLoad sp_rel mach_rep) }
203 VirStkLNE sp_off -> getSpRelOffset sp_off
205 VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
206 -- We return a 'bottom' amode, rather than panicing now
207 -- In this way getArgAmode returns a pair of (VoidArg, bottom)
208 -- and that's exactly what we want
210 NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
213 mach_rep = argMachRep (cg_rep info)
215 maybeTag amode -- add the tag, if we have one
217 | otherwise = cmmOffsetB amode tag
218 where tag = cg_tag info
220 cgIdInfoId :: CgIdInfo -> Id
223 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
226 cgIdInfoArgRep :: CgIdInfo -> CgRep
227 cgIdInfoArgRep = cg_rep
229 maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
230 maybeLetNoEscape other = Nothing
233 %************************************************************************
235 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
237 %************************************************************************
239 .There are three basic routines, for adding (@addBindC@), modifying
240 (@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
242 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
243 The name should not already be bound. (nice ASSERT, eh?)
246 addBindC :: Id -> CgIdInfo -> Code
247 addBindC name stuff_to_bind = do
249 setBinds $ extendVarEnv binds name stuff_to_bind
251 addBindsC :: [(Id, CgIdInfo)] -> Code
252 addBindsC new_bindings = do
254 let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
259 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
260 modifyBindC name mangle_fn = do
262 setBinds $ modifyVarEnv mangle_fn binds name
264 getCgIdInfo :: Id -> FCode CgIdInfo
266 = do { -- Try local bindings first
267 ; local_binds <- getBinds
268 ; case lookupVarEnv local_binds id of {
269 Just info -> return info ;
272 { -- Try top-level bindings
273 static_binds <- getStaticBinds
274 ; case lookupVarEnv static_binds id of {
275 Just info -> return info ;
278 -- Should be imported; make up a CgIdInfo for it
282 if isExternalName name then do
283 let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
284 return (stableIdInfo id ext_lbl (mkLFImported id))
286 if isVoidArg (idCgRep id) then
287 -- Void things are never in the environment
288 return (voidIdInfo id)
295 cgLookupPanic :: Id -> FCode a
297 = do static_binds <- getStaticBinds
298 local_binds <- getBinds
302 ptext SLIT("static binds for:"),
303 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
304 ptext SLIT("local binds for:"),
305 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
306 ptext SLIT("SRT label") <+> pprCLabel srt
310 %************************************************************************
312 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
314 %************************************************************************
316 We sometimes want to nuke all the volatile bindings; we must be sure
317 we don't leave any (NoVolatile, NoStable) binds around...
320 nukeVolatileBinds :: CgBindings -> CgBindings
321 nukeVolatileBinds binds
322 = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
324 keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
325 keep_if_stable info acc
326 = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
330 %************************************************************************
332 \subsection[lookup-interface]{Interface functions to looking up bindings}
334 %************************************************************************
337 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
338 getCAddrModeIfVolatile id
339 = do { info <- getCgIdInfo id
340 ; case cg_stb info of
341 NoStableLoc -> do -- Aha! So it is volatile!
342 amode <- idInfoToAmode info
344 a_stable_loc -> return Nothing }
347 @getVolatileRegs@ gets a set of live variables, and returns a list of
348 all registers on which these variables depend. These are the regs
349 which must be saved and restored across any C calls. If a variable is
350 both in a volatile location (depending on a register) {\em and} a
351 stable one (notably, on the stack), we modify the current bindings to
352 forget the volatile one.
355 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
357 getVolatileRegs vars = do
358 do { stuff <- mapFCs snaffle_it (varSetElems vars)
359 ; returnFC $ catMaybes stuff }
362 { info <- getCgIdInfo var
364 -- commoned-up code...
366 = -- We assume that all regs can die across C calls
367 -- We leave it to the save-macros to decide which
368 -- regs *really* need to be saved.
370 NoStableLoc -> returnFC (Just reg) -- got one!
371 is_a_stable_loc -> do
372 { -- has both volatile & stable locations;
373 -- force it to rely on the stable location
374 modifyBindC var nuke_vol_bind
377 ; case cg_vol info of
378 RegLoc (CmmGlobal reg) -> consider_reg reg
379 VirNodeLoc _ -> consider_reg node
380 other_loc -> returnFC Nothing -- Local registers
383 nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
387 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
388 getArgAmode (StgVarArg var)
389 = do { info <- getCgIdInfo var
390 ; amode <- idInfoToAmode info
391 ; return (cgIdInfoArgRep info, amode ) }
393 getArgAmode (StgLitArg lit)
394 = do { cmm_lit <- cgLit lit
395 ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
397 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
399 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
400 getArgAmodes [] = returnFC []
401 getArgAmodes (atom:atoms)
402 | isStgTypeArg atom = getArgAmodes atoms
403 | otherwise = do { amode <- getArgAmode atom
404 ; amodes <- getArgAmodes atoms
405 ; return ( amode : amodes ) }
408 %************************************************************************
410 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
412 %************************************************************************
415 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
419 bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
421 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
425 bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
427 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
428 bindNewToNode id offset lf_info
429 = addBindC id (nodeIdInfo id offset lf_info)
431 bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
432 bindNewToUntagNode id offset lf_info tag
433 = addBindC id (untagNodeIdInfo id offset lf_info tag)
435 -- Create a new temporary whose unique is that in the id,
436 -- bind the id to it, and return the addressing mode for the
438 bindNewToTemp :: Id -> FCode LocalReg
440 = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
444 temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
445 kind = if isFollowableArg (idCgRep id)
448 lf_info = mkLFArgument id -- Always used of things we
449 -- know nothing about
451 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
452 bindNewToReg name reg lf_info
455 info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
459 rebindToStack :: Id -> VirtualSpOffset -> Code
460 rebindToStack name offset
461 = modifyBindC name replace_stable_fn
463 replace_stable_fn info = info { cg_stb = VirStkLoc offset }
466 %************************************************************************
468 \subsection[CgMonad-deadslots]{Finding dead stack slots}
470 %************************************************************************
472 nukeDeadBindings does the following:
474 - Removes all bindings from the environment other than those
475 for variables in the argument to nukeDeadBindings.
476 - Collects any stack slots so freed, and returns them to the stack free
478 - Moves the virtual stack pointer to point to the topmost used
481 You can have multi-word slots on the stack (where a Double# used to
482 be, for instance); if dead, such a slot will be reported as *several*
483 offsets (one per word).
485 Probably *naughty* to look inside monad...
488 nukeDeadBindings :: StgLiveVars -- All the *live* variables
490 nukeDeadBindings live_vars = do
492 let (dead_stk_slots, bs') =
495 [ (cg_id b, b) | b <- varEnvElts binds ]
496 setBinds $ mkVarEnv bs'
497 freeStackSlots dead_stk_slots
500 Several boring auxiliary functions to do the dirty work.
503 dead_slots :: StgLiveVars
507 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
509 -- dead_slots carries accumulating parameters for
510 -- filtered bindings, dead slots
511 dead_slots live_vars fbs ds []
512 = (ds, reverse fbs) -- Finished; rm the dups, if any
514 dead_slots live_vars fbs ds ((v,i):bs)
515 | v `elementOfUniqSet` live_vars
516 = dead_slots live_vars ((v,i):fbs) ds bs
517 -- Live, so don't record it in dead slots
518 -- Instead keep it in the filtered bindings
524 -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
526 _ -> dead_slots live_vars fbs ds bs
529 size = cgRepSizeW (cg_rep i)
533 getLiveStackSlots :: FCode [VirtualSpOffset]
534 -- Return the offsets of slots in stack containig live pointers
536 = do { binds <- getBinds
537 ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
538 cg_rep = rep } <- varEnvElts binds,
539 isFollowableArg rep] }
543 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
545 = do { binds <- getBinds
546 ; return [(off, bind) |
547 bind <- varEnvElts binds,
548 CgIdInfo { cg_stb = VirStkLoc off,
549 cg_rep = rep} <- [bind],
550 isFollowableArg rep] }