\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,
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}
| 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:
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)
= getSpBRelOffset i `thenFC` \ rel_spB ->
returnFC (CVal rel_spB kind)
+#ifdef DEBUG
idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
+#endif
\end{code}
%************************************************************************
\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
= 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
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
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
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`
\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}
%************************************************************************
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
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}
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}
projects / ghc-hetmet.git / blobdiff