X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=45481368d8a2c3aa20e3c5f8086068f20c448e7f;hb=084c8a024934d05d39e2c080b00b362605f893b9;hp=f204197bb2c368894650239370ed82d8b0713cd7;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index f204197..4548136 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -5,14 +5,14 @@ \begin{code} module CgBindery ( - CgBindings, CgIdInfo(..){-dubiously concrete-}, + CgBindings, CgIdInfo, StableLoc, VolatileLoc, - maybeStkLoc, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, letNoEscapeIdInfo, idInfoToAmode, + addBindC, addBindsC, + nukeVolatileBinds, nukeDeadBindings, @@ -32,28 +32,28 @@ import AbsCSyn 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 PrimRep ( isFollowableRep, getPrimRepSize ) import DataCon ( DataCon, dataConName ) -import Id ( Id, idPrimRep, idType ) +import Id ( Id, idPrimRep, idType, isDataConWrapId ) import Type ( typePrimRep ) import VarEnv import VarSet ( varSetElems ) -import Const ( Con(..), Literal ) +import Literal ( Literal ) import Maybes ( catMaybes, maybeToBool ) -import Name ( isLocallyDefined, isWiredInName, NamedThing(..) ) +import Name ( isLocallyDefined, 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} @@ -165,6 +165,63 @@ idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: %************************************************************************ %* * +\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 ticky _) + 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 ticky _) + 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} %* * %************************************************************************ @@ -195,8 +252,13 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocallyDefined name) || isWiredInName name - {- Why the "isWiredInName"? + | not (isLocallyDefined name) || isDataConWrapId id + -- Why the isDataConWrapId? Because CoreToStg changes a call to + -- a nullary constructor worker fn to a call to its wrapper, + -- which may not be defined until later + + {- -- OLD: the unpack stuff isn't injected now Jan 2000 + 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 @@ -285,6 +347,9 @@ getVolatileRegs vars getArgAmodes :: [StgArg] -> FCode [CAddrMode] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) + | isStgTypeArg atom + = getArgAmodes atoms + | otherwise = getArgAmode atom `thenFC` \ amode -> getArgAmodes atoms `thenFC` \ amodes -> returnFC ( amode : amodes ) @@ -292,43 +357,7 @@ getArgAmodes (atom:atoms) 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} %************************************************************************ @@ -416,36 +445,24 @@ rebindToStack name offset 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 @@ -460,18 +477,20 @@ buildLivenessMask uniq sp info_down where -- find all unboxed stack-resident ids unboxed_slots = - [ (ofs, getPrimRepSize rep) | + [ (ofs, size) | (MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds, - let rep = idPrimRep id, - not (isFollowableRep rep) + 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 + 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 ++ + all_slots = mergeSlots flatten_slots (map fst free) ++ if vsp < sp then [vsp+1 .. sp] else [] -- recalibrate the list to be sp-relative @@ -480,19 +499,16 @@ buildLivenessMask uniq sp info_down -- 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 --} +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 [] = [] @@ -580,7 +596,7 @@ dead_slots live_vars fbs ds ((v,i):bs) | 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