2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CgBindery]{Utility functions related to doing @CgBindings@}
9 StableLoc, VolatileLoc,
11 stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
12 letNoEscapeIdInfo, idInfoToAmode,
19 bindNewToStack, rebindToStack,
20 bindNewToNode, bindNewToReg, bindArgsToRegs,
21 bindNewToTemp, bindNewPrimToAmode,
22 getArgAmode, getArgAmodes,
23 getCAddrModeAndInfo, getCAddrMode,
24 getCAddrModeIfVolatile, getVolatileRegs,
26 buildLivenessMask, buildContLivenessMask
29 #include "HsVersions.h"
34 import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
35 import CgStackery ( freeStackSlots )
36 import CLabel ( mkClosureLabel,
37 mkBitmapLabel, pprCLabel )
38 import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
40 import PrimRep ( isFollowableRep, getPrimRepSize )
41 import Id ( Id, idPrimRep, idType )
42 import Type ( typePrimRep )
44 import VarSet ( varSetElems )
45 import Literal ( Literal )
46 import Maybes ( catMaybes, maybeToBool )
47 import Name ( isLocalName, NamedThing(..) )
49 import PprAbsC ( pprAmode )
51 import PrimRep ( PrimRep(..) )
52 import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
53 import Unique ( Unique, Uniquable(..) )
54 import UniqSet ( elementOfUniqSet )
55 import Util ( zipWithEqual, sortLt )
60 %************************************************************************
62 \subsection[Bindery-datatypes]{Data types}
64 %************************************************************************
66 @(CgBinding a b)@ is a type of finite maps from a to b.
68 The assumption used to be that @lookupCgBind@ must get exactly one
69 match. This is {\em completely wrong} in the case of compiling
70 letrecs (where knot-tying is used). An initial binding is fed in (and
71 never evaluated); eventually, a correct binding is put into the
72 environment. So there can be two bindings for a given name.
75 type CgBindings = IdEnv CgIdInfo
78 = MkCgIdInfo Id -- Id that this is the info for
87 | RegLoc MagicId -- in one of the magic registers
88 -- (probably {Int,Float,Char,etc}Reg
90 | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
92 | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
96 @StableLoc@ encodes where an Id can be found, used by
97 the @CgBindings@ environment in @CgBindery@.
102 | VirStkLoc VirtualSpOffset
104 | StableAmodeLoc CAddrMode
106 -- these are so StableLoc can be abstract:
108 maybeStkLoc (VirStkLoc offset) = Just offset
109 maybeStkLoc _ = Nothing
112 %************************************************************************
114 \subsection[Bindery-idInfo]{Manipulating IdInfo}
116 %************************************************************************
119 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
120 heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
121 tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
123 letNoEscapeIdInfo i sp lf_info
124 = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
126 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
128 newTempAmodeAndIdInfo name lf_info
129 = (temp_amode, temp_idinfo)
131 uniq = getUnique name
132 temp_amode = CTemp uniq (idPrimRep name)
133 temp_idinfo = tempIdInfo name uniq lf_info
135 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
136 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
138 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
140 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
141 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
143 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
144 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
146 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
147 = returnFC (CVal (nodeRel nd_off) kind)
148 -- Virtual offsets from Node increase into the closures,
149 -- and so do Node-relative offsets (which we want in the CVal),
150 -- so there is no mucking about to do to the offset.
152 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
153 = getHpRelOffset hp_off `thenFC` \ rel_hp ->
154 returnFC (CAddr rel_hp)
156 idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
157 = getSpRelOffset i `thenFC` \ rel_sp ->
158 returnFC (CVal rel_sp kind)
161 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
165 %************************************************************************
167 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
169 %************************************************************************
171 There are three basic routines, for adding (@addBindC@), modifying
172 (@modifyBindC@) and looking up (@lookupBindC@) bindings.
174 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
175 The name should not already be bound. (nice ASSERT, eh?)
178 addBindC :: Id -> CgIdInfo -> Code
179 addBindC name stuff_to_bind = do
181 setBinds $ extendVarEnv binds name stuff_to_bind
183 addBindsC :: [(Id, CgIdInfo)] -> Code
184 addBindsC new_bindings = do
186 let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
191 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
192 modifyBindC name mangle_fn = do
194 setBinds $ modifyVarEnv mangle_fn binds name
196 lookupBindC :: Id -> FCode CgIdInfo
197 lookupBindC name = do
198 static_binds <- getStaticBinds
199 local_binds <- getBinds
200 case (lookupVarEnv local_binds name) of
201 Nothing -> case (lookupVarEnv static_binds name) of
202 Nothing -> cgPanic (text "lookupBindC: no info for" <+> ppr name)
203 Just this -> return this
204 Just this -> return this
206 cgPanic :: SDoc -> FCode a
208 static_binds <- getStaticBinds
209 local_binds <- getBinds
213 ptext SLIT("static binds for:"),
214 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
215 ptext SLIT("local binds for:"),
216 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
217 ptext SLIT("SRT label") <+> pprCLabel srt
221 %************************************************************************
223 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
225 %************************************************************************
227 We sometimes want to nuke all the volatile bindings; we must be sure
228 we don't leave any (NoVolatile, NoStable) binds around...
231 nukeVolatileBinds :: CgBindings -> CgBindings
232 nukeVolatileBinds binds
233 = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
235 keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
236 keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
237 = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
241 %************************************************************************
243 \subsection[lookup-interface]{Interface functions to looking up bindings}
245 %************************************************************************
247 I {\em think} all looking-up is done through @getCAddrMode(s)@.
250 getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
252 getCAddrModeAndInfo id
253 | not (isLocalName name)
254 = returnFC (id, global_amode, mkLFImported id)
255 -- deals with imported or locally defined but externally visible ids
256 -- (CoreTidy makes all these into global names).
258 | otherwise = do -- *might* be a nested defn: in any case, it's something whose
259 -- definition we will know about...
260 (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
261 amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
262 return (id', amode, lf_info)
265 global_amode = CLbl (mkClosureLabel name) kind
268 getCAddrMode :: Id -> FCode CAddrMode
269 getCAddrMode name = do
270 (_, amode, _) <- getCAddrModeAndInfo name
275 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
276 getCAddrModeIfVolatile name
277 -- | toplevelishId name = returnFC Nothing
280 (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
282 NoStableLoc -> do -- Aha! So it is volatile!
283 amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
285 a_stable_loc -> return Nothing
288 @getVolatileRegs@ gets a set of live variables, and returns a list of
289 all registers on which these variables depend. These are the regs
290 which must be saved and restored across any C calls. If a variable is
291 both in a volatile location (depending on a register) {\em and} a
292 stable one (notably, on the stack), we modify the current bindings to
293 forget the volatile one.
296 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
298 getVolatileRegs vars = do
299 stuff <- mapFCs snaffle_it (varSetElems vars)
300 returnFC $ catMaybes stuff
303 (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
305 -- commoned-up code...
307 if not (isVolatileReg reg) then
308 -- Potentially dies across C calls
309 -- For now, that's everything; we leave
310 -- it to the save-macros to decide which
311 -- regs *really* need to be saved.
315 NoStableLoc -> returnFC (Just reg) -- got one!
316 is_a_stable_loc -> do
317 -- has both volatile & stable locations;
318 -- force it to rely on the stable location
319 modifyBindC var nuke_vol_bind
323 RegLoc reg -> consider_reg reg
324 VirHpLoc _ -> consider_reg Hp
325 VirNodeLoc _ -> consider_reg node
326 non_reg_loc -> returnFC Nothing
328 nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
329 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
333 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
334 getArgAmodes [] = returnFC []
335 getArgAmodes (atom:atoms)
339 amode <- getArgAmode atom
340 amodes <- getArgAmodes atoms
341 return ( amode : amodes )
343 getArgAmode :: StgArg -> FCode CAddrMode
345 getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
346 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
349 %************************************************************************
351 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
353 %************************************************************************
356 bindNewToStack :: (Id, VirtualSpOffset) -> Code
357 bindNewToStack (name, offset)
360 info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
362 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
363 bindNewToNode name offset lf_info
366 info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
368 -- Create a new temporary whose unique is that in the id,
369 -- bind the id to it, and return the addressing mode for the
371 bindNewToTemp :: Id -> FCode CAddrMode
373 = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
374 -- This is used only for things we don't know
375 -- anything about; values returned by a case statement,
378 addBindC name id_info
381 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
382 bindNewToReg name magic_id lf_info
385 info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
387 bindArgsToRegs :: [Id] -> [MagicId] -> Code
388 bindArgsToRegs args regs
389 = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
391 arg `bind` reg = bindNewToReg arg reg mkLFArgument
394 @bindNewPrimToAmode@ works only for certain addressing modes. Making
395 this work for stack offsets is non-trivial (virt vs. real stack offset
399 bindNewPrimToAmode :: Id -> CAddrMode -> Code
400 bindNewPrimToAmode name (CReg reg)
401 = bindNewToReg name reg (panic "bindNewPrimToAmode")
403 bindNewPrimToAmode name (CTemp uniq kind)
404 = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
407 bindNewPrimToAmode name amode
408 = pprPanic "bindNew...:" (pprAmode amode)
413 rebindToStack :: Id -> VirtualSpOffset -> Code
414 rebindToStack name offset
415 = modifyBindC name replace_stable_fn
417 replace_stable_fn (MkCgIdInfo i vol stab einfo)
418 = MkCgIdInfo i vol (VirStkLoc offset) einfo
421 %************************************************************************
423 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
425 %************************************************************************
427 ToDo: remove the dependency on 32-bit words.
429 There are four kinds of things on the stack:
431 - pointer variables (bound in the environment)
432 - non-pointer variables (boudn in the environment)
433 - free slots (recorded in the stack free list)
434 - non-pointer data slots (recorded in the stack free list)
436 We build up a bitmap of non-pointer slots by looking down the
437 environment for all the non-pointer variables, and merging this with
438 the slots recorded in the stack free list.
440 There's a bit of a hack here to do with update frames: since nothing
441 is recorded in either the environment or the stack free list for an
442 update frame, the code below defaults to assuming the slots taken up
443 by an update frame contain pointers. Furthermore, update frames are
444 always in slots 0-2 at the bottom of the stack. The bitmap will
445 therefore end at slot 3, which is what we want (the update frame info
446 pointer has its own bitmap to describe the update frame).
450 :: Unique -- unique for for large bitmap label
451 -> VirtualSpOffset -- offset from which the bitmap should start
452 -> FCode Liveness -- mask for free/unlifted slots
454 buildLivenessMask uniq sp = do
456 -- find all unboxed stack-resident ids
458 ((vsp, free, _, _), heap_usage) <- getUsage
462 (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
463 let rep = idPrimRep id; size = getPrimRepSize rep,
464 not (isFollowableRep rep),
468 -- flatten this list into a list of unboxed stack slots
469 let flatten_slots = sortLt (<)
470 (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
473 -- merge in the free slots
474 let all_slots = mergeSlots flatten_slots (map fst free) ++
475 if vsp < sp then [vsp+1 .. sp] else []
477 -- recalibrate the list to be sp-relative
478 let rel_slots = reverse (map (sp-) all_slots)
482 = ASSERT(all (>=0) rel_slots
483 && rel_slots == sortLt (<) rel_slots)
484 (listToLivenessMask rel_slots)
486 livenessToAbsC uniq liveness_mask
488 mergeSlots :: [Int] -> [Int] -> [Int]
489 mergeSlots cs [] = cs
490 mergeSlots [] ns = ns
491 mergeSlots (c:cs) (n:ns)
493 c : mergeSlots cs (n:ns)
495 n : mergeSlots (c:cs) ns
497 panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
499 listToLivenessMask :: [Int] -> LivenessMask
500 listToLivenessMask [] = []
501 listToLivenessMask slots =
502 mkBS this : listToLivenessMask (map (\x -> x-32) rest)
503 where (this,rest) = span (<32) slots
505 livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
506 livenessToAbsC uniq mask =
507 absC (CBitmap lbl mask) `thenC`
508 returnFC (Liveness lbl mask)
509 where lbl = mkBitmapLabel uniq
512 In a continuation, we want a liveness mask that starts from just after
513 the return address, which is on the stack at realSp.
516 buildContLivenessMask
519 buildContLivenessMask uniq = do
521 buildLivenessMask uniq (realSp-1)
524 %************************************************************************
526 \subsection[CgMonad-deadslots]{Finding dead stack slots}
528 %************************************************************************
530 nukeDeadBindings does the following:
532 - Removes all bindings from the environment other than those
533 for variables in the argument to nukeDeadBindings.
534 - Collects any stack slots so freed, and returns them to the stack free
536 - Moves the virtual stack pointer to point to the topmost used
539 You can have multi-word slots on the stack (where a Double# used to
540 be, for instance); if dead, such a slot will be reported as *several*
541 offsets (one per word).
543 Probably *naughty* to look inside monad...
546 nukeDeadBindings :: StgLiveVars -- All the *live* variables
548 nukeDeadBindings live_vars = do
550 let (dead_stk_slots, bs') =
553 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
554 setBinds $ mkVarEnv bs'
555 freeStackSlots dead_stk_slots
558 Several boring auxiliary functions to do the dirty work.
561 dead_slots :: StgLiveVars
565 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
567 -- dead_slots carries accumulating parameters for
568 -- filtered bindings, dead slots
569 dead_slots live_vars fbs ds []
570 = (ds, reverse fbs) -- Finished; rm the dups, if any
572 dead_slots live_vars fbs ds ((v,i):bs)
573 | v `elementOfUniqSet` live_vars
574 = dead_slots live_vars ((v,i):fbs) ds bs
575 -- Live, so don't record it in dead slots
576 -- Instead keep it in the filtered bindings
580 MkCgIdInfo _ _ stable_loc _
581 | is_stk_loc && size > 0 ->
582 dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
584 maybe_stk_loc = maybeStkLoc stable_loc
585 is_stk_loc = maybeToBool maybe_stk_loc
586 (Just offset) = maybe_stk_loc
588 _ -> dead_slots live_vars fbs ds bs
592 size = (getPrimRepSize . typePrimRep . idType) v