\begin{code}
module CgBindery (
- CgBindings, CgIdInfo(..){-dubiously concrete-},
+ CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- maybeStkLoc,
-
stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
+ addBindC, addBindsC,
+
nukeVolatileBinds,
nukeDeadBindings,
import CgMonad
import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
-import CgStackery ( freeStackSlots, addFreeSlots )
-import CLabel ( mkStaticClosureLabel, mkClosureLabel,
- mkBitmapLabel )
+import CgStackery ( freeStackSlots )
+import CLabel ( mkClosureLabel,
+ mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import BitSet ( mkBS, emptyBS )
+import BitSet
import PrimRep ( isFollowableRep, getPrimRepSize )
-import DataCon ( DataCon, dataConName )
import Id ( Id, idPrimRep, idType )
import Type ( typePrimRep )
import VarEnv
import VarSet ( varSetElems )
-import Const ( Con(..), Literal )
-import Maybes ( catMaybes, maybeToBool )
-import Name ( isLocallyDefined, isWiredInName, NamedThing(..) )
+import Literal ( Literal )
+import Maybes ( catMaybes, maybeToBool, seqMaybe )
+import Name ( isInternalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
import PrimRep ( PrimRep(..) )
-import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) )
+import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
import Unique ( Unique, Uniquable(..) )
import UniqSet ( elementOfUniqSet )
-import Util ( zipWithEqual, panic, sortLt )
+import Util ( zipWithEqual, sortLt )
import Outputable
\end{code}
%************************************************************************
%* *
+\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
+%* *
+%************************************************************************
+
+There are three basic routines, for adding (@addBindC@), modifying
+(@modifyBindC@) and looking up (@lookupBindC@) bindings.
+
+A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
+The name should not already be bound. (nice ASSERT, eh?)
+
+\begin{code}
+addBindC :: Id -> CgIdInfo -> Code
+addBindC name stuff_to_bind = do
+ binds <- getBinds
+ setBinds $ extendVarEnv binds name stuff_to_bind
+
+addBindsC :: [(Id, CgIdInfo)] -> Code
+addBindsC new_bindings = do
+ binds <- getBinds
+ let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+ binds
+ new_bindings
+ setBinds new_binds
+
+modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
+modifyBindC name mangle_fn = do
+ binds <- getBinds
+ setBinds $ modifyVarEnv mangle_fn binds name
+
+lookupBindC :: Id -> FCode CgIdInfo
+lookupBindC id = do maybe_info <- lookupBindC_maybe id
+ case maybe_info of
+ Just info -> return info
+ Nothing -> cgLookupPanic id
+
+lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
+lookupBindC_maybe id
+ = do static_binds <- getStaticBinds
+ local_binds <- getBinds
+ return (lookupVarEnv local_binds id
+ `seqMaybe`
+ lookupVarEnv static_binds id)
+
+cgLookupPanic :: Id -> FCode a
+cgLookupPanic id
+ = do static_binds <- getStaticBinds
+ local_binds <- getBinds
+ srt <- getSRTLabel
+ pprPanic "cgPanic"
+ (vcat [ppr id,
+ ptext SLIT("static binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
+ ptext SLIT("local binds for:"),
+ vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
+ ptext SLIT("SRT label") <+> pprCLabel srt
+ ])
+\end{code}
+
+%************************************************************************
+%* *
\subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
%* *
%************************************************************************
I {\em think} all looking-up is done through @getCAddrMode(s)@.
\begin{code}
-getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
+getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
- | not (isLocallyDefined name) || isWiredInName name
- {- Why the "isWiredInName"?
- Imagine you are compiling PrelBase.hs (a module that
- supplies some of the wired-in values). What can
- happen is that the compiler will inject calls to
- (e.g.) GHCbase.unpackPS, where-ever it likes -- it
- assumes those values are ubiquitously available.
- The main point is: it may inject calls to them earlier
- in GHCbase.hs than the actual definition...
- -}
- = returnFC (global_amode, mkLFImported id)
-
- | otherwise = -- *might* be a nested defn: in any case, it's something whose
- -- definition we will know about...
- lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
- idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
- returnFC (amode, lf_info)
+ = do
+ maybe_cg_id_info <- lookupBindC_maybe id
+ case maybe_cg_id_info of
+
+ -- Nothing => not in the environment, so should be imported
+ Nothing | isInternalName name -> cgLookupPanic id
+ | otherwise -> returnFC (id, global_amode, mkLFImported id)
+
+ Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
+ -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
+ return (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
-getCAddrMode name
- = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
- returnFC amode
+getCAddrMode name = do
+ (_, amode, _) <- getCAddrModeAndInfo name
+ return amode
\end{code}
\begin{code}
getCAddrModeIfVolatile name
-- | toplevelishId name = returnFC Nothing
-- | otherwise
- = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
- case stable_loc of
- NoStableLoc -> -- Aha! So it is volatile!
- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
- returnFC (Just amode)
-
- a_stable_loc -> returnFC Nothing
+ = do
+ (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
+ case stable_loc of
+ NoStableLoc -> do -- Aha! So it is volatile!
+ amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
+ return $ Just amode
+ a_stable_loc -> return Nothing
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
\begin{code}
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
-getVolatileRegs vars
- = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
- returnFC (catMaybes stuff)
- where
- snaffle_it var
- = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
- let
- -- commoned-up code...
- consider_reg reg
- = if not (isVolatileReg reg) then
- -- Potentially dies across C calls
- -- For now, that's everything; we leave
- -- it to the save-macros to decide which
- -- regs *really* need to be saved.
- returnFC Nothing
- else
- case stable_loc of
- NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc ->
- -- has both volatile & stable locations;
- -- force it to rely on the stable location
- modifyBindC var nuke_vol_bind `thenC`
- returnFC Nothing
- in
- case volatile_loc of
- RegLoc reg -> consider_reg reg
- VirHpLoc _ -> consider_reg Hp
- VirNodeLoc _ -> consider_reg node
- non_reg_loc -> returnFC Nothing
-
- nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
- = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
+getVolatileRegs vars = do
+ stuff <- mapFCs snaffle_it (varSetElems vars)
+ returnFC $ catMaybes stuff
+ where
+ snaffle_it var = do
+ (MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
+ let
+ -- commoned-up code...
+ consider_reg reg =
+ if not (isVolatileReg reg) then
+ -- Potentially dies across C calls
+ -- For now, that's everything; we leave
+ -- it to the save-macros to decide which
+ -- regs *really* need to be saved.
+ returnFC Nothing
+ else
+ case stable_loc of
+ NoStableLoc -> returnFC (Just reg) -- got one!
+ is_a_stable_loc -> do
+ -- has both volatile & stable locations;
+ -- force it to rely on the stable location
+ modifyBindC var nuke_vol_bind
+ return Nothing
+ in
+ case volatile_loc of
+ RegLoc reg -> consider_reg reg
+ VirNodeLoc _ -> consider_reg node
+ non_reg_loc -> returnFC Nothing
+
+ nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
+ = MkCgIdInfo i NoVolatileLoc stable_loc lf_info
\end{code}
\begin{code}
getArgAmodes :: [StgArg] -> FCode [CAddrMode]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
- = getArgAmode atom `thenFC` \ amode ->
- getArgAmodes atoms `thenFC` \ amodes ->
- returnFC ( amode : amodes )
+ | isStgTypeArg atom
+ = getArgAmodes atoms
+ | otherwise = do
+ amode <- getArgAmode atom
+ amodes <- getArgAmodes atoms
+ return ( amode : amodes )
getArgAmode :: StgArg -> FCode CAddrMode
getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
-
-getArgAmode (StgConArg (DataCon con))
- {- Why does this case differ from StgVarArg?
- Because the program might look like this:
- data Foo a = Empty | Baz a
- f a x = let c = Empty! a
- in h c
- Now, when we go Core->Stg, we drop the type applications,
- so we can inline c, giving
- f x = h Empty
- Now we are referring to Empty as an argument (rather than in an STGCon),
- so we'll look it up with getCAddrMode. We want to return an amode for
- the static closure that we make for nullary constructors. But if we blindly
- go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
-
- This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
- Consider:
- f a x = Baz a x
- If the constructor Baz isn't inlined we simply want to treat it like any other
- identifier, with a top level definition. We don't want to spot that it's a constructor.
-
- In short
- StgApp con args
- and
- StgCon con args
- are treated differently; the former is a call to a bog standard function while the
- latter uses the specially-labelled, pre-defined info tables etc for the constructor.
-
- The way to think of this case in getArgAmode is that
- SApp f Empty
- is really
- App f (StgCon Empty [])
- -}
- = returnFC (CLbl (mkStaticClosureLabel (dataConName con)) PtrRep)
-
-
-getArgAmode (StgConArg (Literal lit)) = returnFC (CLit lit)
+getArgAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
%************************************************************************
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
- in
- addBindC name id_info `thenC`
- returnFC temp_amode
+ in do
+ addBindC name id_info
+ return temp_amode
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
where
info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info
-bindNewToLit name lit
- = addBindC name info
- where
- info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit")
-
bindArgsToRegs :: [Id] -> [MagicId] -> Code
bindArgsToRegs args regs
= listCs (zipWithEqual "bindArgsToRegs" bind args regs)
%* *
%************************************************************************
-ToDo: remove the dependency on 32-bit words.
-
-There are two ways to build a liveness mask, and both appear to have
-problems.
+There are four kinds of things on the stack:
- 1) Find all the pointer words by searching through the binding list.
- Invert this to find the non-pointer words and build the bitmap.
+ - pointer variables (bound in the environment)
+ - non-pointer variables (boudn in the environment)
+ - free slots (recorded in the stack free list)
+ - non-pointer data slots (recorded in the stack free list)
- 2) Find all the non-pointer words by search through the binding list.
- Merge this with the list of currently free slots. Build the
- bitmap.
+We build up a bitmap of non-pointer slots by looking down the
+environment for all the non-pointer variables, and merging this with
+the slots recorded in the stack free list.
-Method (1) conflicts with update frames - these contain pointers but
-have no bindings in the environment. We could bind the updatee to its
-location in the update frame at the point when the update frame is
-pushed, but this binding would be dropped by the first case expression
-(nukeDeadBindings).
-
-Method (2) causes problems because we must make sure that every
-non-pointer word on the stack is either a free stack slot or has a
-binding in the environment. Things like cost centres break this (but
-only for case-of-case expressions - because that's when there's a cost
-centre on the stack from the outer case and we need to generate a
-bitmap for the inner case's continuation).
-
-This method also works "by accident" for update frames: since all
-unaccounted for slots on the stack are assumed to be pointers, and an
-update frame always occurs at virtual Sp offsets 0-3 (i.e. the bottom
-of the stack frame), the bitmap will simply end at the start of the
-update frame.
-
-We use method (2) at the moment.
+There's a bit of a hack here to do with update frames: since nothing
+is recorded in either the environment or the stack free list for an
+update frame, the code below defaults to assuming the slots taken up
+by an update frame contain pointers. Furthermore, update frames are
+always in slots 0-2 at the bottom of the stack. The bitmap will
+therefore end at slot 3, which is what we want (the update frame info
+pointer has its own bitmap to describe the update frame).
\begin{code}
buildLivenessMask
-> VirtualSpOffset -- offset from which the bitmap should start
-> FCode Liveness -- mask for free/unlifted slots
-buildLivenessMask uniq sp info_down
- state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
- = ASSERT(all (>=0) rel_slots)
- livenessToAbsC uniq liveness_mask info_down state
- where
- -- find all unboxed stack-resident ids
- unboxed_slots =
- [ (ofs, getPrimRepSize rep) |
- (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- let rep = idPrimRep id,
- not (isFollowableRep rep)
- ]
+buildLivenessMask uniq sp = do
+ -- find all unboxed stack-resident ids
+ binds <- getBinds
+ ((vsp, free, _, _), heap_usage) <- getUsage
+
+ let unboxed_slots =
+ [ (ofs, size) |
+ (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ let rep = idPrimRep id; size = getPrimRepSize rep,
+ not (isFollowableRep rep),
+ size > 0
+ ]
+
-- flatten this list into a list of unboxed stack slots
- flatten_slots = foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
- unboxed_slots
+ let flatten_slots = sortLt (<)
+ (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
+ unboxed_slots)
-- merge in the free slots
- all_slots = addFreeSlots flatten_slots free ++
+ let all_slots = mergeSlots flatten_slots (map fst free) ++
if vsp < sp then [vsp+1 .. sp] else []
-- recalibrate the list to be sp-relative
- rel_slots = reverse (map (sp-) all_slots)
+ let rel_slots = reverse (map (sp-) all_slots)
-- build the bitmap
- liveness_mask = listToLivenessMask rel_slots
-
-{- ALTERNATE version that doesn't work because update frames aren't
- recorded in the environment.
-
- -- find all boxed stack-resident ids
- boxed_slots =
- [ ofs | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
- isFollowableRep (idPrimRep id)
- ]
- all_slots = [1..vsp]
-
- -- invert to get unboxed slots
- unboxed_slots = filter (`notElem` boxed_slots) all_slots
--}
+ let liveness_mask
+ = ASSERT(all (>=0) rel_slots
+ && rel_slots == sortLt (<) rel_slots)
+ (listToLivenessMask rel_slots)
+
+ livenessToAbsC uniq liveness_mask
+
+mergeSlots :: [Int] -> [Int] -> [Int]
+mergeSlots cs [] = cs
+mergeSlots [] ns = ns
+mergeSlots (c:cs) (n:ns)
+ = if c < n then
+ c : mergeSlots cs (n:ns)
+ else if c > n then
+ n : mergeSlots (c:cs) ns
+ else
+ panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
listToLivenessMask :: [Int] -> LivenessMask
listToLivenessMask [] = []
where (this,rest) = span (<32) slots
livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq [] = returnFC (LvSmall emptyBS)
-livenessToAbsC uniq [one] = returnFC (LvSmall one)
-livenessToAbsC uniq many =
- absC (CBitmap lbl many) `thenC`
- returnFC (LvLarge lbl)
- where lbl = mkBitmapLabel uniq
+livenessToAbsC uniq mask =
+ absC (CBitmap lbl mask) `thenC`
+ returnFC (Liveness lbl mask)
+ where lbl = mkBitmapLabel uniq
\end{code}
In a continuation, we want a liveness mask that starts from just after
buildContLivenessMask
:: Unique
-> FCode Liveness
-buildContLivenessMask uniq
- = getRealSp `thenFC` \ realSp ->
- buildLivenessMask uniq (realSp-1)
+buildContLivenessMask uniq = do
+ realSp <- getRealSp
+ buildLivenessMask uniq (realSp-1)
\end{code}
%************************************************************************
\begin{code}
nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
-
-nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
- = freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
- where
- (dead_stk_slots, bs')
- = dead_slots live_vars
- [] []
- [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
-
- extra_free = sortLt (<) dead_stk_slots
+nukeDeadBindings live_vars = do
+ binds <- getBinds
+ let (dead_stk_slots, bs') =
+ dead_slots live_vars
+ [] []
+ [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
+ setBinds $ mkVarEnv bs'
+ freeStackSlots dead_stk_slots
\end{code}
Several boring auxiliary functions to do the dirty work.
| otherwise
= case i of
MkCgIdInfo _ _ stable_loc _
- | is_stk_loc ->
+ | is_stk_loc && size > 0 ->
dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
where
maybe_stk_loc = maybeStkLoc stable_loc