From: simonpj Date: Wed, 2 Jul 2003 13:12:39 +0000 (+0000) Subject: [project @ 2003-07-02 13:12:33 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~714 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3f5e4368fd4e87e116ce34be4cf9dd0f9f96726d [project @ 2003-07-02 13:12:33 by simonpj] ------------------------ Tidy up the code generator ------------------------ The code generation for 'case' expressions had grown huge and gnarly. This commit removes about 120 lines of code, and makes it a lot easier to read too. I think the code generated is identical. Part of this was to simplify the StgCase data type, so that it is more like the Core case: there is a simple list of alternatives, and the DEFAULT (if present) must be the first. This tidies and simplifies other Stg passes. --- diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 2b8a0e4..cff7ace 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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} @@ -14,27 +14,7 @@ From @AbstractC@, one may convert to real C (for portability) or to 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" diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index ac75ca1..893f88a 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -22,7 +22,7 @@ module AbsCUtils ( 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(..) ) @@ -34,14 +34,13 @@ import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised ) 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} @@ -108,18 +107,14 @@ mkAbsCStmtList' other r = other : r \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 @@ -128,8 +123,8 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc -- 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} %************************************************************************ diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index f0ae177..300b5f4 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -28,7 +28,7 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC, import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, playThreadSafe, ccallConvAttribute, - ForeignCall(..), Safety(..), DNCallSpec(..), + ForeignCall(..), DNCallSpec(..), DNType(..), DNKind(..) ) import CLabel ( externallyVisibleCLabel, needsCDecl, pprCLabel, mkClosureLabel, @@ -1411,7 +1411,7 @@ pprMagicId SpLim = ptext SLIT("SpLim") 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) diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index c91bbee..15a50fd 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -8,7 +8,7 @@ module CgBindery ( CgBindings, CgIdInfo, StableLoc, VolatileLoc, - stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + stableAmodeIdInfo, heapIdInfo, letNoEscapeIdInfo, idInfoToAmode, addBindC, addBindsC, @@ -18,7 +18,7 @@ module CgBindery ( bindNewToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, bindNewPrimToAmode, + bindNewToTemp, getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, @@ -44,9 +44,9 @@ import VarEnv 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 ) @@ -109,6 +109,25 @@ maybeStkLoc (VirStkLoc offset) = Just offset 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} @@ -123,15 +142,6 @@ tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc l 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 @@ -373,14 +383,15 @@ bindNewToNode name offset lf_info -- 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 @@ -395,24 +406,6 @@ bindArgsToRegs args regs 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 @@ -458,15 +451,16 @@ buildLivenessMask size sp = do { ]; }; - 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 @@ -477,7 +471,7 @@ buildContLivenessMask name = do 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} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 8c67334..0e6deff 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -10,7 +10,8 @@ %******************************************************** \begin{code} -module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre +module CgCase ( cgCase, saveVolatileVarsAndRegs, + mkRetDirectTarget, restoreCurrentCostCentre ) where #include "HsVersions.h" @@ -21,12 +22,10 @@ import CgMonad 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, ) @@ -45,18 +44,17 @@ import CLabel ( mkVecTblLabel, mkClosureTblLabel, ) 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} @@ -113,118 +111,112 @@ cgCase :: StgExpr -> 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 @@ -232,39 +224,13 @@ maybe better to translate it out beforehand). See 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 -> @@ -282,10 +248,10 @@ cgCase (StgApp fun args) ( 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} @@ -303,7 +269,7 @@ deAllocStackTop call is doing above. 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` @@ -320,9 +286,9 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alts `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} @@ -361,10 +327,8 @@ don't follow the layout of closures when we're profiling. The CCS 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} @@ -382,24 +346,50 @@ is some evaluation to be done. 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. @@ -410,67 +400,25 @@ cgEvalAlts cc_slot bndr srt alts -- -- 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 - 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} @@ -496,120 +444,43 @@ are inlined alternatives. \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} %************************************************************************ @@ -622,34 +493,44 @@ Turgid-but-non-monadic code to conjure up the required info from 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} %************************************************************************ @@ -658,7 +539,7 @@ cgSemiTaggedAlts binder alts deflt %* * %************************************************************************ -@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. @@ -666,53 +547,30 @@ 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} @@ -723,13 +581,23 @@ cgPrimDefault gc_flag regs (StgBindDefault rhs) %************************************************************************ \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) -> @@ -739,7 +607,7 @@ saveVolatileVarsAndRegs vars 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 @@ -789,12 +657,12 @@ saveCurrentCostCentre 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. @@ -810,113 +678,88 @@ Build a return vector, and return a suitable label addressing 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} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 9b654b9..57bfffe 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -45,7 +45,7 @@ import DataCon ( DataCon, dataConTag, 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 ) @@ -229,44 +229,51 @@ returned in registers and on the stack instead of the heap. \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} %************************************************************************ @@ -287,7 +294,7 @@ cgReturnDataCon con amodes 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 @@ -301,9 +308,9 @@ cgReturnDataCon con amodes -- 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)) diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 14e2758..3f900d1 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -22,10 +22,10 @@ import AbsCUtils ( mkAbstractCs, getAmodeRep ) 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 ) @@ -138,6 +138,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) (\ 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 @@ -199,8 +200,8 @@ Case-expression conversion is complicated enough to have its own 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} @@ -232,7 +233,10 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) 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! @@ -316,10 +320,9 @@ mkRhsClosure bndr cc bi srt [] -- 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 @@ -397,7 +400,7 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body 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 diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 8a224f4..d68c1e4 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (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} @@ -17,23 +17,24 @@ module CgHeapery ( #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 @@ -160,72 +161,57 @@ the heap check code. \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 @@ -247,21 +233,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code 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 diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index a7521a3..2876eb0 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (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 $ % %******************************************************** %* * @@ -20,27 +20,19 @@ import StgSyn 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} %************************************************************************ @@ -158,12 +150,11 @@ cgLetNoEscapeClosure -- 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. @@ -175,65 +166,37 @@ cgLetNoEscapeClosure 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 diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 99c776e..88083f7 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (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} @@ -151,9 +151,8 @@ data Sequel 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 ) @@ -446,19 +445,16 @@ that - 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. diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index aca4961..508f812 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -173,33 +173,14 @@ stgMassageForProfiling mod_name us stg_binds 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) -> diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index 89ef8e4..34e61ce 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -100,8 +100,8 @@ srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ] 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) -- --------------------------------------------------------------------------- @@ -116,13 +116,12 @@ srtExpr table e@(StgOpApp op args ty) = e 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' -> @@ -138,32 +137,15 @@ srtExpr table (StgLetNoEscape live1 live2 bind body) 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 diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index 0e5a75b..a918739 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -38,8 +38,7 @@ data CounterType | ConstructorApps | PrimitiveApps | LetNoEscapes - | AlgCases - | PrimCases + | StgCases | FreeVariables | ConstructorBinds Bool{-True<=>top-level-} | ReEntrantBinds Bool{-ditto-} @@ -88,8 +87,7 @@ showStgStats prog 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 " @@ -163,24 +161,12 @@ statExpr (StgLet binds body) = 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} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 15e9fc3..358d29f 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,6 +20,7 @@ import TyCon ( isAlgTyCon ) import Literal import Id import Var ( Var, globalIdDetails, varType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) #endif @@ -333,7 +334,7 @@ coreToStgExpr (Note other_note expr) 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) -> @@ -367,6 +368,7 @@ coreToStgExpr (Case scrut bndr alts) (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 @@ -406,28 +408,14 @@ coreToStgExpr (Let bind body) \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} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 28b02a9..f634185 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -14,8 +14,9 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) 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 ) @@ -200,13 +201,14 @@ lintStgExpr (StgLetNoEscape _ _ binds body) 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)) $ @@ -224,25 +226,15 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts) 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 @@ -252,7 +244,14 @@ lintStgAlts alts scrut_ty 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) -> @@ -267,7 +266,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs) mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_` returnL () other -> - addErrL (mkAlgAltMsg1 scrut_ty) + addErrL (mkAltMsg1 scrut_ty) ) `thenL_` addInScopeVars args ( lintStgExpr rhs @@ -280,13 +279,6 @@ lintAlgAlt scrut_ty (con, args, _, 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} @@ -464,7 +456,7 @@ checkTys ty1 ty2 msg loc scope errs \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 @@ -498,10 +490,10 @@ mkUnappTyMsg var ty (<>) (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 @@ -527,11 +519,6 @@ mkAlgAltMsg4 ty arg 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 diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 31e2057..b9f3671 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -14,7 +14,7 @@ module StgSyn ( GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgCaseAlts(..), GenStgCaseDefault(..), + GenStgAlt, AltType(..), UpdateFlag(..), isUpdatable, @@ -24,8 +24,7 @@ module StgSyn ( -- a set of synonyms for the most common (only :-) parameterisation StgArg, StgLiveVars, - StgBinding, StgExpr, StgRhs, - StgCaseAlts, StgCaseDefault, + StgBinding, StgExpr, StgRhs, StgAlt, -- StgOp StgOp(..), @@ -38,7 +37,7 @@ module StgSyn ( isLitLitArg, isDllConApp, isStgTypeArg, stgArgType, stgBinders, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs #ifdef DEBUG , pprStgLVs @@ -56,6 +55,7 @@ import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) +import CoreSyn ( AltCon ) import PrimOp ( PrimOp ) import Outputable import Util ( count ) @@ -227,7 +227,10 @@ This has the same boxed/unboxed business as Core case expressions. 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} %************************************************************************ @@ -456,53 +459,32 @@ pp_binder_info SatCallsOnly = ptext SLIT("sat-only") %* * %************************************************************************ -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} %************************************************************************ @@ -519,8 +501,7 @@ type StgArg = GenStgArg Id 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} %************************************************************************ @@ -740,19 +721,15 @@ pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) 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 ( @@ -760,34 +737,21 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts) 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}