%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.52 2003/05/14 09:13:52 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.53 2003/07/02 13:12:33 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
raw assembler/machine code.
\begin{code}
-module AbsCSyn {- (
- -- export everything
- AbstractC(..),
- C_SRT(..)
- CStmtMacro(..),
- CExprMacro(..),
- CAddrMode(..),
- ReturnInfo(..),
- mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- mkIntCLit,
- mkAbsCStmtList,
- mkCCostCentre,
-
- -- RegRelatives
- RegRelative(..),
-
- -- registers
- MagicId(..), node, infoptr,
- isVolatileReg,
- CostRes(Cost)
- )-} where
+module AbsCSyn where -- export everything
#include "HsVersions.h"
import AbsCSyn
import CLabel ( mkMAP_FROZEN_infoLabel )
import Digraph ( stronglyConnComp, SCC(..) )
-import DataCon ( fIRST_TAG, ConTag )
+import DataCon ( fIRST_TAG, dataConTag )
import Literal ( literalPrimRep, mkMachWord, mkMachInt )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
isDynamicTarget, isCasmTarget )
import StgSyn ( StgOp(..) )
+import CoreSyn ( AltCon(..) )
import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
import Outputable
import Panic ( panic )
import FastTypes
import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
-import Maybe ( isJust )
-
infixr 9 `thenFlt`
\end{code}
\end{code}
\begin{code}
-mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
+mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
-mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
- | isJust (nonemptyAbsC deflt_absc)
- = CSwitch scrutinee (adjust tagged_alts) deflt_absc
- | otherwise
- = CSwitch scrutinee (adjust rest) first_alt
+mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
+ = CSwitch scrutinee (adjust rest_alts) first_alt
where
- -- it's ok to convert one of the alts into a default if we don't already have
- -- one, because this is an algebraic case and we're guaranteed that the tag
- -- will match one of the branches.
- ((_,first_alt):rest) = tagged_alts
+ -- We use the first alt as the default. Either it *is* the DEFAULT,
+ -- (which is always first if present), or the case is exhaustive,
+ -- in which case we can use the first as the default anyway
-- Adjust the tags in the switch to start at zero.
-- This is the convention used by primitive ops which return algebraic
-- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
- = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
- | (tag, abs_c) <- tagged_alts ]
+ = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
+ | (DataAlt dc, abs_c) <- tagged_alts ]
\end{code}
%************************************************************************
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
playThreadSafe, ccallConvAttribute,
- ForeignCall(..), Safety(..), DNCallSpec(..),
+ ForeignCall(..), DNCallSpec(..),
DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
pprMagicId Hp = ptext SLIT("Hp")
pprMagicId HpLim = ptext SLIT("HpLim")
pprMagicId CurCostCentre = ptext SLIT("CCCS")
-pprMagicId VoidReg = panic "pprMagicId:VoidReg!"
+pprMagicId VoidReg = ptext SLIT("VoidReg")
pprVanillaReg :: Int# -> SDoc
pprVanillaReg n = char 'R' <> int (I# n)
CgBindings, CgIdInfo,
StableLoc, VolatileLoc,
- stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo,
+ stableAmodeIdInfo, heapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
bindNewToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
- bindNewToTemp, bindNewPrimToAmode,
+ bindNewToTemp,
getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
import VarSet ( varSetElems )
import Literal ( Literal )
import Maybes ( catMaybes, maybeToBool, seqMaybe )
-import Name ( Name, isInternalName, NamedThing(..) )
+import Name ( isInternalName, NamedThing(..) )
#ifdef DEBUG
-import PprAbsC ( pprAmode )
+import PprAbsC ( pprAmode, pprMagicId )
#endif
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
maybeStkLoc _ = Nothing
\end{code}
+\begin{code}
+instance Outputable CgIdInfo where
+ ppr (MkCgIdInfo id vol stb lf)
+ = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
+
+instance Outputable VolatileLoc where
+ ppr NoVolatileLoc = empty
+ ppr (TempVarLoc u) = ptext SLIT("tmp") <+> ppr u
+ ppr (RegLoc r) = ptext SLIT("reg") <+> pprMagicId r
+ ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
+ ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
+
+instance Outputable StableLoc where
+ ppr NoStableLoc = empty
+ ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
+ ppr (LitLoc l) = ptext SLIT("lit") <+> ppr l
+ ppr (StableAmodeLoc a) = ptext SLIT("amode") <+> pprAmode a
+\end{code}
+
%************************************************************************
%* *
\subsection[Bindery-idInfo]{Manipulating IdInfo}
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 = getUnique name
- temp_amode = CTemp uniq (idPrimRep name)
- temp_idinfo = tempIdInfo name uniq lf_info
-
idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
-- bind the id to it, and return the addressing mode for the
-- temporary.
bindNewToTemp :: Id -> FCode CAddrMode
-bindNewToTemp name
- = 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.
- in do
- addBindC name id_info
- return temp_amode
+bindNewToTemp id
+ = do addBindC id id_info
+ return temp_amode
+ where
+ uniq = getUnique id
+ temp_amode = CTemp uniq (idPrimRep id)
+ id_info = tempIdInfo id uniq lf_info
+ lf_info = mkLFArgument id -- Always used of things we
+ -- know nothing about
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
arg `bind` reg = bindNewToReg arg reg (mkLFArgument arg)
\end{code}
-@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")
-
-bindNewPrimToAmode name (CTemp uniq kind)
- = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode"))
-
-#ifdef DEBUG
-bindNewPrimToAmode name amode
- = pprPanic "bindNew...:" (pprAmode amode)
-#endif
-\end{code}
-
\begin{code}
rebindToStack :: Id -> VirtualSpOffset -> Code
rebindToStack name offset
];
};
- ASSERT(all (>=0) rel_slots)
- return (intsToReverseBitmap size rel_slots)
+ WARN( not (all (>=0) rel_slots), ppr size $$ ppr sp $$ ppr rel_slots $$ ppr binds )
+ 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
+buildContLivenessMask :: Id -> FCode Liveness
+ -- The Id is used just for its unique to make a label
+buildContLivenessMask id = do
realSp <- getRealSp
frame_sp <- getStackFrame
mask <- buildLivenessMask frame_size (realSp-1)
- let liveness = Liveness (mkBitmapLabel name) frame_size mask
+ let liveness = Liveness (mkBitmapLabel (getName id)) frame_size mask
absC (maybeLargeBitmap liveness)
return liveness
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.62 2003/05/14 09:13:53 simonmar Exp $
+% $Id: CgCase.lhs,v 1.63 2003/07/02 13:12:35 simonpj Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+module CgCase ( cgCase, saveVolatileVarsAndRegs,
+ mkRetDirectTarget, restoreCurrentCostCentre
) where
#include "HsVersions.h"
import StgSyn
import AbsCSyn
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- getAmodeRep, nonemptyAbsC
- )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode, getCAddrModeAndInfo,
+ getCAddrModeAndInfo,
rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
buildContLivenessMask, nukeDeadBindings,
)
)
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
-import Id ( Id, idPrimRep, isDeadBinder )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
+import Id ( Id, idName, isDeadBinder )
+import DataCon ( dataConTag, fIRST_TAG, ConTag )
import VarSet ( varSetElems )
-import Literal ( Literal )
+import CoreSyn ( AltCon(..) )
import PrimOp ( primOpOutOfLine, PrimOp(..) )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
-import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
-import Name ( Name, getName )
+import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
-import Maybes ( maybeToBool )
import Util ( only )
+import List ( sortBy )
import Outputable
\end{code}
-> StgLiveVars
-> Id
-> SRT
- -> StgCaseAlts
+ -> AltType
+ -> [StgAlt]
-> Code
\end{code}
-Special case #1: PrimOps returning enumeration types.
-
-For enumeration types, we invent a temporary (builtin-unique 1) to
-hold the tag, and cross our fingers that this doesn't clash with
-anything else. Builtin-unique 0 is used for a similar reason when
-compiling enumerated-type primops in CgExpr.lhs. We can't use the
-unique from the case binder, because this is used to hold the actual
-closure (when the case binder is live, that is).
-
-There is an extra special case for
-
- case tagToEnum# x of
- ...
-
-which generates no code for the primop, unless x is used in the
-alternatives (in which case we lookup the tag in the relevant closure
-table to get the closure).
-
-Being a bit short of uniques for temporary variables here, we use
-newTagUnique to generate a new unique from the case binder. The case
-binder's unique will presumably have the 'c' tag (generated by
-CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
-doesn't clash with anything else.
+Special case #1: case of literal.
\begin{code}
-cgCase (StgOpApp op args _)
- live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
- | isEnumerationTyCon tycon
- = getArgAmodes args `thenFC` \ arg_amodes ->
-
- case op of {
- StgPrimOp TagToEnumOp -- No code!
- -> returnFC (only arg_amodes) ;
-
- _ -> -- Perform the operation
- let
- tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
- in
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- absC (COpStmt [tag_amode] op arg_amodes vol_regs)
- `thenC`
- -- NB: no liveness arg
- returnFC tag_amode
- } `thenFC` \ tag_amode ->
-
- let
- closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
- tag_amode PtrRep)
- PtrRep
- in
-
- -- Bind the default binder if necessary
- -- The deadness info is set by StgVarInfo
- (if (isDeadBinder bndr)
- then nopC
- else bindNewToTemp bndr `thenFC` \ bndr_amode ->
- absC (CAssign bndr_amode closure))
- `thenC`
-
- -- compile the alts
- cgAlgAlts NoGC False{-not polymorphic-} (getUnique bndr)
- Nothing{-cc_slot-} False{-no semi-tagging-}
- alts deflt False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-
- -- Do the switch
- absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
+ alt_type@(PrimAlt tycon) alts
+ = bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (CLit lit)) `thenC`
+ cgPrimAlts NoGC tmp_amode alts alt_type
\end{code}
-Special case #2: case of literal.
+Special case #2: scrutinising a primitive-typed variable. No
+evaluation required. We don't save volatile variables, nor do we do a
+heap-check in the alternatives. Instead, the heap usage of the
+alternatives is worst-cased and passed upstream. This can result in
+allocating more heap than strictly necessary, but it will sometimes
+eliminate a heap check altogether.
\begin{code}
-cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt alts =
- absC (CAssign (CTemp (getUnique bndr) (idPrimRep bndr)) (CLit lit)) `thenC`
- case alts of
- StgPrimAlts tycon alts deflt -> cgPrimInlineAlts bndr tycon alts deflt
- other -> pprPanic "cgCase: case of literal has strange alts" (pprStgAlts alts)
-\end{code}
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+ alt_type@(PrimAlt tycon) alts
+
+ = -- Careful! we can't just bind the default binder to the same thing
+ -- as the scrutinee, since it might be a stack location, and having
+ -- two bindings pointing at the same stack locn doesn't work (it
+ -- confuses nukeDeadBindings). Hence, use a new temp.
+ getCAddrMode v `thenFC` \ amode ->
+ bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode amode) `thenC`
+ cgPrimAlts NoGC amode alts alt_type
+ -- TEMP Should be tmp_amode, not amode
+ -- but for line-by-line comparison with old stuff, we pass amode too
+\end{code}
Special case #3: inline PrimOps.
\begin{code}
cgCase (StgOpApp op@(StgPrimOp primop) args _)
- live_in_whole_case live_in_alts bndr srt alts
+ live_in_whole_case live_in_alts bndr srt alt_type alts
| not (primOpOutOfLine primop)
- =
- -- Get amodes for the arguments and results
+ = -- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- case alts of
- StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
- -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
- op
- arg_amodes -- note: no liveness arg
- vol_regs) `thenC`
- cgPrimInlineAlts bndr tycon alts deflt
-
- StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
- | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
- -> -- no heap check, no yield, just get in there and do it.
- absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
- op
- arg_amodes -- note: no liveness arg
- vol_regs) `thenC`
- mapFCs bindNewToTemp args `thenFC` \ _ ->
+ case alt_type of
+ PrimAlt tycon -- PRIMITIVE ALTS
+ -> bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC`
+ -- Note: no liveness arg
+ cgPrimAlts NoGC tmp_amode alts alt_type
+
+ UbxTupAlt tycon -- UNBOXED TUPLE ALTS
+ -> -- No heap check, no yield, just get in there and do it.
+ -- NB: the case binder isn't bound to anything;
+ -- it has a unboxed tuple type
+ mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps ->
+ absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC`
cgExpr rhs
-
- other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
+ where
+ [(_, res_ids, _, rhs)] = alts
+
+ AlgAlt tycon -- ENUMERATION TYPE RETURN
+ -> ASSERT( isEnumerationTyCon tycon )
+ do_enum_primop primop `thenFC` \ tag_amode ->
+
+ -- Bind the default binder if necessary
+ -- (avoiding it avoids the assignment)
+ -- The deadness info is set by StgVarInfo
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
+ ) `thenC`
+
+ -- Compile the alts
+ cgAlgAlts NoGC (getUnique bndr)
+ Nothing{-cc_slot-} False{-no semi-tagging-}
+ (AlgAlt tycon) alts `thenFC` \ tagged_alts ->
+
+ -- Do the switch
+ absC (mkAlgAltsCSwitch tag_amode tagged_alts)
+ where
+ do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ = returnFC (only arg_amodes)
+
+ do_enum_primop primop
+ = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ returnFC tag_amode
+ where
+ tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+ -- Being a bit short of uniques for temporary variables here,
+ -- we use newTagUnique to generate a new unique from the case
+ -- binder. The case binder's unique will presumably have
+ -- the 'c' tag (generated by CoreToStg), so we just change
+ -- its tag to 'C' (for 'case') to ensure it doesn't clash with
+ -- anything else.
+ -- We can't use the unique from the case binder, becaus e
+ -- this is used to hold the actual result closure
+ -- (via the call to bindNewToTemp)
+
+ other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
ghc/lib/misc/PackedString.lhs for examples where this crops up (with
4.02).
-Another special case: scrutinising a primitive-typed variable. No
-evaluation required. We don't save volatile variables, nor do we do a
-heap-check in the alternatives. Instead, the heap usage of the
-alternatives is worst-cased and passed upstream. This can result in
-allocating more heap than strictly necessary, but it will sometimes
-eliminate a heap check altogether.
-
-\begin{code}
-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
- (StgPrimAlts tycon alts deflt)
-
- =
- getCAddrMode v `thenFC` \amode ->
-
- {-
- Careful! we can't just bind the default binder to the same thing
- as the scrutinee, since it might be a stack location, and having
- two bindings pointing at the same stack locn doesn't work (it
- confuses nukeDeadBindings). Hence, use a new temp.
- -}
- bindNewToTemp bndr `thenFC` \deflt_amode ->
- absC (CAssign deflt_amode amode) `thenC`
-
- cgPrimAlts NoGC amode alts deflt []
-\end{code}
-
Special case: scrutinising a non-primitive variable.
This can be done a little better than the general case, because
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr srt alts
+ live_in_whole_case live_in_alts bndr srt alt_type alts
= getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
( allocStackTop retPrimRepSize
`thenFC` \_ -> nopC )
( deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts )
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
`thenFC` \ scrut_eob_info ->
- setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
performTailCall fun' fun_amode lf_info arg_amodes save_assts
\end{code}
Finally, here is the general case.
\begin{code}
-cgCase expr live_in_whole_case live_in_alts bndr srt alts
+cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_case `thenC`
`thenFC` \_ -> nopC
)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
- setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
cgExpr expr
\end{code}
could be anywhere within the record).
\begin{code}
-maybeReserveSeqFrame (StgAlgAlts Nothing _ _)
- (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
+maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
= EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
-
maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
-> Id
-> SRT -- SRT for the continuation
- -> StgCaseAlts
+ -> AltType
+ -> [StgAlt]
-> FCode Sequel -- Any addr modes inside are guaranteed
-- to be a label so that we can duplicate it
-- without risk of duplicating code
-cgEvalAlts cc_slot bndr srt alts
- =
- let uniq = getUnique bndr; name = getName bndr in
-
- buildContLivenessMask name `thenFC` \ liveness ->
-
- case alts of
-
- -- algebraic alts ...
- StgAlgAlts maybe_tycon alts deflt ->
+cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
+ = -- Unboxed tuple case
+ -- By now, the simplifier should have have turned it
+ -- into case e of (# a,b #) -> e
+ -- There shouldn't be a
+ -- case e of DEFAULT -> e
+ ASSERT2( case con of { DataAlt _ -> True; other -> False },
+ text "cgEvalAlts: dodgy case of unboxed tuple type" )
+
+ forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ restoreCurrentCostCentre cc_slot `thenC`
+ bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
+ -- Generate a heap check if necessary
+ unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop $
+ -- And finally the code for the alternative
+ cgExpr rhs
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+
+cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+ = forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ restoreCurrentCostCentre cc_slot `thenC`
+ bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
+ cgPrimAlts GCMayHappen (CReg reg) alts alt_type
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+ where
+ reg = dataReturnConvPrim kind
+ kind = tyConPrimRep tycon
- -- bind the default binder (it covers all the alternatives)
- bindNewToReg bndr node (mkLFArgument bndr) `thenC`
+cgEvalAlts cc_slot bndr srt alt_type alts
+ = -- Algebraic and polymorphic case
+ -- Bind the default binder
+ bindNewToReg bndr node (mkLFArgument bndr) `thenC`
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
--
-- which is worse than having the alt code in the switch statement
- let is_alg = maybeToBool maybe_tycon
- Just spec_tycon = maybe_tycon
- in
-
- -- Deal with the unboxed tuple case
- if is_alg && isUnboxedTupleTyCon spec_tycon then
- -- By now, the simplifier should have have turned it
- -- into case e of (# a,b #) -> e
- -- There shouldn't be a
- -- case e of DEFAULT -> e
- ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
- text "cgEvalAlts: dodgy case of unboxed tuple type" )
- let
- alt = head alts
- lbl = mkReturnInfoLabel uniq
- in
- cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
- returnFC (CaseAlts (CLbl lbl RetRep) Nothing False)
-
- -- normal algebraic (or polymorphic) case alternatives
- else let
- ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
- | otherwise = UnvectoredReturn 0
-
- use_labelled_alts = case ret_conv of
- VectoredReturn _ -> True
- _ -> False
-
- semi_tagged_stuff
- = if use_labelled_alts then
- cgSemiTaggedAlts bndr alts deflt -- Just <something>
- else
- Nothing -- no semi-tagging info
-
- in
- cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts
- alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
-
- mkReturnVector name tagged_alt_absCs deflt_absC srt liveness
- ret_conv `thenFC` \ return_vec ->
-
- returnFC (CaseAlts return_vec semi_tagged_stuff False)
-
- -- primitive alts...
- StgPrimAlts tycon alts deflt ->
-
- -- Restore the cost centre
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-
- -- Generate the switch
- getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-
- -- Generate the labelled block, starting with restore-cost-centre
- getSRTInfo name srt `thenFC` \srt_info ->
- absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
- srt_info liveness) `thenC`
-
- -- Return an amode for the block
- returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing False)
+ let ret_conv = case alt_type of
+ AlgAlt tc -> ctrlReturnConvAlg tc
+ PolyAlt -> UnvectoredReturn 0
+
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
+
+ semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
+
+ in
+ cgAlgAlts GCMayHappen (getUnique bndr)
+ cc_slot use_labelled_alts
+ alt_type alts `thenFC` \ tagged_alt_absCs ->
+
+ mkRetVecTarget bndr tagged_alt_absCs
+ srt ret_conv `thenFC` \ return_vec ->
+
+ returnFC (CaseAlts return_vec semi_tagged_stuff False)
\end{code}
\begin{code}
cgAlgAlts :: GCFlag
- -> Bool -- polymorphic case
- -> Unique
- -> Maybe VirtualSpOffset
- -> Bool -- True <=> branches must be labelled
- -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
- -> StgCaseDefault -- The default
- -> Bool -- Context switch at alts?
- -> FCode ([(ConTag, AbstractC)], -- The branches
- AbstractC -- The default case
- )
-
-cgAlgAlts gc_flag is_poly uniq restore_cc must_label_branches alts deflt
- emit_yield{-should a yield macro be emitted?-}
-
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
- (cgAlgDefault gc_flag is_poly uniq restore_cc must_label_branches deflt emit_yield)
-\end{code}
-
-\begin{code}
-cgAlgDefault :: GCFlag
- -> Bool -- polymorphic case
- -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
- -> StgCaseDefault -- input
- -> Bool
- -> FCode AbstractC -- output
-
-cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch StgNoDefault _
- = returnFC AbsCNop
-
-cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch
- (StgBindDefault rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = -- We have arranged that Node points to the thing
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- getAbsC (absC restore_cc `thenC`
- -- HWL: maybe need yield here
- --(if emit_yield
- -- then yield [node] True
- -- else absC AbsCNop) `thenC`
- algAltHeapCheck gc_flag is_poly [node] (cgExpr rhs)
- -- Node is live, but doesn't need to point at the thing itself;
- -- it's ok for Node to point to an indirection or FETCH_ME
- -- Hence no need to re-enter Node.
- ) `thenFC` \ abs_c ->
-
- let
- final_abs_c | must_label_branch = CCodeBlock lbl abs_c
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
--- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
+ -> Unique
+ -> Maybe VirtualSpOffset
+ -> Bool -- True <=> branches must be labelled
+ -- (used for semi-tagging)
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> [StgAlt] -- The alternatives
+ -> FCode [(AltCon, AbstractC)] -- The branches
+
+cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
+ = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
+ | alt <- alts]
cgAlgAlt :: GCFlag
- -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
- -> Bool -- Context switch at alts?
- -> (DataCon, [Id], [Bool], StgExpr)
- -> FCode (ConTag, AbstractC)
-
-cgAlgAlt gc_flag uniq cc_slot must_label_branch
- emit_yield{-should a yield macro be emitted?-}
- (con, args, use_mask, rhs)
- =
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- getAbsC (absC restore_cc `thenC`
- -- HWL: maybe need yield here
- -- (if emit_yield
- -- then yield [node] True -- XXX live regs wrong
- -- else absC AbsCNop) `thenC`
- (case gc_flag of
- NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
- GCMayHappen -> bindConArgs con args
- ) `thenC`
- algAltHeapCheck gc_flag False{-not poly-} [node] (
- cgExpr rhs)
- ) `thenFC` \ abs_c ->
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> StgAlt
+ -> FCode (AltCon, AbstractC)
+
+cgAlgAlt gc_flag uniq cc_slot must_label_branch
+ alt_type (con, args, use_mask, rhs)
+ = getAbsC (bind_con_args con args `thenFC` \ _ ->
+ restoreCurrentCostCentre cc_slot `thenC`
+ maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
+ ) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
- returnFC (tag, final_abs_c)
+ returnFC (con, final_abs_c)
where
- tag = dataConTag con
- lbl = mkAltLabel uniq tag
-
-cgUnboxedTupleAlt
- :: Unique -- unique for label of the alternative
- -> Maybe VirtualSpOffset -- Restore cost centre
- -> Bool -- ctxt switch
- -> (DataCon, [Id], [Bool], StgExpr) -- alternative
- -> FCode AbstractC
-
-cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
- = getAbsC (
- bindUnboxedTupleComponents args
- `thenFC` \ (live_regs, ptrs, nptrs, stack_res) ->
-
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- absC restore_cc `thenC`
-
- -- HWL: maybe need yield here
- -- (if emit_yield
- -- then yield live_regs True -- XXX live regs wrong?
- -- else absC AbsCNop) `thenC`
-
- -- generate a heap check if necessary
- possibleUnbxTupleHeapCheck GCMayHappen live_regs ptrs nptrs (
-
- -- and finally the code for the alternative
- cgExpr rhs)
- )
+ lbl = case con of
+ DataAlt dc -> mkAltLabel uniq (dataConTag dc)
+ DEFAULT -> mkDefaultLabel uniq
+ other -> pprPanic "cgAlgAlt" (ppr con)
+
+ bind_con_args DEFAULT args = nopC
+ bind_con_args (DataAlt dc) args = bindConArgs dc args
\end{code}
%************************************************************************
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Id
- -> [(DataCon, [Id], [Bool], StgExpr)]
- -> GenStgCaseDefault Id Id
+cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
+ -> Id
+ -> [StgAlt]
-> SemiTaggingStuff
-cgSemiTaggedAlts binder alts deflt
- = Just (map st_alt alts, st_deflt deflt)
+cgSemiTaggedAlts False binder alts
+ = Nothing
+cgSemiTaggedAlts True binder alts
+ = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
+ case head alts of
+ (DEFAULT, _, _, _) -> Just st_deflt
+ other -> Nothing)
where
- uniq = getUnique binder
+ uniq = getUnique binder
- st_deflt StgNoDefault = Nothing
+ st_deflt = (binder,
+ (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
+ mkDefaultLabel uniq))
- st_deflt (StgBindDefault _)
- = Just (Just binder,
- (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
- mkDefaultLabel uniq)
- )
-
- st_alt (con, args, use_mask, _)
- = -- Ha! Nothing to do; Node already points to the thing
- (con_tag,
+ st_alt con args -- Ha! Nothing to do; Node already points to the thing
+ = (con_tag,
(CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
[mkIntCLit (length args)], -- how big the thing in the heap is
join_label)
)
where
- con_tag = dataConTag con
- join_label = mkAltLabel uniq con_tag
+ con_tag = dataConTag con
+ join_label = mkAltLabel uniq con_tag
+
+
+tagToClosure :: TyCon -> CAddrMode -> CAddrMode
+-- Primops returning an enumeration type (notably Bool)
+-- actually return an index into
+-- the table of closures for the enumeration type
+tagToClosure tycon tag_amode
+ = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
+ where
+ closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
\end{code}
%************************************************************************
%* *
%************************************************************************
-@cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
+@cgPrimAlts@ generates suitable a @CSwitch@
for dealing with the alternatives of a primitive @case@, given an
addressing mode for the thing to scrutinise. It also keeps track of
the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
-cgPrimInlineAlts bndr tycon alts deflt
- = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
- where
- uniq = getUnique bndr
- kind = tyConPrimRep tycon
-
-cgPrimEvalAlts bndr tycon alts deflt
- = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
- where
- reg = dataReturnConvPrim kind
- kind = tyConPrimRep tycon
-
-cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
- = -- first bind the default if necessary
- bindNewPrimToAmode bndr scrutinee `thenC`
- cgPrimAlts gc_flag scrutinee alts deflt regs
-
-cgPrimAlts gc_flag scrutinee alts deflt regs
- = forkAlts (map (cgPrimAlt gc_flag regs) alts)
- (cgPrimDefault gc_flag regs deflt)
- `thenFC` \ (alt_absCs, deflt_absC) ->
-
+cgPrimAlts :: GCFlag
+ -> CAddrMode -- Scrutinee
+ -> [StgAlt] -- Alternatives
+ -> AltType
+ -> Code
+-- INVARIANT: the default binder is already bound
+cgPrimAlts gc_flag scrutinee alts alt_type
+ = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs ->
+ let
+ ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
+ alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
+ in
absC (CSwitch scrutinee alt_absCs deflt_absC)
-- CSwitch does sensible things with one or zero alternatives
-
cgPrimAlt :: GCFlag
- -> [MagicId] -- live registers
- -> (Literal, StgExpr) -- The alternative
- -> FCode (Literal, AbstractC) -- Its compiled form
-
-cgPrimAlt gc_flag regs (lit, rhs)
- = getAbsC rhs_code `thenFC` \ absC ->
- returnFC (lit,absC)
- where
- rhs_code = primAltHeapCheck gc_flag regs (cgExpr rhs)
-
-cgPrimDefault :: GCFlag
- -> [MagicId] -- live registers
- -> StgCaseDefault
- -> FCode AbstractC
-
-cgPrimDefault gc_flag regs StgNoDefault
- = panic "cgPrimDefault: No default in prim case"
-
-cgPrimDefault gc_flag regs (StgBindDefault rhs)
- = getAbsC (primAltHeapCheck gc_flag regs (cgExpr rhs))
+ -> AltType
+ -> StgAlt -- The alternative
+ -> FCode (AltCon, AbstractC) -- Its compiled form
+
+cgPrimAlt gc_flag alt_type (con, [], [], rhs)
+ = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
+ getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c ->
+ returnFC (con, abs_c)
\end{code}
%************************************************************************
\begin{code}
+maybeAltHeapCheck
+ :: GCFlag
+ -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -> Code -- Continuation
+ -> Code
+maybeAltHeapCheck NoGC _ code = code
+maybeAltHeapCheck GCMayHappen alt_type code
+ = -- HWL: maybe need yield here
+ -- yield [node] True -- XXX live regs wrong
+ altHeapCheck alt_type code
+
saveVolatileVarsAndRegs
:: StgLiveVars -- Vars which should be made safe
-> FCode (AbstractC, -- Assignments to do the saves
EndOfBlockInfo, -- sequel for the alts
Maybe VirtualSpOffset) -- Slot for current cost centre
-
saveVolatileVarsAndRegs vars
= saveVolatileVars vars `thenFC` \ var_saves ->
saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
maybe_cc_slot)
-saveVolatileVars :: StgLiveVars -- Vars which should be made safe
+saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
returnFC (Just slot,
CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
-restoreCurrentCostCentre Nothing = returnFC AbsCNop
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Code
+restoreCurrentCostCentre Nothing = nopC
restoreCurrentCostCentre (Just slot)
= getSpRelOffset slot `thenFC` \ sp_rel ->
freeStackSlots [slot] `thenC`
- returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCCS
-- has some sanity-checking in it.
mode for it.
\begin{code}
-mkReturnVector :: Name
- -> [(ConTag, AbstractC)] -- Branch codes
- -> AbstractC -- Default case
- -> SRT -- continuation's SRT
- -> Liveness -- stack liveness
- -> CtrlReturnConvention
- -> FCode CAddrMode
-
-mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTInfo name srt `thenFC` \ srt_info ->
- let
- (return_vec_amode, vtbl_body) = case ret_conv of {
-
- -- might be a polymorphic case...
- UnvectoredReturn 0 ->
- ASSERT(null tagged_alt_absCs)
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq deflt_absC srt_info liveness));
-
- UnvectoredReturn n ->
- -- find the tag explicitly rather than using tag_reg for now.
- -- on architectures with lots of regs the tag will be loaded
- -- into tag_reg by the code doing the returning.
- let
- tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
- in
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq
- (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- srt_info liveness));
-
- VectoredReturn table_size ->
- let
- (vector_table, alts_absC) =
- unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
-
- ret_vector = CRetVector vtbl_label vector_table srt_info liveness
- in
- (CLbl vtbl_label DataPtrRep,
- -- alts come first, because we don't want to declare all the symbols
- absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
- )
-
- } in
- vtbl_body `thenC`
- returnFC return_vec_amode
- -- )
+mkRetDirectTarget :: Id -- Used for labelling only
+ -> AbstractC -- Return code
+ -> SRT -- Live CAFs in return code
+ -> FCode CAddrMode -- Emit the labelled return block,
+ -- and return its label
+mkRetDirectTarget bndr abs_c srt
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
+ return lbl
where
- uniq = getUnique name
-
- vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnInfoLabel uniq
-
- deflt_lbl =
- case nonemptyAbsC deflt_absC of
- -- the simplifier might have eliminated a case
- Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
- Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
-
- mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
- mk_vector_entry tag
- = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> (deflt_lbl, AbsCNop)
- [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
- _ -> panic "mkReturnVector: too many"
+ name = idName bndr
+ uniq = getUnique name
+ lbl = CLbl (mkReturnInfoLabel uniq) RetRep
\end{code}
-%************************************************************************
-%* *
-\subsection[CgCase-utils]{Utilities for handling case expressions}
-%* *
-%************************************************************************
-
-'possibleHeapCheck' tests a flag passed in to decide whether to do a
-heap check or not. These heap checks are always in a case
-alternative, so we use altHeapCheck.
-
\begin{code}
-algAltHeapCheck
- :: GCFlag
- -> Bool -- polymorphic case
- -> [MagicId] -- live registers
- -> Code -- continuation
- -> Code
-
-algAltHeapCheck GCMayHappen is_poly regs code = altHeapCheck is_poly regs code
-algAltHeapCheck NoGC _ _ code = code
+mkRetVecTarget :: Id -- Just for its unique
+ -> [(AltCon, AbstractC)] -- Branch codes
+ -> SRT -- Continuation's SRT
+ -> CtrlReturnConvention
+ -> FCode CAddrMode
-primAltHeapCheck
- :: GCFlag
- -> [MagicId] -- live registers
- -> Code -- continuation
- -> Code
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
+ = ASSERT( null other_alts )
+ mkRetDirectTarget bndr deflt_absC srt
+ where
+ ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
-primAltHeapCheck GCMayHappen regs code = altHeapCheck True regs code
-primAltHeapCheck NoGC _ code = code
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
+ = mkRetDirectTarget bndr switch_absC srt
+ where
+ -- Find the tag explicitly rather than using tag_reg for now.
+ -- on architectures with lots of regs the tag will be loaded
+ -- into tag_reg by the code doing the returning.
+ tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+ switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
+
+
+mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ let
+ ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
+ in
+ absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
+ -- Alts come first, because we don't want to declare all the symbols
-possibleUnbxTupleHeapCheck
- :: GCFlag
- -> [MagicId] -- live registers
- -> Int -- no. of stack slots containing ptrs
- -> Int -- no. of stack slots containing nonptrs
- -> Code -- continuation
- -> Code
+ return (CLbl vtbl_lbl DataPtrRep)
+ where
+ tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
+ vector_table = map mk_vector_entry tags
+ alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
+ -- The sort is unnecessary; just there for now
+ -- to make the new order the same as the old
+ (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
+ (DEFAULT,_) `cmp` _ = GT
+ (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
+ (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
+ -- Others impossible
+
+ name = idName bndr
+ uniq = getUnique name
+ vtbl_lbl = mkVecTblLabel uniq
+
+ deflt_lbl :: CAddrMode
+ deflt_lbl = case tagged_alt_absCs of
+ (DEFAULT, abs_c) : _ -> get_block_label abs_c
+ other -> mkIntCLit 0
+ -- 'other' case: the simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation the default should never be taken,
+ -- so we just use '0' (=> seg fault if used)
+
+ mk_vector_entry :: ConTag -> CAddrMode
+ mk_vector_entry tag
+ = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
+ -- The comprehension neatly, and correctly, ignores the DEFAULT
+ [] -> deflt_lbl
+ [abs_c] -> get_block_label abs_c
+ _ -> panic "mkReturnVector: too many"
-possibleUnbxTupleHeapCheck GCMayHappen regs ptrs nptrs code
- = unbxTupleHeapCheck regs ptrs nptrs AbsCNop code
-possibleUnbxTupleHeapCheck NoGC _ _ _ code
- = code
+ get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
\end{code}
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConName, dataConRepArity
)
-import Id ( Id, idName, idPrimRep )
+import Id ( Id, idName, idPrimRep, isDeadBinder )
import Literal ( Literal(..) )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..), isFollowableRep )
\begin{code}
bindUnboxedTupleComponents
- :: [Id] -- args
- -> FCode ([MagicId], -- regs assigned
- Int, -- number of pointer stack slots
- Int, -- number of non-pointer stack slots
- Bool) -- any components on stack?
+ :: [Id] -- Aargs
+ -> FCode ([MagicId], -- Regs assigned
+ Int, -- Number of pointer stack slots
+ Int, -- Number of non-pointer stack slots
+ VirtualSpOffset) -- Offset of return address slot
+ -- (= realSP on entry)
bindUnboxedTupleComponents args
- = -- Assign as many components as possible to registers
+ = -- Assign as many components as possible to registers
let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
(reg_args, stk_args) = splitAtList arg_regs args
-- separate the rest of the args into pointers and non-pointers
- ( ptr_args, nptr_args ) =
+ (ptr_args, nptr_args) =
partition (isFollowableRep . idPrimRep) stk_args
in
-- Allocate the rest on the stack
+ -- The real SP points to the return address, above which any
+ -- leftover unboxed-tuple components will be allocated
getVirtSp `thenFC` \ vsp ->
getRealSp `thenFC` \ rsp ->
let
(ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp idPrimRep ptr_args
(nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
+ ptrs = ptr_sp - rsp
+ nptrs = nptr_sp - ptr_sp
in
-- The stack pointer points to the last stack-allocated component
setRealAndVirtualSp nptr_sp `thenC`
- -- need to explicitly free any empty slots we just jumped over
- (if vsp < rsp then freeStackSlots [vsp+1 .. rsp] else nopC) `thenC`
+ -- We have just allocated slots starting at real SP + 1, and set the new
+ -- virtual SP to the topmost allocated slot.
+ -- If the virtual SP started *below* the real SP, we've just jumped over
+ -- some slots that won't be in the free-list, so put them there
+ -- This commonly happens because we've freed the return-address slot
+ -- (trimming back the virtual SP), but the real SP still points to that slot
+ freeStackSlots [vsp+1,vsp+2 .. rsp] `thenC`
bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToStack ptr_offsets `thenC`
mapCs bindNewToStack nptr_offsets `thenC`
- returnFC (arg_regs,
- ptr_sp - rsp, nptr_sp - ptr_sp,
- notNull ptr_offsets || notNull ptr_offsets
- )
+ returnFC (arg_regs, ptrs, nptrs, rsp)
\end{code}
%************************************************************************
case sequel of
- CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl)))) False
+ CaseAlts _ (Just (alts, Just (deflt_bndr, (_,deflt_lbl)))) False
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
- case maybe_deflt of
- Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
- Just _ -> build_it_then jump_to_join_point
+ if isDeadBinder deflt_bndr
+ then performReturn AbsCNop {- No reg assts -} jump_to_join_point
+ else build_it_then jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.53 2003/05/14 09:13:55 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.54 2003/07/02 13:12:36 simonpj Exp $
%
%********************************************************
%* *
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
+import CoreSyn ( AltCon(..) )
import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
nukeDeadBindings, addBindC, addBindsC )
-import CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre )
+import CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
(\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
where
dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
+ -- The '0' is just to get a random spare temp
--
-- if you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
module, @CgCase@.
\begin{code}
-cgExpr (StgCase expr live_vars save_vars bndr srt alts)
- = cgCase expr live_vars save_vars bndr srt alts
+cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
+ = cgCase expr live_vars save_vars bndr srt alt_type alts
\end{code}
nukeDeadBindings live_in_whole_let `thenC`
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
- -- ToDo: cost centre???
+
+ -- TEMP: put back in for line-by-line compatibility
+ -- Doesn't look right; surely should restore in the branch!
+ -- And the code isn't used....
restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
- (StgAlgAlts (Just tycon)
- [(con, params, use_mask,
- (StgApp selectee [{-no args-}]))]
- StgNoDefault))
+ (AlgAlt tycon)
+ [(DataAlt con, params, use_mask,
+ (StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
(StgNonRec binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive binder rhs
+ NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.36 2002/12/18 16:15:43 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.37 2003/07/02 13:12:36 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
#include "HsVersions.h"
import AbsCSyn
+import StgSyn ( AltType(..) )
import CLabel
import CgMonad
-
import CgStackery ( getFinalStackHW )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
)
+import CgRetConv ( dataReturnConvPrim )
import ClosureInfo ( closureSize, closureGoodStuffSize,
slopSize, allocProfilingMsg, ClosureInfo
)
+import TyCon ( tyConPrimRep )
import PrimRep ( PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_GranMacros )
import Outputable
-
#ifdef DEBUG
-import PprAbsC ( pprMagicId ) -- tmp
+import PprAbsC ( pprMagicId )
#endif
import GLAEXTS
\begin{code}
altHeapCheck
- :: Bool -- do not enter node on return
- -> [MagicId] -- live registers
- -> Code -- continuation
- -> Code
-
-
--- normal algebraic and primitive case alternatives:
-
-altHeapCheck no_enter regs code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
+ :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -- (Unboxed tuples are dealt with by ubxTupleHeapCheck)
+ -> Code -- Continuation
+ -> Code
+altHeapCheck alt_type code
+ = initHeapUsage (\ hHw ->
+ do_heap_chk hHw `thenC`
+ setRealHp hHw `thenC`
+ code)
where
do_heap_chk :: HeapOffset -> Code
do_heap_chk words_required
- = getTickyCtrLabel `thenFC` \ ctr ->
- absC ( if words_required == 0
- then AbsCNop
- else mkAbstractCs
- [ checking_code,
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( -- NB The conditional is inside the absC,
+ -- so the monadic stuff doesn't depend on
+ -- the value of words_required!
+ if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ CCheck (checking_code alt_type)
+ [mkIntCLit words_required] AbsCNop,
profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
- ]
- ) `thenC`
- setRealHp words_required
-
- where
- non_void_regs = filter (/= VoidReg) regs
-
- checking_code =
- case non_void_regs of
-
- -- No regs live: probably a Void return
- [] ->
- CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
-
- [VanillaReg rep 1#]
- -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
- | isFollowableRep rep && no_enter ->
- CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-
- -- R1 is lifted (the common case)
- | isFollowableRep rep ->
- CCheck HP_CHK_NP
- [mkIntCLit words_required]
- AbsCNop
-
- -- R1 is unboxed
- | otherwise ->
- CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
-
- -- FloatReg1
- [FloatReg 1#] ->
- CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
-
- -- DblReg1
- [DoubleReg 1#] ->
- CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
-
- -- LngReg1
- [LongReg _ 1#] ->
- CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
-
+ ])
+
+ checking_code PolyAlt
+ = HP_CHK_UNPT_R1 -- Do *not* enter R1 after a heap check in
+ -- a polymorphic case. It might be a function
+ -- and the entry code for a function (currently)
+ -- applies it
+ --
+ -- However R1 is guaranteed to be a pointer
+
+ checking_code (AlgAlt tc)
+ = HP_CHK_NP -- Enter R1 after the heap check; it's a pointer
+ -- The "NP" is short for "Node (R1) Points to it"
+
+ checking_code (PrimAlt tc)
+ = case dataReturnConvPrim (tyConPrimRep tc) of
+ VoidReg -> HP_CHK_NOREGS
+ FloatReg 1# -> HP_CHK_F1
+ DoubleReg 1# -> HP_CHK_D1
+ LongReg _ 1# -> HP_CHK_L1
+ VanillaReg rep 1#
+ | isFollowableRep rep -> HP_CHK_UNPT_R1 -- R1 is boxed but unlifted:
+ | otherwise -> HP_CHK_UNBX_R1 -- R1 is unboxed
#ifdef DEBUG
- _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
+ other_reg -> pprPanic "CgHeapery.altHeapCheck" (ppr tc <+> pprMagicId other_reg)
#endif
--- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- Unboxed tuple alternatives and let-no-escapes (the two most annoying
-- constructs to generate code for!):
unbxTupleHeapCheck
absC ( if words_required == 0
then AbsCNop
else mkAbstractCs
- [ checking_code,
+ [ checking_code words_required,
profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
[ mkIntCLit words_required, CLbl ctr DataPtrRep ]
]
) `thenC`
setRealHp words_required
- where
- checking_code =
- let liveness = mkRegLiveness regs ptrs nptrs
- in
- CCheck HP_CHK_UNBX_TUPLE
- [mkIntCLit words_required,
- mkIntCLit (I# (word2Int# liveness))]
- fail_code
+ liveness = I# (word2Int# (mkRegLiveness regs ptrs nptrs))
+ checking_code words_required = CCheck HP_CHK_UNBX_TUPLE
+ [mkIntCLit words_required,
+ mkIntCLit liveness]
+ fail_code
-- build up a bitmap of the live pointer registers
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.20 2003/05/14 09:13:56 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.21 2003/07/02 13:12:37 simonpj Exp $
%
%********************************************************
%* *
import CgMonad
import AbsCSyn
-import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
- bindNewToStack, buildContLivenessMask, CgIdInfo,
- nukeDeadBindings
- )
+import CgBindery ( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings )
+import CgCase ( mkRetDirectTarget, restoreCurrentCostCentre )
+import CgCon ( bindUnboxedTupleComponents )
import CgHeapery ( unbxTupleHeapCheck )
-import CgRetConv ( assignRegs )
-import CgStackery ( mkVirtStkOffsets,
- allocStackTop, deAllocStackTop, freeStackSlots )
-import CgUsages ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
+import CgStackery ( allocStackTop, deAllocStackTop )
+import CgUsages ( getSpRelOffset )
import CLabel ( mkReturnInfoLabel )
import ClosureInfo ( mkLFLetNoEscape )
import CostCentre ( CostCentreStack )
-import Name ( getName )
-import Id ( Id, idPrimRep, idName )
+import Id ( Id )
import Var ( idUnique )
-import PrimRep ( PrimRep(..), retPrimRepSize, isFollowableRep )
+import PrimRep ( PrimRep(..), retPrimRepSize )
import BasicTypes ( RecFlag(..) )
-import Unique ( Unique )
-import Util ( splitAtList )
-
-import List ( partition )
\end{code}
%************************************************************************
-- ToDo: deal with the cost-centre issues
cgLetNoEscapeClosure
- binder cc binder_info srt full_live_in_rhss
+ bndr cc binder_info srt full_live_in_rhss
rhs_eob_info cc_slot rec args body
= let
arity = length args
lf_info = mkLFLetNoEscape arity
- uniq = idUnique binder
in
-- saveVolatileVarsAndRegs done earlier in cgExpr.
nukeDeadBindings full_live_in_rhss)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
- buildContLivenessMask (getName binder) `thenFC` \ liveness ->
- forkAbsC (cgLetNoEscapeBody binder cc args body uniq)
- `thenFC` \ code ->
- getSRTInfo (idName binder) srt `thenFC` \ srt_info ->
- absC (CRetDirect uniq code srt_info liveness)
- `thenC` returnFC ())
- `thenFC` \ (vSp, _) ->
-
- returnFC (binder, letNoEscapeIdInfo binder vSp lf_info)
+ forkAbsC (
+-- TEMP omit for line-by-line compatibility
+-- restoreCurrentCostCentre cc_slot `thenC`
+ cgLetNoEscapeBody bndr cc args body
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt
+ -- Ignore the label that comes back from
+ -- mkRetDirectTarget. It must be conjured up elswhere
+ ) `thenFC` \ (vSp, _) ->
+
+ returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info)
\end{code}
\begin{code}
-cgLetNoEscapeBody :: Id
+cgLetNoEscapeBody :: Id -- Name of the joint point
-> CostCentreStack
-> [Id] -- Args
-> StgExpr -- Body
- -> Unique -- Unique for entry label
-> Code
-cgLetNoEscapeBody binder cc all_args body uniq
- =
- -- this is where the stack frame lives:
- getRealSp `thenFC` \sp ->
-
- -- This is very much like bindUnboxedTupleComponents (ToDo)
- let
- arg_kinds = map idPrimRep all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
- (reg_args, stk_args) = splitAtList arg_regs all_args
-
- -- separate the rest of the args into pointers and non-pointers
- ( ptr_args, nptr_args ) =
- partition (isFollowableRep . idPrimRep) stk_args
-
- (ptr_sp, ptr_offsets) = mkVirtStkOffsets sp idPrimRep ptr_args
- (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
-
- ptrs = ptr_sp - sp
- nptrs = nptr_sp - ptr_sp
- in
-
- -- Bind args to appropriate regs/stk locns
- bindArgsToRegs reg_args arg_regs `thenC`
- mapCs bindNewToStack ptr_offsets `thenC`
- mapCs bindNewToStack nptr_offsets `thenC`
-
- setRealAndVirtualSp nptr_sp `thenC`
-
- -- free up the stack slots containing the return address
- -- (frame header itbl). c.f. CgCase.cgUnboxedTupleAlt.
- freeStackSlots [sp] `thenC`
+cgLetNoEscapeBody bndr cc all_args body
+ = bindUnboxedTupleComponents all_args `thenFC` \ (arg_regs, ptrs, nptrs, ret_slot) ->
-- Enter the closures cc, if required
--enterCostCentreCode closure_info cc IsFunction `thenC`
- -- fill in the frame header only if we fail a heap check:
- -- otherwise it isn't needed.
- getSpRelOffset sp `thenFC` \sp_rel ->
- let lbl = mkReturnInfoLabel uniq
+ -- The "return address" slot doesn't have a return address in it;
+ -- but the heap-check needs it filled in if the heap-check fails.
+ -- So we pass code to fill it in to the heap-check macro
+ getSpRelOffset ret_slot `thenFC` \ sp_rel ->
+ let lbl = mkReturnInfoLabel (idUnique bndr)
frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
in
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $
%
\section[CgMonad]{The code generation monad}
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
([(ConTag, JoinDetails)], -- Alternatives
- Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
- -- Maybe[3] the default is a
- -- bind-default (Just b); that is,
+ Maybe (Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
+ -- The default branch expects a
-- it expects a ptr to the thing
-- in Node, bound to b
)
- the virtual Hp is moved on to the worst virtual Hp for the branches
\begin{code}
-forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-
-forkAlts branch_fcodes (FCode deflt_fcode) =
- do
- info_down <- getInfoDown
- in_state <- getState
- let compile (FCode fc) = fc info_down in_state
- let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
- let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
- setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
- -- NB foldl. in_state is the *left* argument to stateIncUsage
- return (branch_results, deflt_result)
-
+forkAlts :: [FCode a] -> FCode [a]
+
+forkAlts branch_fcodes
+ = do info_down <- getInfoDown
+ in_state <- getState
+ let compile (FCode fc) = fc info_down in_state
+ let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
+ setState $ foldl stateIncUsage in_state branch_out_states
+ -- NB foldl. in_state is the *left* argument to stateIncUsage
+ return branch_results
\end{code}
@forkEval@ takes two blocks of code.
do_expr expr `thenMM` \ expr' ->
returnMM (StgSCC cc expr')
- do_expr (StgCase expr fv1 fv2 bndr srt alts)
+ do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts)
= do_expr expr `thenMM` \ expr' ->
- do_alts alts `thenMM` \ alts' ->
- returnMM (StgCase expr' fv1 fv2 bndr srt alts')
+ mapMM do_alt alts `thenMM` \ alts' ->
+ returnMM (StgCase expr' fv1 fv2 bndr srt alt_type alts')
where
- do_alts (StgAlgAlts tycon alts def)
- = mapMM do_alt alts `thenMM` \ alts' ->
- do_deflt def `thenMM` \ def' ->
- returnMM (StgAlgAlts tycon alts' def')
- where
- do_alt (id, bs, use_mask, e)
- = do_expr e `thenMM` \ e' ->
- returnMM (id, bs, use_mask, e')
-
- do_alts (StgPrimAlts tycon alts def)
- = mapMM do_alt alts `thenMM` \ alts' ->
- do_deflt def `thenMM` \ def' ->
- returnMM (StgPrimAlts tycon alts' def')
- where
- do_alt (l,e)
- = do_expr e `thenMM` \ e' ->
- returnMM (l,e')
-
- do_deflt StgNoDefault = returnMM StgNoDefault
- do_deflt (StgBindDefault e)
- = do_expr e `thenMM` \ e' ->
- returnMM (StgBindDefault e')
+ do_alt (id, bs, use_mask, e)
+ = do_expr e `thenMM` \ e' ->
+ returnMM (id, bs, use_mask, e')
do_expr (StgLet b e)
= do_let b e `thenMM` \ (b,e) ->
srtRhs :: IdEnv Int -> StgRhs -> StgRhs
srtRhs table e@(StgRhsCon cc con args) = e
-srtRhs table (StgRhsClosure cc bi free_vars u (SRTEntries cafs) args body)
- = StgRhsClosure cc bi free_vars u (constructSRT table cafs) args
+srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
+ = StgRhsClosure cc bi free_vars u (constructSRT table srt) args
$! (srtExpr table body)
-- ---------------------------------------------------------------------------
srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
-srtExpr table (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
- = let
- expr' = srtExpr table scrut
- srt_info = constructSRT table cafs_in_alts
- alts' = srtCaseAlts table alts
- in
- StgCase expr' live1 live2 uniq srt_info alts'
+srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
+ = StgCase expr' live1 live2 uniq srt' alt_type alts'
+ where
+ expr' = srtExpr table scrut
+ srt' = constructSRT table srt
+ alts' = map (srtAlt table) alts
srtExpr table (StgLet bind body)
= srtBind table bind =: \ bind' ->
srtExpr table expr = pprPanic "srtExpr" (ppr expr)
#endif
-
--- Case Alternatives
-
-srtCaseAlts :: IdEnv Int -> StgCaseAlts -> StgCaseAlts
-
-srtCaseAlts table (StgAlgAlts t alts dflt)
- = (StgAlgAlts t $! map (srtAlgAlt table) alts) $! srtDefault table dflt
-
-srtCaseAlts table (StgPrimAlts t alts dflt)
- = (StgPrimAlts t $! map (srtPrimAlt table) alts) $! srtDefault table dflt
-
-srtAlgAlt table (con,args,used,rhs)
+srtAlt :: IdEnv Int -> StgAlt -> StgAlt
+srtAlt table (con,args,used,rhs)
= (,,,) con args used $! srtExpr table rhs
-srtPrimAlt table (lit,rhs)
- = (,) lit $! srtExpr table rhs
-
-srtDefault table StgNoDefault = StgNoDefault
-srtDefault table (StgBindDefault rhs)
- = StgBindDefault $! srtExpr table rhs
-
-----------------------------------------------------------------------------
-- Construct an SRT bitmap.
-constructSRT :: IdEnv Int -> IdSet -> SRT
-constructSRT table entries
+constructSRT :: IdEnv Int -> SRT -> SRT
+constructSRT table (SRTEntries entries)
| isEmptyVarSet entries = NoSRT
| otherwise = SRT offset len bitmap
where
| ConstructorApps
| PrimitiveApps
| LetNoEscapes
- | AlgCases
- | PrimCases
+ | StgCases
| FreeVariables
| ConstructorBinds Bool{-True<=>top-level-}
| ReEntrantBinds Bool{-ditto-}
s ConstructorApps = "ConstructorApps "
s PrimitiveApps = "PrimitiveApps "
s LetNoEscapes = "LetNoEscapes "
- s AlgCases = "AlgCases "
- s PrimCases = "PrimCases "
+ s StgCases = "StgCases "
s FreeVariables = "FreeVariables "
s (ConstructorBinds True) = "ConstructorBinds_Top "
s (ReEntrantBinds True) = "ReEntrantBinds_Top "
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
-statExpr (StgCase expr lve lva bndr srt alts)
+statExpr (StgCase expr lve lva bndr srt alt_type alts)
= statExpr expr `combineSE`
+ stat_alts alts `combineSE`
+ countOne StgCases
+ where
stat_alts alts
- where
- stat_alts (StgAlgAlts ty alts def)
= combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
- `combineSE`
- stat_deflt def `combineSE`
- countOne AlgCases
-
- stat_alts (StgPrimAlts ty alts def)
- = combineSEs (map statExpr [ e | (_,e) <- alts ])
- `combineSE`
- stat_deflt def `combineSE`
- countOne PrimCases
-
- stat_deflt StgNoDefault = emptySE
-
- stat_deflt (StgBindDefault expr) = statExpr expr
\end{code}
import Literal
import Id
import Var ( Var, globalIdDetails, varType )
+import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
#ifdef ILX
import MkId ( unsafeCoerceId )
#endif
coreToStgExpr (Case scrut bndr alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
- returnLne ( mkStgAlts (idType bndr) alts2,
+ returnLne ( alts2,
unionFVInfos fvs_s,
unionVarSets escs_s )
) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
+ (mkStgAltType (idType bndr))
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
\end{code}
\begin{code}
-mkStgAlts scrut_ty orig_alts
- | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
- | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
- where
- is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
- prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
- alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
-
- (other_alts, deflt)
- = case orig_alts of -- DEFAULT is always first if it's there at all
- (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
- other -> (orig_alts, StgNoDefault)
-
- maybe_tycon = case alg_alts of
- -- Get the tycon from the data con
- (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
-
- -- Otherwise just do your best
- [] -> case splitTyConApp_maybe (repType scrut_ty) of
- Just (tc,_) | isAlgTyCon tc -> Just tc
- _other -> Nothing
+mkStgAltType scrut_ty
+ = case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+ | isPrimTyCon tc -> PrimAlt tc
+ | isAlgTyCon tc -> AlgAlt tc
+ | isFunTyCon tc -> PolyAlt
+ | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ Nothing -> PolyAlt
\end{code}
import Id ( Id, idType, isLocalId )
import VarSet
import DataCon ( DataCon, dataConArgTys, dataConRepType )
+import CoreSyn ( AltCon(..) )
import PrimOp ( primOpType )
-import Literal ( literalType, Literal )
+import Literal ( literalType )
import Maybes ( catMaybes )
import Name ( getSrcLoc )
import ErrUtils ( Message, addErrLocHdrLine )
lintStgExpr (StgSCC _ expr) = lintStgExpr expr
-lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
+lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts)
= lintStgExpr scrut `thenMaybeL` \ _ ->
- (case alts of
- StgPrimAlts tc _ _ -> check_bndr tc
- StgAlgAlts (Just tc) _ _ -> check_bndr tc
- StgAlgAlts Nothing _ _ -> returnL ()
+ (case alts_type of
+ AlgAlt tc -> check_bndr tc
+ PrimAlt tc -> check_bndr tc
+ UbxTupAlt tc -> check_bndr tc
+ PolyAlt -> returnL ()
) `thenL_`
(trace (showSDoc (ppr e)) $
check_bndr tc = case splitTyConApp_maybe scrut_ty of
Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
-\end{code}
-\begin{code}
-lintStgAlts :: StgCaseAlts
- -> Type -- Type of scrutinee
- -> LintM (Maybe Type) -- Type of alternatives
+
+lintStgAlts :: [StgAlt]
+ -> Type -- Type of scrutinee
+ -> LintM (Maybe Type) -- Type of alternatives
lintStgAlts alts scrut_ty
- = (case alts of
- StgAlgAlts _ alg_alts deflt ->
- mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
- lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
-
- StgPrimAlts _ prim_alts deflt ->
- mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
- lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
- ) `thenL` \ maybe_result_tys ->
+ = mapL (lintAlt scrut_ty) alts `thenL` \ maybe_result_tys ->
+
-- Check the result types
case catMaybes (maybe_result_tys) of
[] -> returnL Nothing
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-lintAlgAlt scrut_ty (con, args, _, rhs)
+lintAlt scrut_ty (DEFAULT, _, _, rhs)
+ = lintStgExpr rhs
+
+lintAlt scrut_ty (LitAlt lit, _, _, rhs)
+ = checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty) `thenL_`
+ lintStgExpr rhs
+
+lintAlt scrut_ty (DataAlt con, args, _, rhs)
= (case splitTyConApp_maybe scrut_ty of
Just (tycon, tys_applied) | isAlgTyCon tycon &&
not (isNewTyCon tycon) ->
mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_`
returnL ()
other ->
- addErrL (mkAlgAltMsg1 scrut_ty)
+ addErrL (mkAltMsg1 scrut_ty)
) `thenL_`
addInScopeVars args (
lintStgExpr rhs
-- We give it its own copy, so it isn't overloaded.
elem _ [] = False
elem x (y:ys) = x==y || elem x ys
-
-lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
- lintStgExpr rhs
-
-lintDeflt StgNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
\end{code}
\end{code}
\begin{code}
-mkCaseAltMsg :: StgCaseAlts -> Message
+mkCaseAltMsg :: [StgAlt] -> Message
mkCaseAltMsg alts
= ($$) (text "In some case alternatives, type of alternatives not all same:")
(empty) -- LATER: ppr alts
(<>) (ptext SLIT("Var: ")) (ppr var),
(<>) (ptext SLIT("Its type: ")) (ppr ty)]
-mkAlgAltMsg1 :: Type -> Message
-mkAlgAltMsg1 ty
- = ($$) (text "In some case statement, type of scrutinee is not a data type:")
- (ppr ty)
+mkAltMsg1 :: Type -> Message
+mkAltMsg1 ty
+ = ($$) (text "In a case expression, type of scrutinee does not match patterns")
+ (ppr ty)
mkAlgAltMsg2 :: Type -> DataCon -> Message
mkAlgAltMsg2 ty con
ppr arg
]
-mkPrimAltMsg :: (Literal, StgExpr) -> Message
-mkPrimAltMsg alt
- = text "In a primitive case alternative, type of literal doesn't match type of scrutinee:"
- $$ ppr alt
-
mkCaseOfCaseMsg :: StgExpr -> Message
mkCaseOfCaseMsg e
= text "Case of non-tail-call:" $$ ppr e
GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
- GenStgCaseAlts(..), GenStgCaseDefault(..),
+ GenStgAlt, AltType(..),
UpdateFlag(..), isUpdatable,
-- a set of synonyms for the most common (only :-) parameterisation
StgArg, StgLiveVars,
- StgBinding, StgExpr, StgRhs,
- StgCaseAlts, StgCaseDefault,
+ StgBinding, StgExpr, StgRhs, StgAlt,
-- StgOp
StgOp(..),
isLitLitArg, isDllConApp, isStgTypeArg,
stgArgType, stgBinders,
- pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs
#ifdef DEBUG
, pprStgLVs
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
+import CoreSyn ( AltCon )
import PrimOp ( PrimOp )
import Outputable
import Util ( count )
SRT -- The SRT for the continuation
- (GenStgCaseAlts bndr occ)
+ AltType
+
+ [GenStgAlt bndr occ] -- The DEFAULT case is always *first*
+ -- if it is there at all
\end{code}
%************************************************************************
%* *
%************************************************************************
-Just like in @CoreSyntax@ (except no type-world stuff).
-
-* Algebraic cases are done using
- StgAlgAlts (Just tc) alts deflt
-
-* Polymorphic cases, or case of a function type, are done using
- StgAlgAlts Nothing [] (StgBindDefault e)
+Very like in @CoreSyntax@ (except no type-world stuff).
-* Primitive cases are done using
- StgPrimAlts tc alts deflt
-
-We thought of giving polymorphic cases their own constructor,
-but we get a bit more code sharing this way
-
-The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
-to be abstract; that is, we can see its representation. This is
-important because the code generator uses it to determine return
-conventions etc. But it's not trivial where there's a moduule loop
-involved, because some versions of a type constructor might not have
-all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures
-that it gets the TyCon from the constructors or literals (which are
-guaranteed to have the Real McCoy) rather than from the scrutinee type.
+The type constructor is guaranteed not to be abstract; that is, we can
+see its representation. This is important because the code generator
+uses it to determine return conventions etc. But it's not trivial
+where there's a moduule loop involved, because some versions of a type
+constructor might not have all the constructors visible. So
+mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
+constructors or literals (which are guaranteed to have the Real McCoy)
+rather than from the scrutinee type.
\begin{code}
-data GenStgCaseAlts bndr occ
- = StgAlgAlts (Maybe TyCon) -- Just tc => scrutinee type is
- -- an algebraic data type
- -- Nothing => scrutinee type is a type
- -- variable or function type
- [(DataCon, -- alts: data constructor,
- [bndr], -- constructor's parameters,
- [Bool], -- "use mask", same length as
- -- parameters; a True in a
- -- param's position if it is
- -- used in the ...
- GenStgExpr bndr occ)] -- ...right-hand side.
- (GenStgCaseDefault bndr occ)
-
- | StgPrimAlts TyCon
- [(Literal, -- alts: unboxed literal,
- GenStgExpr bndr occ)] -- rhs.
- (GenStgCaseDefault bndr occ)
-
-data GenStgCaseDefault bndr occ
- = StgNoDefault -- small con family: all
- -- constructor accounted for
- | StgBindDefault (GenStgExpr bndr occ)
+type GenStgAlt bndr occ
+ = (AltCon, -- alts: data constructor,
+ [bndr], -- constructor's parameters,
+ [Bool], -- "use mask", same length as
+ -- parameters; a True in a
+ -- param's position if it is
+ -- used in the ...
+ GenStgExpr bndr occ) -- ...right-hand side.
+
+data AltType
+ = PolyAlt -- Polymorphic (a type variable)
+ | UbxTupAlt TyCon -- Unboxed tuple
+ | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts
+ | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts
\end{code}
%************************************************************************
type StgLiveVars = GenStgLiveVars Id
type StgExpr = GenStgExpr Id Id
type StgRhs = GenStgRhs Id Id
-type StgCaseAlts = GenStgCaseAlts Id Id
-type StgCaseDefault = GenStgCaseDefault Id Id
+type StgAlt = GenStgAlt Id Id
\end{code}
%************************************************************************
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
char ']']))))
2 (ppr expr)]
-\end{code}
-\begin{code}
pprStgExpr (StgSCC cc expr)
= sep [ hsep [ptext SLIT("_scc_"), ppr cc],
pprStgExpr expr ]
-\end{code}
-\begin{code}
-pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
- ifPprDebug (dcolon <+> pp_ty alts)]),
+ ifPprDebug (dcolon <+> ppr alt_type)]),
ptext SLIT("of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
ptext SLIT("]; "),
pprMaybeSRT srt])),
- nest 2 (pprStgAlts alts),
+ nest 2 (vcat (map pprStgAlt alts)),
char '}']
- where
- pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon
- pp_ty (StgPrimAlts tycon _ _) = ppr tycon
-
-pprStgAlts (StgAlgAlts _ alts deflt)
- = vcat [ vcat (map (ppr_bxd_alt) alts),
- pprStgDefault deflt ]
- where
- ppr_bxd_alt (con, params, use_mask, expr)
- = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
- 4 ((<>) (ppr expr) semi)
-
-pprStgAlts (StgPrimAlts _ alts deflt)
- = vcat [ vcat (map (ppr_ubxd_alt) alts),
- pprStgDefault deflt ]
- where
- ppr_ubxd_alt (lit, expr)
- = hang (hsep [ppr lit, ptext SLIT("->")])
- 4 ((<>) (ppr expr) semi)
-
-pprStgDefault StgNoDefault = empty
-pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
- 4 (ppr expr)
+
+pprStgAlt (con, params, use_mask, expr)
+ = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
+ 4 (ppr expr <> semi)
pprStgOp (StgPrimOp op) = ppr op
pprStgOp (StgFCallOp op _) = ppr op
+
+instance Outputable AltType where
+ ppr PolyAlt = ptext SLIT("Polymorphic")
+ ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc
+ ppr (AlgAlt tc) = ptext SLIT("Alg") <+> ppr tc
+ ppr (PrimAlt tc) = ptext SLIT("Prim") <+> ppr tc
\end{code}
\begin{code}
projects / ghc-hetmet.git / commitdiff