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, addFreeSlots )
36 import CLabel ( mkClosureLabel,
37 mkBitmapLabel, pprCLabel )
38 import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
39 import BitSet ( mkBS, emptyBS )
40 import PrimRep ( isFollowableRep, getPrimRepSize )
41 import DataCon ( DataCon, dataConName )
42 import Id ( Id, idPrimRep, idType, isDataConWrapId )
43 import Type ( typePrimRep )
45 import VarSet ( varSetElems )
46 import Literal ( Literal )
47 import Maybes ( catMaybes, maybeToBool )
48 import Name ( isLocallyDefined, isWiredInName, NamedThing(..) )
50 import PprAbsC ( pprAmode )
52 import PrimRep ( PrimRep(..) )
53 import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
54 import Unique ( Unique, Uniquable(..) )
55 import UniqSet ( elementOfUniqSet )
56 import Util ( zipWithEqual, sortLt )
61 %************************************************************************
63 \subsection[Bindery-datatypes]{Data types}
65 %************************************************************************
67 @(CgBinding a b)@ is a type of finite maps from a to b.
69 The assumption used to be that @lookupCgBind@ must get exactly one
70 match. This is {\em completely wrong} in the case of compiling
71 letrecs (where knot-tying is used). An initial binding is fed in (and
72 never evaluated); eventually, a correct binding is put into the
73 environment. So there can be two bindings for a given name.
76 type CgBindings = IdEnv CgIdInfo
79 = MkCgIdInfo Id -- Id that this is the info for
88 | RegLoc MagicId -- in one of the magic registers
89 -- (probably {Int,Float,Char,etc}Reg
91 | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
93 | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
97 @StableLoc@ encodes where an Id can be found, used by
98 the @CgBindings@ environment in @CgBindery@.
103 | VirStkLoc VirtualSpOffset
105 | StableAmodeLoc CAddrMode
107 -- these are so StableLoc can be abstract:
109 maybeStkLoc (VirStkLoc offset) = Just offset
110 maybeStkLoc _ = Nothing
113 %************************************************************************
115 \subsection[Bindery-idInfo]{Manipulating IdInfo}
117 %************************************************************************
120 stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info
121 heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
122 tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
124 letNoEscapeIdInfo i sp lf_info
125 = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
127 newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
129 newTempAmodeAndIdInfo name lf_info
130 = (temp_amode, temp_idinfo)
132 uniq = getUnique name
133 temp_amode = CTemp uniq (idPrimRep name)
134 temp_idinfo = tempIdInfo name uniq lf_info
136 idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
137 idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
139 idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
141 idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
142 idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
144 idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit)
145 idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
147 idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
148 = returnFC (CVal (nodeRel nd_off) kind)
149 -- Virtual offsets from Node increase into the closures,
150 -- and so do Node-relative offsets (which we want in the CVal),
151 -- so there is no mucking about to do to the offset.
153 idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc
154 = getHpRelOffset hp_off `thenFC` \ rel_hp ->
155 returnFC (CAddr rel_hp)
157 idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
158 = getSpRelOffset i `thenFC` \ rel_sp ->
159 returnFC (CVal rel_sp kind)
162 idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
166 %************************************************************************
168 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
170 %************************************************************************
172 There are three basic routines, for adding (@addBindC@), modifying
173 (@modifyBindC@) and looking up (@lookupBindC@) bindings.
175 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
176 The name should not already be bound. (nice ASSERT, eh?)
179 addBindC :: Id -> CgIdInfo -> Code
180 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
181 = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
183 addBindsC :: [(Id, CgIdInfo)] -> Code
184 addBindsC new_bindings info_down (MkCgState absC binds usage)
185 = MkCgState absC new_binds usage
187 new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
191 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
192 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
193 = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
195 lookupBindC :: Id -> FCode CgIdInfo
196 lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _)
197 state@(MkCgState absC local_binds usage)
200 val = case (lookupVarEnv local_binds name) of
201 Nothing -> try_static
205 case (lookupVarEnv static_binds name) of
208 -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
210 cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
211 cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _)
212 state@(MkCgState absC local_binds usage)
215 ptext SLIT("static binds for:"),
216 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
217 ptext SLIT("local binds for:"),
218 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
219 ptext SLIT("SRT label") <+> pprCLabel srt
223 %************************************************************************
225 \subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
227 %************************************************************************
229 We sometimes want to nuke all the volatile bindings; we must be sure
230 we don't leave any (NoVolatile, NoStable) binds around...
233 nukeVolatileBinds :: CgBindings -> CgBindings
234 nukeVolatileBinds binds
235 = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
237 keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
238 keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
239 = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc
243 %************************************************************************
245 \subsection[lookup-interface]{Interface functions to looking up bindings}
247 %************************************************************************
249 I {\em think} all looking-up is done through @getCAddrMode(s)@.
252 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
254 getCAddrModeAndInfo id
255 | not (isLocallyDefined name) || isDataConWrapId id
256 -- Why the isDataConWrapId? Because CoreToStg changes a call to
257 -- a nullary constructor worker fn to a call to its wrapper,
258 -- which may not be defined until later
260 {- -- OLD: the unpack stuff isn't injected now Jan 2000
261 Why the "isWiredInName"?
262 Imagine you are compiling PrelBase.hs (a module that
263 supplies some of the wired-in values). What can
264 happen is that the compiler will inject calls to
265 (e.g.) GHCbase.unpackPS, where-ever it likes -- it
266 assumes those values are ubiquitously available.
267 The main point is: it may inject calls to them earlier
268 in GHCbase.hs than the actual definition...
270 = returnFC (global_amode, mkLFImported id)
272 | otherwise = -- *might* be a nested defn: in any case, it's something whose
273 -- definition we will know about...
274 lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
275 idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
276 returnFC (amode, lf_info)
279 global_amode = CLbl (mkClosureLabel name) kind
282 getCAddrMode :: Id -> FCode CAddrMode
284 = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
289 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
290 getCAddrModeIfVolatile name
291 -- | toplevelishId name = returnFC Nothing
293 = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
295 NoStableLoc -> -- Aha! So it is volatile!
296 idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
297 returnFC (Just amode)
299 a_stable_loc -> returnFC Nothing
302 @getVolatileRegs@ gets a set of live variables, and returns a list of
303 all registers on which these variables depend. These are the regs
304 which must be saved and restored across any C calls. If a variable is
305 both in a volatile location (depending on a register) {\em and} a
306 stable one (notably, on the stack), we modify the current bindings to
307 forget the volatile one.
310 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
313 = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
314 returnFC (catMaybes stuff)
317 = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
319 -- commoned-up code...
321 = if not (isVolatileReg reg) then
322 -- Potentially dies across C calls
323 -- For now, that's everything; we leave
324 -- it to the save-macros to decide which
325 -- regs *really* need to be saved.
329 NoStableLoc -> returnFC (Just reg) -- got one!
331 -- has both volatile & stable locations;
332 -- force it to rely on the stable location
333 modifyBindC var nuke_vol_bind `thenC`
337 RegLoc reg -> consider_reg reg
338 VirHpLoc _ -> consider_reg Hp
339 VirNodeLoc _ -> consider_reg node
340 non_reg_loc -> returnFC Nothing
342 nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
343 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
347 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
348 getArgAmodes [] = returnFC []
349 getArgAmodes (atom:atoms)
353 = getArgAmode atom `thenFC` \ amode ->
354 getArgAmodes atoms `thenFC` \ amodes ->
355 returnFC ( amode : amodes )
357 getArgAmode :: StgArg -> FCode CAddrMode
359 getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
360 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
363 %************************************************************************
365 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
367 %************************************************************************
370 bindNewToStack :: (Id, VirtualSpOffset) -> Code
371 bindNewToStack (name, offset)
374 info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
376 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
377 bindNewToNode name offset lf_info
380 info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
382 -- Create a new temporary whose unique is that in the id,
383 -- bind the id to it, and return the addressing mode for the
385 bindNewToTemp :: Id -> FCode CAddrMode
387 = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
388 -- This is used only for things we don't know
389 -- anything about; values returned by a case statement,
392 addBindC name id_info `thenC`
395 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
396 bindNewToReg name magic_id lf_info
399 info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
401 bindNewToLit name lit
404 info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
406 bindArgsToRegs :: [Id] -> [MagicId] -> Code
407 bindArgsToRegs args regs
408 = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
410 arg `bind` reg = bindNewToReg arg reg mkLFArgument
413 @bindNewPrimToAmode@ works only for certain addressing modes. Making
414 this work for stack offsets is non-trivial (virt vs. real stack offset
418 bindNewPrimToAmode :: Id -> CAddrMode -> Code
419 bindNewPrimToAmode name (CReg reg)
420 = bindNewToReg name reg (panic "bindNewPrimToAmode")
422 bindNewPrimToAmode name (CTemp uniq kind)
423 = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
426 bindNewPrimToAmode name amode
427 = pprPanic "bindNew...:" (pprAmode amode)
432 rebindToStack :: Id -> VirtualSpOffset -> Code
433 rebindToStack name offset
434 = modifyBindC name replace_stable_fn
436 replace_stable_fn (MkCgIdInfo i vol stab einfo)
437 = MkCgIdInfo i vol (VirStkLoc offset) einfo
440 %************************************************************************
442 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
444 %************************************************************************
446 ToDo: remove the dependency on 32-bit words.
448 There are four kinds of things on the stack:
450 - pointer variables (bound in the environment)
451 - non-pointer variables (boudn in the environment)
452 - free slots (recorded in the stack free list)
453 - non-pointer data slots (recorded in the stack free list)
455 We build up a bitmap of non-pointer slots by looking down the
456 environment for all the non-pointer variables, and merging this with
457 the slots recorded in the stack free list.
459 There's a bit of a hack here to do with update frames: since nothing
460 is recorded in either the environment or the stack free list for an
461 update frame, the code below defaults to assuming the slots taken up
462 by an update frame contain pointers. Furthermore, update frames are
463 always in slots 0-2 at the bottom of the stack. The bitmap will
464 therefore end at slot 3, which is what we want (the update frame info
465 pointer has its own bitmap to describe the update frame).
469 :: Unique -- unique for for large bitmap label
470 -> VirtualSpOffset -- offset from which the bitmap should start
471 -> FCode Liveness -- mask for free/unlifted slots
473 buildLivenessMask uniq sp info_down
474 state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
475 = ASSERT(all (>=0) rel_slots)
476 livenessToAbsC uniq liveness_mask info_down state
478 -- find all unboxed stack-resident ids
481 (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
482 let rep = idPrimRep id; size = getPrimRepSize rep,
483 not (isFollowableRep rep),
487 -- flatten this list into a list of unboxed stack slots
488 flatten_slots = sortLt (<)
489 (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
492 -- merge in the free slots
493 all_slots = mergeSlots flatten_slots (map fst free) ++
494 if vsp < sp then [vsp+1 .. sp] else []
496 -- recalibrate the list to be sp-relative
497 rel_slots = reverse (map (sp-) all_slots)
500 liveness_mask = listToLivenessMask rel_slots
502 mergeSlots :: [Int] -> [Int] -> [Int]
503 mergeSlots cs [] = cs
504 mergeSlots [] ns = ns
505 mergeSlots (c:cs) (n:ns)
507 c : mergeSlots cs (n:ns)
509 n : mergeSlots (c:cs) ns
511 panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
513 listToLivenessMask :: [Int] -> LivenessMask
514 listToLivenessMask [] = []
515 listToLivenessMask slots =
516 mkBS this : listToLivenessMask (map (\x -> x-32) rest)
517 where (this,rest) = span (<32) slots
519 livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
520 livenessToAbsC uniq [] = returnFC (LvSmall emptyBS)
521 livenessToAbsC uniq [one] = returnFC (LvSmall one)
522 livenessToAbsC uniq many =
523 absC (CBitmap lbl many) `thenC`
524 returnFC (LvLarge lbl)
525 where lbl = mkBitmapLabel uniq
528 In a continuation, we want a liveness mask that starts from just after
529 the return address, which is on the stack at realSp.
532 buildContLivenessMask
535 buildContLivenessMask uniq
536 = getRealSp `thenFC` \ realSp ->
537 buildLivenessMask uniq (realSp-1)
540 %************************************************************************
542 \subsection[CgMonad-deadslots]{Finding dead stack slots}
544 %************************************************************************
546 nukeDeadBindings does the following:
548 - Removes all bindings from the environment other than those
549 for variables in the argument to nukeDeadBindings.
550 - Collects any stack slots so freed, and returns them to the stack free
552 - Moves the virtual stack pointer to point to the topmost used
555 You can have multi-word slots on the stack (where a Double# used to
556 be, for instance); if dead, such a slot will be reported as *several*
557 offsets (one per word).
559 Probably *naughty* to look inside monad...
562 nukeDeadBindings :: StgLiveVars -- All the *live* variables
565 nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
566 = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
568 (dead_stk_slots, bs')
569 = dead_slots live_vars
571 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
573 extra_free = sortLt (<) dead_stk_slots
576 Several boring auxiliary functions to do the dirty work.
579 dead_slots :: StgLiveVars
583 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
585 -- dead_slots carries accumulating parameters for
586 -- filtered bindings, dead slots
587 dead_slots live_vars fbs ds []
588 = (ds, reverse fbs) -- Finished; rm the dups, if any
590 dead_slots live_vars fbs ds ((v,i):bs)
591 | v `elementOfUniqSet` live_vars
592 = dead_slots live_vars ((v,i):fbs) ds bs
593 -- Live, so don't record it in dead slots
594 -- Instead keep it in the filtered bindings
598 MkCgIdInfo _ _ stable_loc _
599 | is_stk_loc && size > 0 ->
600 dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
602 maybe_stk_loc = maybeStkLoc stable_loc
603 is_stk_loc = maybeToBool maybe_stk_loc
604 (Just offset) = maybe_stk_loc
606 _ -> dead_slots live_vars fbs ds bs
610 size = (getPrimRepSize . typePrimRep . idType) v