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 this_pkg <- getThisPackage
284 let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name))
285 return (stableIdInfo id ext_lbl (mkLFImported id))
287 if isVoidArg (idCgRep id) then
288 -- Void things are never in the environment
289 return (voidIdInfo id)
296 cgLookupPanic :: Id -> FCode a
298 = do static_binds <- getStaticBinds
299 local_binds <- getBinds
303 ptext SLIT("static binds for:"),
304 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
305 ptext SLIT("local binds for:"),
306 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
307 ptext SLIT("SRT label") <+> pprCLabel srt
311 %************************************************************************
313 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
315 %************************************************************************
317 We sometimes want to nuke all the volatile bindings; we must be sure
318 we don't leave any (NoVolatile, NoStable) binds around...
321 nukeVolatileBinds :: CgBindings -> CgBindings
322 nukeVolatileBinds binds
323 = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
325 keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
326 keep_if_stable info acc
327 = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
331 %************************************************************************
333 \subsection[lookup-interface]{Interface functions to looking up bindings}
335 %************************************************************************
338 getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
339 getCAddrModeIfVolatile id
340 = do { info <- getCgIdInfo id
341 ; case cg_stb info of
342 NoStableLoc -> do -- Aha! So it is volatile!
343 amode <- idInfoToAmode info
345 a_stable_loc -> return Nothing }
348 @getVolatileRegs@ gets a set of live variables, and returns a list of
349 all registers on which these variables depend. These are the regs
350 which must be saved and restored across any C calls. If a variable is
351 both in a volatile location (depending on a register) {\em and} a
352 stable one (notably, on the stack), we modify the current bindings to
353 forget the volatile one.
356 getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
358 getVolatileRegs vars = do
359 do { stuff <- mapFCs snaffle_it (varSetElems vars)
360 ; returnFC $ catMaybes stuff }
363 { info <- getCgIdInfo var
365 -- commoned-up code...
367 = -- We assume that all regs can die across C calls
368 -- We leave it to the save-macros to decide which
369 -- regs *really* need to be saved.
371 NoStableLoc -> returnFC (Just reg) -- got one!
372 is_a_stable_loc -> do
373 { -- has both volatile & stable locations;
374 -- force it to rely on the stable location
375 modifyBindC var nuke_vol_bind
378 ; case cg_vol info of
379 RegLoc (CmmGlobal reg) -> consider_reg reg
380 VirNodeLoc _ -> consider_reg node
381 other_loc -> returnFC Nothing -- Local registers
384 nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
388 getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
389 getArgAmode (StgVarArg var)
390 = do { info <- getCgIdInfo var
391 ; amode <- idInfoToAmode info
392 ; return (cgIdInfoArgRep info, amode ) }
394 getArgAmode (StgLitArg lit)
395 = do { cmm_lit <- cgLit lit
396 ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
398 getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
400 getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
401 getArgAmodes [] = returnFC []
402 getArgAmodes (atom:atoms)
403 | isStgTypeArg atom = getArgAmodes atoms
404 | otherwise = do { amode <- getArgAmode atom
405 ; amodes <- getArgAmodes atoms
406 ; return ( amode : amodes ) }
409 %************************************************************************
411 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
413 %************************************************************************
416 bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
420 bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
422 bindArgsToRegs :: [(Id, GlobalReg)] -> Code
426 bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
428 bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
429 bindNewToNode id offset lf_info
430 = addBindC id (nodeIdInfo id offset lf_info)
432 bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
433 bindNewToUntagNode id offset lf_info tag
434 = addBindC id (untagNodeIdInfo id offset lf_info tag)
436 -- Create a new temporary whose unique is that in the id,
437 -- bind the id to it, and return the addressing mode for the
439 bindNewToTemp :: Id -> FCode LocalReg
441 = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
445 temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
446 kind = if isFollowableArg (idCgRep id)
449 lf_info = mkLFArgument id -- Always used of things we
450 -- know nothing about
452 bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
453 bindNewToReg name reg lf_info
456 info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
460 rebindToStack :: Id -> VirtualSpOffset -> Code
461 rebindToStack name offset
462 = modifyBindC name replace_stable_fn
464 replace_stable_fn info = info { cg_stb = VirStkLoc offset }
467 %************************************************************************
469 \subsection[CgMonad-deadslots]{Finding dead stack slots}
471 %************************************************************************
473 nukeDeadBindings does the following:
475 - Removes all bindings from the environment other than those
476 for variables in the argument to nukeDeadBindings.
477 - Collects any stack slots so freed, and returns them to the stack free
479 - Moves the virtual stack pointer to point to the topmost used
482 You can have multi-word slots on the stack (where a Double# used to
483 be, for instance); if dead, such a slot will be reported as *several*
484 offsets (one per word).
486 Probably *naughty* to look inside monad...
489 nukeDeadBindings :: StgLiveVars -- All the *live* variables
491 nukeDeadBindings live_vars = do
493 let (dead_stk_slots, bs') =
496 [ (cg_id b, b) | b <- varEnvElts binds ]
497 setBinds $ mkVarEnv bs'
498 freeStackSlots dead_stk_slots
501 Several boring auxiliary functions to do the dirty work.
504 dead_slots :: StgLiveVars
508 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
510 -- dead_slots carries accumulating parameters for
511 -- filtered bindings, dead slots
512 dead_slots live_vars fbs ds []
513 = (ds, reverse fbs) -- Finished; rm the dups, if any
515 dead_slots live_vars fbs ds ((v,i):bs)
516 | v `elementOfUniqSet` live_vars
517 = dead_slots live_vars ((v,i):fbs) ds bs
518 -- Live, so don't record it in dead slots
519 -- Instead keep it in the filtered bindings
525 -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
527 _ -> dead_slots live_vars fbs ds bs
530 size = cgRepSizeW (cg_rep i)
534 getLiveStackSlots :: FCode [VirtualSpOffset]
535 -- Return the offsets of slots in stack containig live pointers
537 = do { binds <- getBinds
538 ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
539 cg_rep = rep } <- varEnvElts binds,
540 isFollowableArg rep] }
544 getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
546 = do { binds <- getBinds
547 ; return [(off, bind) |
548 bind <- varEnvElts binds,
549 CgIdInfo { cg_stb = VirStkLoc off,
550 cg_rep = rep} <- [bind],
551 isFollowableArg rep] }