X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=f21d393b8326e4ad134ccba807c637074bb8f7b3;hb=a651e21e45b7e390ed65770d6181de874769a7eb;hp=fbc2fc9e214d8ee2ab68616bffdd74962d300277;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index fbc2fc9..f21d393 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -4,11 +4,9 @@ \section[CgBindery]{Utility functions related to doing @CgBindings@} \begin{code} -#include "HsVersions.h" - module CgBindery ( - CgBindings(..), CgIdInfo(..){-dubiously concrete-}, - StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-}, + CgBindings, CgIdInfo(..){-dubiously concrete-}, + StableLoc, VolatileLoc, maybeAStkLoc, maybeBStkLoc, @@ -19,37 +17,39 @@ module CgBindery ( bindNewToAStack, bindNewToBStack, bindNewToNode, bindNewToReg, bindArgsToRegs, ---UNUSED: bindNewToSameAsOther, bindNewToTemp, bindNewPrimToAmode, - getAtomAmode, getAtomAmodes, + getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, - rebindToAStack, rebindToBStack, ---UNUSED: rebindToTemp, - - -- and to make a self-sufficient interface... - AbstractC, CAddrMode, HeapOffset, MagicId, CLabel, CgState, - BasicLit, IdEnv(..), UniqFM, - Id, Maybe, Unique, StgAtom, UniqSet(..) + rebindToAStack, rebindToBStack ) where -IMPORT_Trace -- ToDo: rm (debugging only) -import Outputable -import Unpretty -import PprAbsC +#include "HsVersions.h" import AbsCSyn import CgMonad import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) -import CLabelInfo ( mkClosureLabel, CLabel ) -import ClosureInfo -import Id ( getIdKind, toplevelishId, isDataCon, Id ) -import IdEnv -- used to build CgBindings -import Maybes ( catMaybes, Maybe(..) ) -import UniqSet -- ( setToList ) -import StgSyn -import Util +import CLabel ( mkStaticClosureLabel, mkClosureLabel ) +import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo ) +import HeapOffs ( VirtualHeapOffset, + VirtualSpAOffset, VirtualSpBOffset + ) +import Id ( idPrimRep, toplevelishId, + mkIdEnv, rngIdEnv, IdEnv, + idSetToList, + Id + ) +import Literal ( Literal ) +import Maybes ( catMaybes ) +import Name ( isLocallyDefined, isWiredInName, + Name{-instance NamedThing-}, NamedThing(..) ) +import PprAbsC ( pprAmode ) +import PrimRep ( PrimRep ) +import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) ) +import Unique ( Unique, Uniquable(..) ) +import Util ( zipWithEqual, panic ) +import Outputable \end{code} @@ -87,12 +87,17 @@ data VolatileLoc | 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 - | LitLoc BasicLit + | LitLoc Literal | StableAmodeLoc CAddrMode -- these are so StableLoc can be abstract: @@ -123,14 +128,14 @@ newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo) newTempAmodeAndIdInfo name lf_info = (temp_amode, temp_idinfo) where - uniq = getTheUnique name - temp_amode = CTemp uniq (getIdKind name) + uniq = uniqueOf name + temp_amode = CTemp uniq (idPrimRep name) temp_idinfo = tempIdInfo name uniq lf_info -idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode +idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab -idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode +idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind) idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id) @@ -156,7 +161,9 @@ idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i) = getSpBRelOffset i `thenFC` \ rel_spB -> returnFC (CVal rel_spB kind) +#ifdef DEBUG idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc" +#endif \end{code} %************************************************************************ @@ -190,21 +197,28 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. \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 - global_amode = CLbl (mkClosureLabel name) kind - kind = getIdKind name + name = getName id + global_amode = CLbl (mkClosureLabel id) kind + kind = idPrimRep id getCAddrMode :: Id -> FCode CAddrMode getCAddrMode name @@ -220,7 +234,7 @@ getCAddrModeIfVolatile name = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) -> case stable_loc of NoStableLoc -> -- Aha! So it is volatile! - idInfoPiecesToAmode (getIdKind name) volatile_loc NoStableLoc `thenFC` \ amode -> + idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode -> returnFC (Just amode) a_stable_loc -> returnFC Nothing @@ -234,10 +248,10 @@ stable one (notably, on the stack), we modify the current bindings to forget the volatile one. \begin{code} -getVolatileRegs :: PlainStgLiveVars -> FCode [MagicId] +getVolatileRegs :: StgLiveVars -> FCode [MagicId] getVolatileRegs vars - = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff -> + = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff -> returnFC (catMaybes stuff) where snaffle_it var @@ -245,7 +259,7 @@ getVolatileRegs vars let -- commoned-up code... consider_reg reg - = if not (isVolatileReg reg) then + = 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 @@ -254,7 +268,7 @@ getVolatileRegs vars else case stable_loc of NoStableLoc -> returnFC (Just reg) -- got one! - is_a_stable_loc -> + is_a_stable_loc -> -- has both volatile & stable locations; -- force it to rely on the stable location modifyBindC var nuke_vol_bind `thenC` @@ -271,17 +285,52 @@ getVolatileRegs vars \end{code} \begin{code} -getAtomAmodes :: [PlainStgAtom] -> FCode [CAddrMode] -getAtomAmodes [] = returnFC [] -getAtomAmodes (atom:atoms) - = getAtomAmode atom `thenFC` \ amode -> - getAtomAmodes atoms `thenFC` \ amodes -> +getArgAmodes :: [StgArg] -> FCode [CAddrMode] +getArgAmodes [] = returnFC [] +getArgAmodes (atom:atoms) + = getArgAmode atom `thenFC` \ amode -> + getArgAmodes atoms `thenFC` \ amodes -> returnFC ( amode : amodes ) -getAtomAmode :: PlainStgAtom -> FCode CAddrMode - -getAtomAmode (StgVarAtom var) = getCAddrMode var -getAtomAmode (StgLitAtom lit) = returnFC (CLit lit) +getArgAmode :: StgArg -> FCode CAddrMode + +getArgAmode (StgConArg var) + {- 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 var) (idPrimRep var)) + +getArgAmode (StgVarArg var) = getCAddrMode var -- The common case + +getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} %************************************************************************ @@ -336,25 +385,9 @@ bindNewToLit name lit bindArgsToRegs :: [Id] -> [MagicId] -> Code bindArgsToRegs args regs - = listCs (zipWith bind args regs) - where - arg `bind` reg = bindNewToReg arg reg mkLFArgument - -{- UNUSED: -bindNewToSameAsOther :: Id -> PlainStgAtom -> Code -bindNewToSameAsOther name (StgVarAtom old_name) -#ifdef DEBUG - | toplevelishId old_name = panic "bindNewToSameAsOther: global old name" - | otherwise -#endif - = lookupBindC old_name `thenFC` \ old_stuff -> - addBindC name old_stuff - -bindNewToSameAsOther name (StgLitAtom lit) - = addBindC name info + = listCs (zipWithEqual "bindArgsToRegs" bind args regs) where - info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (panic "bindNewToSameAsOther") --} + arg `bind` reg = bindNewToReg arg reg mkLFArgument \end{code} @bindNewPrimToAmode@ works only for certain addressing modes, because @@ -371,16 +404,16 @@ bindNewPrimToAmode name (CTemp uniq kind) bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit -bindNewPrimToAmode name (CVal (SpBRel _ offset) _) +bindNewPrimToAmode name (CVal (SpBRel _ offset) _) = bindNewToBStack (name, offset) -bindNewPrimToAmode name (CVal (NodeRel 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} @@ -398,19 +431,5 @@ rebindToBStack name offset where replace_stable_fn (MkCgIdInfo i vol stab einfo) = MkCgIdInfo i vol (VirBStkLoc offset) einfo - -{- UNUSED: -rebindToTemp :: Id -> FCode CAddrMode -rebindToTemp name - = let - (temp_amode, MkCgIdInfo _ new_vol _ _ {-LF info discarded-}) - = newTempAmodeAndIdInfo name (panic "rebindToTemp") - in - modifyBindC name (replace_volatile_fn new_vol) `thenC` - returnFC temp_amode - where - replace_volatile_fn new_vol (MkCgIdInfo i vol stab einfo) - = MkCgIdInfo i new_vol stab einfo --} \end{code}