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 ( mkStaticClosureLabel, 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 )
43 import Type ( typePrimRep )
45 import VarSet ( varSetElems )
46 import Const ( Con(..), 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(..) )
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) || isWiredInName name
256 {- Why the "isWiredInName"?
257 Imagine you are compiling PrelBase.hs (a module that
258 supplies some of the wired-in values). What can
259 happen is that the compiler will inject calls to
260 (e.g.) GHCbase.unpackPS, where-ever it likes -- it
261 assumes those values are ubiquitously available.
262 The main point is: it may inject calls to them earlier
263 in GHCbase.hs than the actual definition...
265 = returnFC (global_amode, mkLFImported id)
267 | otherwise = -- *might* be a nested defn: in any case, it's something whose
268 -- definition we will know about...
269 lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
270 idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
271 returnFC (amode, lf_info)
274 global_amode = CLbl (mkClosureLabel name) kind
277 getCAddrMode :: Id -> FCode CAddrMode
279 = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
284 getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
285 getCAddrModeIfVolatile name
286 -- | toplevelishId name = returnFC Nothing
288 = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
290 NoStableLoc -> -- Aha! So it is volatile!
291 idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
292 returnFC (Just amode)
294 a_stable_loc -> returnFC Nothing
297 @getVolatileRegs@ gets a set of live variables, and returns a list of
298 all registers on which these variables depend. These are the regs
299 which must be saved and restored across any C calls. If a variable is
300 both in a volatile location (depending on a register) {\em and} a
301 stable one (notably, on the stack), we modify the current bindings to
302 forget the volatile one.
305 getVolatileRegs :: StgLiveVars -> FCode [MagicId]
308 = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
309 returnFC (catMaybes stuff)
312 = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
314 -- commoned-up code...
316 = if not (isVolatileReg reg) then
317 -- Potentially dies across C calls
318 -- For now, that's everything; we leave
319 -- it to the save-macros to decide which
320 -- regs *really* need to be saved.
324 NoStableLoc -> returnFC (Just reg) -- got one!
326 -- has both volatile & stable locations;
327 -- force it to rely on the stable location
328 modifyBindC var nuke_vol_bind `thenC`
332 RegLoc reg -> consider_reg reg
333 VirHpLoc _ -> consider_reg Hp
334 VirNodeLoc _ -> consider_reg node
335 non_reg_loc -> returnFC Nothing
337 nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
338 = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
342 getArgAmodes :: [StgArg] -> FCode [CAddrMode]
343 getArgAmodes [] = returnFC []
344 getArgAmodes (atom:atoms)
345 = getArgAmode atom `thenFC` \ amode ->
346 getArgAmodes atoms `thenFC` \ amodes ->
347 returnFC ( amode : amodes )
349 getArgAmode :: StgArg -> FCode CAddrMode
351 getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
353 getArgAmode (StgConArg (DataCon con))
354 {- Why does this case differ from StgVarArg?
355 Because the program might look like this:
356 data Foo a = Empty | Baz a
357 f a x = let c = Empty! a
359 Now, when we go Core->Stg, we drop the type applications,
360 so we can inline c, giving
362 Now we are referring to Empty as an argument (rather than in an STGCon),
363 so we'll look it up with getCAddrMode. We want to return an amode for
364 the static closure that we make for nullary constructors. But if we blindly
365 go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
367 This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
370 If the constructor Baz isn't inlined we simply want to treat it like any other
371 identifier, with a top level definition. We don't want to spot that it's a constructor.
377 are treated differently; the former is a call to a bog standard function while the
378 latter uses the specially-labelled, pre-defined info tables etc for the constructor.
380 The way to think of this case in getArgAmode is that
383 App f (StgCon Empty [])
385 = returnFC (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
388 getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit)
391 %************************************************************************
393 \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
395 %************************************************************************
398 bindNewToStack :: (Id, VirtualSpOffset) -> Code
399 bindNewToStack (name, offset)
402 info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
404 bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
405 bindNewToNode name offset lf_info
408 info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info
410 -- Create a new temporary whose unique is that in the id,
411 -- bind the id to it, and return the addressing mode for the
413 bindNewToTemp :: Id -> FCode CAddrMode
415 = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
416 -- This is used only for things we don't know
417 -- anything about; values returned by a case statement,
420 addBindC name id_info `thenC`
423 bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
424 bindNewToReg name magic_id lf_info
427 info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
429 bindNewToLit name lit
432 info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
434 bindArgsToRegs :: [Id] -> [MagicId] -> Code
435 bindArgsToRegs args regs
436 = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
438 arg `bind` reg = bindNewToReg arg reg mkLFArgument
441 @bindNewPrimToAmode@ works only for certain addressing modes. Making
442 this work for stack offsets is non-trivial (virt vs. real stack offset
446 bindNewPrimToAmode :: Id -> CAddrMode -> Code
447 bindNewPrimToAmode name (CReg reg)
448 = bindNewToReg name reg (panic "bindNewPrimToAmode")
450 bindNewPrimToAmode name (CTemp uniq kind)
451 = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
454 bindNewPrimToAmode name amode
455 = pprPanic "bindNew...:" (pprAmode amode)
460 rebindToStack :: Id -> VirtualSpOffset -> Code
461 rebindToStack name offset
462 = modifyBindC name replace_stable_fn
464 replace_stable_fn (MkCgIdInfo i vol stab einfo)
465 = MkCgIdInfo i vol (VirStkLoc offset) einfo
468 %************************************************************************
470 \subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
472 %************************************************************************
474 ToDo: remove the dependency on 32-bit words.
476 There are four kinds of things on the stack:
478 - pointer variables (bound in the environment)
479 - non-pointer variables (boudn in the environment)
480 - free slots (recorded in the stack free list)
481 - non-pointer data slots (recorded in the stack free list)
483 We build up a bitmap of non-pointer slots by looking down the
484 environment for all the non-pointer variables, and merging this with
485 the slots recorded in the stack free list.
487 There's a bit of a hack here to do with update frames: since nothing
488 is recorded in either the environment or the stack free list for an
489 update frame, the code below defaults to assuming the slots taken up
490 by an update frame contain pointers. Furthermore, update frames are
491 always in slots 0-2 at the bottom of the stack. The bitmap will
492 therefore end at slot 3, which is what we want (the update frame info
493 pointer has its own bitmap to describe the update frame).
497 :: Unique -- unique for for large bitmap label
498 -> VirtualSpOffset -- offset from which the bitmap should start
499 -> FCode Liveness -- mask for free/unlifted slots
501 buildLivenessMask uniq sp info_down
502 state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
503 = ASSERT(all (>=0) rel_slots)
504 livenessToAbsC uniq liveness_mask info_down state
506 -- find all unboxed stack-resident ids
509 (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
510 let rep = idPrimRep id; size = getPrimRepSize rep,
511 not (isFollowableRep rep),
515 -- flatten this list into a list of unboxed stack slots
516 flatten_slots = sortLt (<)
517 (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
520 -- merge in the free slots
521 all_slots = mergeSlots flatten_slots (map fst free) ++
522 if vsp < sp then [vsp+1 .. sp] else []
524 -- recalibrate the list to be sp-relative
525 rel_slots = reverse (map (sp-) all_slots)
528 liveness_mask = listToLivenessMask rel_slots
530 mergeSlots :: [Int] -> [Int] -> [Int]
531 mergeSlots cs [] = cs
532 mergeSlots [] ns = ns
533 mergeSlots (c:cs) (n:ns)
535 c : mergeSlots cs (n:ns)
537 n : mergeSlots (c:cs) ns
539 panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
541 listToLivenessMask :: [Int] -> LivenessMask
542 listToLivenessMask [] = []
543 listToLivenessMask slots =
544 mkBS this : listToLivenessMask (map (\x -> x-32) rest)
545 where (this,rest) = span (<32) slots
547 livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
548 livenessToAbsC uniq [] = returnFC (LvSmall emptyBS)
549 livenessToAbsC uniq [one] = returnFC (LvSmall one)
550 livenessToAbsC uniq many =
551 absC (CBitmap lbl many) `thenC`
552 returnFC (LvLarge lbl)
553 where lbl = mkBitmapLabel uniq
556 In a continuation, we want a liveness mask that starts from just after
557 the return address, which is on the stack at realSp.
560 buildContLivenessMask
563 buildContLivenessMask uniq
564 = getRealSp `thenFC` \ realSp ->
565 buildLivenessMask uniq (realSp-1)
568 %************************************************************************
570 \subsection[CgMonad-deadslots]{Finding dead stack slots}
572 %************************************************************************
574 nukeDeadBindings does the following:
576 - Removes all bindings from the environment other than those
577 for variables in the argument to nukeDeadBindings.
578 - Collects any stack slots so freed, and returns them to the stack free
580 - Moves the virtual stack pointer to point to the topmost used
583 You can have multi-word slots on the stack (where a Double# used to
584 be, for instance); if dead, such a slot will be reported as *several*
585 offsets (one per word).
587 Probably *naughty* to look inside monad...
590 nukeDeadBindings :: StgLiveVars -- All the *live* variables
593 nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
594 = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
596 (dead_stk_slots, bs')
597 = dead_slots live_vars
599 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
601 extra_free = sortLt (<) dead_stk_slots
604 Several boring auxiliary functions to do the dirty work.
607 dead_slots :: StgLiveVars
611 -> ([VirtualSpOffset], [(Id,CgIdInfo)])
613 -- dead_slots carries accumulating parameters for
614 -- filtered bindings, dead slots
615 dead_slots live_vars fbs ds []
616 = (ds, reverse fbs) -- Finished; rm the dups, if any
618 dead_slots live_vars fbs ds ((v,i):bs)
619 | v `elementOfUniqSet` live_vars
620 = dead_slots live_vars ((v,i):fbs) ds bs
621 -- Live, so don't record it in dead slots
622 -- Instead keep it in the filtered bindings
626 MkCgIdInfo _ _ stable_loc _
627 | is_stk_loc && size > 0 ->
628 dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
630 maybe_stk_loc = maybeStkLoc stable_loc
631 is_stk_loc = maybeToBool maybe_stk_loc
632 (Just offset) = maybe_stk_loc
634 _ -> dead_slots live_vars fbs ds bs
638 size = (getPrimRepSize . typePrimRep . idType) v