getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
- buildLivenessMask, buildContLivenessMask
+ buildContLivenessMask
) where
#include "HsVersions.h"
import CgMonad
import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
-import CgStackery ( freeStackSlots )
+import CgStackery ( freeStackSlots, getStackFrame )
import CLabel ( mkClosureLabel,
mkBitmapLabel, pprCLabel )
import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-import BitSet ( mkBS, emptyBS )
+import Bitmap
import PrimRep ( isFollowableRep, getPrimRepSize )
import Id ( Id, idPrimRep, idType )
import Type ( typePrimRep )
import VarEnv
import VarSet ( varSetElems )
import Literal ( Literal )
-import Maybes ( catMaybes, maybeToBool )
-import Name ( isLocalName, NamedThing(..) )
+import Maybes ( catMaybes, maybeToBool, seqMaybe )
+import Name ( Name, isInternalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
| TempVarLoc Unique
| RegLoc MagicId -- in one of the magic registers
- -- (probably {Int,Float,Char,etc}Reg
+ -- (probably {Int,Float,Char,etc}Reg)
| VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure)
setBinds $ modifyVarEnv mangle_fn binds name
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name = do
- static_binds <- getStaticBinds
- local_binds <- getBinds
- case (lookupVarEnv local_binds name) of
- Nothing -> case (lookupVarEnv static_binds name) of
- Nothing -> cgPanic (text "lookupBindC: no info for" <+> ppr name)
- Just this -> return this
- Just this -> return this
+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)
-cgPanic :: SDoc -> FCode a
-cgPanic doc = do
- static_binds <- getStaticBinds
+cgLookupPanic :: Id -> FCode a
+cgLookupPanic id
+ = do static_binds <- getStaticBinds
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "cgPanic"
- (vcat [doc,
+ (vcat [ppr id,
ptext SLIT("static binds for:"),
vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
- | not (isLocalName name)
- = returnFC (id, global_amode, mkLFImported id)
- -- deals with imported or locally defined but externally visible ids
- -- (CoreTidy makes all these into global names).
-
- | otherwise = do -- *might* be a nested defn: in any case, it's something whose
- -- definition we will know about...
- (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
- amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
- return (id', 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
in
case volatile_loc of
RegLoc reg -> consider_reg reg
- VirHpLoc _ -> consider_reg Hp
VirNodeLoc _ -> consider_reg node
non_reg_loc -> returnFC Nothing
bindNewToStack (name, offset)
= addBindC name info
where
- info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
+ info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) (mkLFArgument name)
bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
bindNewToNode name offset lf_info
-- temporary.
bindNewToTemp :: Id -> FCode CAddrMode
bindNewToTemp name
- = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument
+ = let (temp_amode, id_info) = newTempAmodeAndIdInfo name (mkLFArgument name)
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
bindArgsToRegs args regs
= listCs (zipWithEqual "bindArgsToRegs" bind args regs)
where
- arg `bind` reg = bindNewToReg arg reg mkLFArgument
+ arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
\end{code}
@bindNewPrimToAmode@ works only for certain addressing modes. Making
%* *
%************************************************************************
-ToDo: remove the dependency on 32-bit words.
-
There are four kinds of things on the stack:
- pointer variables (bound in the environment)
- free slots (recorded in the stack free list)
- non-pointer data slots (recorded in the stack free list)
-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.
-
-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).
+We build up a bitmap of non-pointer slots by searching the environment
+for all the pointer variables, and subtracting these from a bitmap
+with initially all bits set (up to the size of the stack frame).
\begin{code}
buildLivenessMask
- :: Unique -- unique for for large bitmap label
+ :: VirtualSpOffset -- size of the stack frame
-> VirtualSpOffset -- offset from which the bitmap should start
- -> FCode Liveness -- mask for free/unlifted slots
+ -> FCode Bitmap -- mask for free/unlifted slots
+
+buildLivenessMask size sp = do {
+ -- find all live stack-resident pointers
+ binds <- getBinds;
+ ((vsp, _, free, _, _), heap_usage) <- getUsage;
+
+ let {
+ rel_slots = sortLt (<)
+ [ sp - ofs -- get slots relative to top of frame
+ | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ isFollowableRep (idPrimRep id)
+ ];
+ };
+
+ ASSERT(all (>=0) rel_slots)
+ return (intsToReverseBitmap size rel_slots)
+ }
+
+-- In a continuation, we want a liveness mask that starts from just after
+-- the return address, which is on the stack at realSp.
+
+buildContLivenessMask :: Name -> FCode Liveness
+buildContLivenessMask name = do
+ realSp <- getRealSp
-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
- let flatten_slots = sortLt (<)
- (foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
- unboxed_slots)
-
- -- merge in the free slots
- let all_slots = mergeSlots flatten_slots (map fst free) ++
- if vsp < sp then [vsp+1 .. sp] else []
-
- -- recalibrate the list to be sp-relative
- let rel_slots = reverse (map (sp-) all_slots)
-
- -- build the bitmap
- let liveness_mask = ASSERT(all (>=0) 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 [] = []
-listToLivenessMask slots =
- mkBS this : listToLivenessMask (map (\x -> x-32) rest)
- where (this,rest) = span (<32) slots
-
-livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq mask =
- absC (CBitmap lbl mask) `thenC`
- returnFC (Liveness lbl mask)
- where lbl = mkBitmapLabel uniq
-\end{code}
+ frame_sp <- getStackFrame
+ -- realSp points to the frame-header for the current stack frame,
+ -- and the end of this frame is frame_sp. The size is therefore
+ -- realSp - frame_sp - 1 (subtract one for the frame-header).
+ let frame_size = realSp - frame_sp - 1
-In a continuation, we want a liveness mask that starts from just after
-the return address, which is on the stack at realSp.
+ mask <- buildLivenessMask frame_size (realSp-1)
-\begin{code}
-buildContLivenessMask
- :: Unique
- -> FCode Liveness
-buildContLivenessMask uniq = do
- realSp <- getRealSp
- buildLivenessMask uniq (realSp-1)
+ let liveness = Liveness (mkBitmapLabel name) frame_size mask
+ absC (maybeLargeBitmap liveness)
+ return liveness
\end{code}
%************************************************************************
dead_slots live_vars
[] []
[ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
- let extra_free = sortLt (<) dead_stk_slots
setBinds $ mkVarEnv bs'
- freeStackSlots extra_free
+ freeStackSlots dead_stk_slots
\end{code}
Several boring auxiliary functions to do the dirty work.
projects / ghc-hetmet.git / blobdiff