%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgBindery]{Utility functions related to doing @CgBindings@}
\begin{code}
-#include "HsVersions.h"
-
module CgBindery (
- CgBindings(..), CgIdInfo(..){-dubiously concrete-},
+ CgBindings, CgIdInfo(..){-dubiously concrete-},
StableLoc, VolatileLoc,
- maybeAStkLoc, maybeBStkLoc,
+ maybeStkLoc,
stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
nukeVolatileBinds,
+ nukeDeadBindings,
- bindNewToAStack, bindNewToBStack,
+ bindNewToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp, bindNewPrimToAmode,
getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
- rebindToAStack, rebindToBStack
+
+ buildLivenessMask, buildContLivenessMask
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
+#include "HsVersions.h"
import AbsCSyn
import CgMonad
-import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel ( mkClosureLabel )
-import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument )
-import HeapOffs ( VirtualHeapOffset(..),
- VirtualSpAOffset(..), VirtualSpBOffset(..)
- )
-import Id ( idPrimRep, toplevelishId, isDataCon,
- mkIdEnv, rngIdEnv, IdEnv(..),
- idSetToList,
- GenId{-instance NamedThing-}
- )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined )
+import CgUsages ( getHpRelOffset, getSpRelOffset, getRealSp )
+import CgStackery ( freeStackSlots, addFreeSlots )
+import CLabel ( mkStaticClosureLabel, mkClosureLabel,
+ mkBitmapLabel )
+import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
+import BitSet ( mkBS, emptyBS )
+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(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
-import PprStyle ( PprStyle(..) )
-import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
-import Unpretty ( uppShow )
-import Util ( zipWithEqual, panic )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) )
+import Unique ( Unique, Uniquable(..) )
+import UniqSet ( elementOfUniqSet )
+import Util ( zipWithEqual, sortLt )
+import Outputable
\end{code}
| VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node
-- ie *(Node+offset)
+\end{code}
+
+@StableLoc@ encodes where an Id can be found, used by
+the @CgBindings@ environment in @CgBindery@.
+\begin{code}
data StableLoc
= NoStableLoc
- | VirAStkLoc VirtualSpAOffset
- | VirBStkLoc VirtualSpBOffset
+ | VirStkLoc VirtualSpOffset
| LitLoc Literal
| StableAmodeLoc CAddrMode
-- these are so StableLoc can be abstract:
-maybeAStkLoc (VirAStkLoc offset) = Just offset
-maybeAStkLoc _ = Nothing
-
-maybeBStkLoc (VirBStkLoc offset) = Just offset
-maybeBStkLoc _ = Nothing
+maybeStkLoc (VirStkLoc offset) = Just offset
+maybeStkLoc _ = Nothing
\end{code}
%************************************************************************
heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info
tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info
-letNoEscapeIdInfo i spa spb lf_info
- = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info
+letNoEscapeIdInfo i sp lf_info
+ = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint sp)) lf_info
newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
- uniq = uniqueOf name
+ uniq = getUnique name
temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode
idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc
- = returnFC (CVal (NodeRel nd_off) kind)
+ = returnFC (CVal (nodeRel nd_off) kind)
-- Virtual offsets from Node increase into the closures,
-- and so do Node-relative offsets (which we want in the CVal),
-- so there is no mucking about to do to the offset.
= getHpRelOffset hp_off `thenFC` \ rel_hp ->
returnFC (CAddr rel_hp)
-idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i)
- = getSpARelOffset i `thenFC` \ rel_spA ->
- returnFC (CVal rel_spA kind)
-
-idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i)
- = getSpBRelOffset i `thenFC` \ rel_spB ->
- returnFC (CVal rel_spB kind)
+idInfoPiecesToAmode kind NoVolatileLoc (VirStkLoc i)
+ = getSpRelOffset i `thenFC` \ rel_sp ->
+ returnFC (CVal rel_sp kind)
#ifdef DEBUG
idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
\begin{code}
nukeVolatileBinds :: CgBindings -> CgBindings
nukeVolatileBinds binds
- = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds))
+ = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds))
where
keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc
keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc
\begin{code}
getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
-getCAddrModeAndInfo name
- | not (isLocallyDefined name)
- = returnFC (global_amode, mkLFImported name)
-
- | isDataCon name
- = returnFC (global_amode, mkConLFInfo name)
+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 name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
+ lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
returnFC (amode, lf_info)
where
+ name = getName id
global_amode = CLbl (mkClosureLabel name) kind
- kind = idPrimRep name
+ kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
\begin{code}
getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
getCAddrModeIfVolatile name
- | toplevelishId name = returnFC Nothing
- | otherwise
+-- | 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!
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
- = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
+ = mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
returnFC (catMaybes stuff)
where
snaffle_it var
getArgAmode :: StgArg -> FCode CAddrMode
-getArgAmode (StgVarArg var) = getCAddrMode var
-getArgAmode (StgLitArg lit) = returnFC (CLit lit)
+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)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-bindNewToAStack :: (Id, VirtualSpAOffset) -> Code
-bindNewToAStack (name, offset)
- = addBindC name info
- where
- info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument
-
-bindNewToBStack :: (Id, VirtualSpBOffset) -> Code
-bindNewToBStack (name, offset)
+bindNewToStack :: (Id, VirtualSpOffset) -> Code
+bindNewToStack (name, offset)
= addBindC name info
where
- info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack")
- -- B-stack things shouldn't need lambda-form info!
+ info = MkCgIdInfo name NoVolatileLoc (VirStkLoc offset) mkLFArgument
bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code
bindNewToNode name offset lf_info
arg `bind` reg = bindNewToReg arg reg mkLFArgument
\end{code}
-@bindNewPrimToAmode@ works only for certain addressing modes, because
-those are the only ones we've needed so far!
+@bindNewPrimToAmode@ works only for certain addressing modes. Making
+this work for stack offsets is non-trivial (virt vs. real stack offset
+difficulties).
\begin{code}
bindNewPrimToAmode :: Id -> CAddrMode -> Code
-bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode")
- -- was: mkLFArgument
- -- LFinfo is irrelevant for primitives
+bindNewPrimToAmode name (CReg reg)
+ = bindNewToReg name reg (panic "bindNewPrimToAmode")
+
bindNewPrimToAmode name (CTemp uniq kind)
= addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
- -- LFinfo is irrelevant for primitives
-
-bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
-
-bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
- = bindNewToBStack (name, offset)
-
-bindNewPrimToAmode name (CVal (NodeRel offset) _)
- = bindNewToNode name offset (panic "bindNewPrimToAmode node")
- -- See comment on idInfoPiecesToAmode for VirNodeLoc
#ifdef DEBUG
bindNewPrimToAmode name amode
- = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode)))
+ = pprPanic "bindNew...:" (pprAmode amode)
#endif
\end{code}
\begin{code}
-rebindToAStack :: Id -> VirtualSpAOffset -> Code
-rebindToAStack name offset
+rebindToStack :: Id -> VirtualSpOffset -> Code
+rebindToStack name offset
= modifyBindC name replace_stable_fn
where
replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirAStkLoc offset) einfo
+ = MkCgIdInfo i vol (VirStkLoc offset) einfo
+\end{code}
-rebindToBStack :: Id -> VirtualSpBOffset -> Code
-rebindToBStack name offset
- = modifyBindC name replace_stable_fn
+%************************************************************************
+%* *
+\subsection[CgBindery-liveness]{Build a liveness mask for the current stack}
+%* *
+%************************************************************************
+
+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 search through the binding list.
+ Merge this with the list of currently free slots. Build the
+ bitmap.
+
+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.
+
+\begin{code}
+buildLivenessMask
+ :: Unique -- unique for for large bitmap label
+ -> 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
- replace_stable_fn (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i vol (VirBStkLoc offset) einfo
+ -- find all unboxed stack-resident ids
+ unboxed_slots =
+ [ (ofs, getPrimRepSize rep) |
+ (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
+ let rep = idPrimRep id,
+ not (isFollowableRep rep)
+ ]
+
+ -- flatten this list into a list of unboxed stack slots
+ 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 ++
+ if vsp < sp then [vsp+1 .. sp] else []
+
+ -- recalibrate the list to be sp-relative
+ 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
+-}
+
+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 [] = returnFC (LvSmall emptyBS)
+livenessToAbsC uniq [one] = returnFC (LvSmall one)
+livenessToAbsC uniq many =
+ absC (CBitmap lbl many) `thenC`
+ returnFC (LvLarge lbl)
+ where lbl = mkBitmapLabel uniq
+\end{code}
+
+In a continuation, we want a liveness mask that starts from just after
+the return address, which is on the stack at realSp.
+
+\begin{code}
+buildContLivenessMask
+ :: Unique
+ -> FCode Liveness
+buildContLivenessMask uniq
+ = getRealSp `thenFC` \ realSp ->
+ buildLivenessMask uniq (realSp-1)
\end{code}
+%************************************************************************
+%* *
+\subsection[CgMonad-deadslots]{Finding dead stack slots}
+%* *
+%************************************************************************
+
+nukeDeadBindings does the following:
+
+ - Removes all bindings from the environment other than those
+ for variables in the argument to nukeDeadBindings.
+ - Collects any stack slots so freed, and returns them to the stack free
+ list.
+ - Moves the virtual stack pointer to point to the topmost used
+ stack locations.
+
+You can have multi-word slots on the stack (where a Double# used to
+be, for instance); if dead, such a slot will be reported as *several*
+offsets (one per word).
+
+Probably *naughty* to look inside monad...
+
+\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
+\end{code}
+
+Several boring auxiliary functions to do the dirty work.
+
+\begin{code}
+dead_slots :: StgLiveVars
+ -> [(Id,CgIdInfo)]
+ -> [VirtualSpOffset]
+ -> [(Id,CgIdInfo)]
+ -> ([VirtualSpOffset], [(Id,CgIdInfo)])
+
+-- dead_slots carries accumulating parameters for
+-- filtered bindings, dead slots
+dead_slots live_vars fbs ds []
+ = (ds, reverse fbs) -- Finished; rm the dups, if any
+
+dead_slots live_vars fbs ds ((v,i):bs)
+ | v `elementOfUniqSet` live_vars
+ = dead_slots live_vars ((v,i):fbs) ds bs
+ -- Live, so don't record it in dead slots
+ -- Instead keep it in the filtered bindings
+
+ | otherwise
+ = case i of
+ MkCgIdInfo _ _ stable_loc _
+ | is_stk_loc ->
+ dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
+ where
+ maybe_stk_loc = maybeStkLoc stable_loc
+ is_stk_loc = maybeToBool maybe_stk_loc
+ (Just offset) = maybe_stk_loc
+
+ _ -> dead_slots live_vars fbs ds bs
+ where
+
+ size :: Int
+ size = (getPrimRepSize . typePrimRep . idType) v
+
+\end{code}
projects / ghc-hetmet.git / blobdiff