\begin{code}
module CgBindery (
- CgBindings, CgIdInfo(..){-dubiously concrete-},
+ CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- maybeStkLoc,
-
stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
+ addBindC, addBindsC,
+
nukeVolatileBinds,
nukeDeadBindings,
import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
import CgStackery ( freeStackSlots, addFreeSlots )
import CLabel ( mkStaticClosureLabel, mkClosureLabel,
- mkBitmapLabel )
+ mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
import BitSet ( mkBS, emptyBS )
import PrimRep ( isFollowableRep, getPrimRepSize )
%************************************************************************
%* *
+\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 info_down (MkCgState absC binds usage)
+ = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
+
+addBindsC :: [(Id, CgIdInfo)] -> Code
+addBindsC new_bindings info_down (MkCgState absC binds usage)
+ = MkCgState absC new_binds usage
+ where
+ new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+ binds
+ new_bindings
+
+modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
+modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
+ = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
+
+lookupBindC :: Id -> FCode CgIdInfo
+lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
+ state@(MkCgState absC local_binds usage)
+ = (val, state)
+ where
+ val = case (lookupVarEnv local_binds name) of
+ Nothing -> try_static
+ Just this -> this
+
+ try_static =
+ case (lookupVarEnv static_binds name) of
+ Just this -> this
+ Nothing
+ -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
+
+cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
+cgPanic doc info_down@(MkCgInfoDown _ static_binds srt _)
+ state@(MkCgState absC local_binds usage)
+ = pprPanic "cgPanic"
+ (vcat [doc,
+ 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}
%* *
%************************************************************************
ToDo: remove the dependency on 32-bit words.
-There are two ways to build a liveness mask, and both appear to have
-problems.
-
- 1) Find all the pointer words by searching through the binding list.
- Invert this to find the non-pointer words and build the bitmap.
-
- 2) Find all the non-pointer words by searching through the binding list.
- Merge this with the list of currently free slots. Build the
- bitmap.
+There are four kinds of things on the stack:
-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).
+ - 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)
-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).
+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.
-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
else
panic ("mergeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
-{- 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
--}
-
listToLivenessMask :: [Int] -> LivenessMask
listToLivenessMask [] = []
listToLivenessMask slots =
projects / ghc-hetmet.git / blobdiff