X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=d31383907217f5ab9ad8415fc4d6c0b445570703;hb=46d88d870471379348f5661a56dad6ce4d7f5588;hp=b1c0b36a67bf182df3b4370264b463571a4f3896;hpb=700d80075ccb6d93d4869154ddb5f3ea4dd34734;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b1c0b36..d313839 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.21 1998/12/22 18:03:27 simonm Exp $ +% $Id: CgCase.lhs,v 1.67 2004/08/09 13:19:29 simonmar Exp $ % %******************************************************** %* * @@ -10,8 +10,9 @@ %******************************************************** \begin{code} -module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre, - splitTyConAppThroughNewTypes ) where +module CgCase ( cgCase, saveVolatileVarsAndRegs, + mkRetDirectTarget, restoreCurrentCostCentre + ) where #include "HsVersions.h" @@ -21,50 +22,40 @@ import CgMonad import StgSyn import AbsCSyn -import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, - getAmodeRep, nonemptyAbsC - ) -import CoreSyn ( isDeadBinder ) -import CgUpdate ( reserveSeqFrame ) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep ) import CgBindery ( getVolatileRegs, getArgAmodes, bindNewToReg, bindNewToTemp, - bindNewPrimToAmode, - rebindToStack, getCAddrMode, - getCAddrModeAndInfo, getCAddrModeIfVolatile, - buildContLivenessMask, nukeDeadBindings + getCAddrModeAndInfo, + rebindToStack, getCAddrMode, getCAddrModeIfVolatile, + buildContLivenessMask, nukeDeadBindings, ) import CgCon ( bindConArgs, bindUnboxedTupleComponents ) -import CgHeapery ( altHeapCheck, yield ) +import CgHeapery ( altHeapCheck, unbxTupleHeapCheck ) import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) import CgStackery ( allocPrimStack, allocStackTop, - deAllocStackTop, freeStackSlots + deAllocStackTop, freeStackSlots, dataStackSlots ) -import CgTailCall ( tailCallFun ) -import CgUsages ( getSpRelOffset, getRealSp ) -import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, - mkDefaultLabel, mkAltLabel, mkReturnInfoLabel, - mkErrorStdEntryLabel, mkClosureTblLabel +import CgTailCall ( performTailCall ) +import CgUsages ( getSpRelOffset ) +import CLabel ( mkVecTblLabel, mkClosureTblLabel, + mkDefaultLabel, mkAltLabel, mkReturnInfoLabel ) import ClosureInfo ( mkLFArgument ) -import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) -import CostCentre ( CostCentre ) -import Id ( Id, idPrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag, - isUnboxedTupleCon, dataConType ) +import CmdLineOpts ( opt_SccProfilingOn ) +import Id ( Id, idName, isDeadBinder ) +import DataCon ( dataConTag, fIRST_TAG, ConTag ) import VarSet ( varSetElems ) -import Const ( Con(..), Literal ) +import CoreSyn ( AltCon(..) ) import PrimOp ( primOpOutOfLine, PrimOp(..) ) import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) -import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, - isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon, - tyConDataCons, tyConFamilySize ) -import Type ( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe, - splitFunTys, applyTys ) -import Unique ( Unique, Uniquable(..) ) -import Maybes ( maybeToBool ) +import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep ) +import Unique ( Unique, Uniquable(..), newTagUnique ) +import ForeignCall +import Util ( only ) +import List ( sortBy ) import Outputable \end{code} @@ -115,52 +106,28 @@ Against: This never hurts us if there is only one alternative. - -*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need -to take account of what is live, and that includes all live volatile -variables, even if they also have stable analogues. Furthermore, the -stack pointers must be lined up properly so that GC sees tidy stacks. -If these things are done, then the heap checks can be done at \tr{!B!} and -\tr{!C!} without a full save-volatile-vars sequence. - \begin{code} cgCase :: StgExpr -> StgLiveVars -> StgLiveVars -> Id -> SRT - -> StgCaseAlts + -> AltType + -> [StgAlt] -> Code \end{code} -Several special cases for inline primitive operations. +Special case #1: case of literal. \begin{code} -cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts - | not (primOpOutOfLine op) - = - -- Get amodes for the arguments and results - getArgAmodes args `thenFC` \ arg_amodes -> - let - result_amodes = getPrimAppResultAmodes (getUnique bndr) alts - in - -- Perform the operation - getVolatileRegs live_in_alts `thenFC` \ vol_regs -> - - absC (COpStmt result_amodes op - arg_amodes -- note: no liveness arg - vol_regs) `thenC` - - -- Scrutinise the result - cgInlineAlts bndr alts +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} -TODO: Case-of-case of primop can probably be done inline too (but -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 +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 @@ -169,62 +136,133 @@ eliminate a heap check altogether. \begin{code} cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt - (StgPrimAlts ty 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. - -} - (if (isDeadBinder bndr) - then nopC - else bindNewToTemp bndr `thenFC` \deflt_amode -> - absC (CAssign deflt_amode amode)) `thenC` - - cgPrimAlts NoGC amode alts deflt [] + 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 tmp_amode alts alt_type +\end{code} + +Special case #3: inline PrimOps and foreign calls. + +\begin{code} +cgCase (StgOpApp op args _) + live_in_whole_case live_in_alts bndr srt alt_type alts + | inline_primop + = -- Get amodes for the arguments and results + getArgAmodes args `thenFC` \ arg_amodes -> + getVolatileRegs live_in_alts `thenFC` \ vol_regs -> + + 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 + where + [(_, res_ids, _, rhs)] = alts + + AlgAlt tycon -- ENUMERATION TYPE RETURN + | StgPrimOp primop <- op + -> ASSERT( isEnumerationTyCon tycon ) + let + 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) + in + 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) + + other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type) + where + inline_primop = case op of + StgPrimOp primop -> not (primOpOutOfLine primop) + StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True + -- unsafe foreign calls are "inline" + _otherwise -> False + \end{code} +TODO: Case-of-case of primop can probably be done inline too (but +maybe better to translate it out beforehand). See +ghc/lib/misc/PackedString.lhs for examples where this crops up (with +4.02). + 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@(StgAlgAlts ty _ _) - = - getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> + 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 -> - -- Squish the environment + -- Nuking dead bindings *before* calculating the saves is the + -- value-add here. We might end up freeing up some slots currently + -- occupied by variables only required for the call. + -- NOTE: we need to look up the variables used in the call before + -- doing this, because some of them may not be in the environment + -- afterward. nukeDeadBindings live_in_alts `thenC` saveVolatileVarsAndRegs live_in_alts `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> - allocStackTop retPrimRepSize `thenFC` \_ -> - - forkEval alts_eob_info nopC ( - deAllocStackTop retPrimRepSize `thenFC` \_ -> - cgEvalAlts maybe_cc_slot bndr srt alts) + forkEval alts_eob_info + ( allocStackTop retPrimRepSize + `thenFC` \_ -> nopC ) + ( deAllocStackTop retPrimRepSize `thenFC` \_ -> + cgEvalAlts maybe_cc_slot bndr srt alt_type alts ) `thenFC` \ scrut_eob_info -> - let real_scrut_eob_info = - if not_con_ty - then reserveSeqFrame scrut_eob_info - else scrut_eob_info - in - - setEndOfBlockInfo real_scrut_eob_info ( - tailCallFun fun fun_amode lf_info arg_amodes save_assts - ) - - where - not_con_ty = case (getScrutineeTyCon ty) of - Just _ -> False - other -> True + setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $ + performTailCall fun' fun_amode lf_info arg_amodes save_assts \end{code} Note about return addresses: we *always* push a return address, even @@ -241,7 +279,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` @@ -253,26 +291,15 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alts -- generate code for the alts forkEval alts_eob_info - ( - nukeDeadBindings live_in_alts `thenC` + (nukeDeadBindings live_in_alts `thenC` allocStackTop retPrimRepSize -- space for retn address `thenFC` \_ -> nopC ) (deAllocStackTop retPrimRepSize `thenFC` \_ -> - cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info -> - - let real_scrut_eob_info = - if not_con_ty - then reserveSeqFrame scrut_eob_info - else scrut_eob_info - in + cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info -> - setEndOfBlockInfo real_scrut_eob_info (cgExpr expr) - - where - not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of - Just _ -> False - other -> True + setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $ + cgExpr expr \end{code} There's a lot of machinery going on behind the scenes to manage the @@ -310,91 +337,13 @@ don't follow the layout of closures when we're profiling. The CCS could be anywhere within the record). \begin{code} -alts_ty (StgAlgAlts ty _ _) = ty -alts_ty (StgPrimAlts ty _ _) = ty +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} %************************************************************************ %* * -\subsection[CgCase-primops]{Primitive applications} -%* * -%************************************************************************ - -Get result amodes for a primitive operation, in the case wher GC can't happen. -The amodes are returned in canonical order, ready for the prim-op! - - Alg case: temporaries named as in the alternatives, - plus (CTemp u) for the tag (if needed) - Prim case: (CTemp u) - -This is all disgusting, because these amodes must be consistent with those -invented by CgAlgAlts. - -\begin{code} -getPrimAppResultAmodes - :: Unique - -> StgCaseAlts - -> [CAddrMode] -\end{code} - -\begin{code} --- If there's an StgBindDefault which does use the bound --- variable, then we can only handle it if the type involved is --- an enumeration type. That's important in the case --- of comparisions: --- --- case x ># y of --- r -> f r --- --- The only reason for the restriction to *enumeration* types is our --- inability to invent suitable temporaries to hold the results; --- Elaborating the CTemp addr mode to have a second uniq field --- (which would simply count from 1) would solve the problem. --- Anyway, cgInlineAlts is now capable of handling all cases; --- it's only this function which is being wimpish. - -getPrimAppResultAmodes uniq (StgAlgAlts ty alts - (StgBindDefault rhs)) - | isEnumerationTyCon spec_tycon = [tag_amode] - | otherwise = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs) - where - -- A temporary variable to hold the tag; this is unaffected by GC because - -- the heap-checks in the branches occur after the switch - tag_amode = CTemp uniq IntRep - (spec_tycon, _, _) = splitAlgTyConApp ty -\end{code} - -If we don't have a default case, we could be scrutinising an unboxed -tuple, or an enumeration type... - -\begin{code} -getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) - -- Default is either StgNoDefault or StgBindDefault with unused binder - - | isEnumerationTyCon tycon = [CTemp uniq IntRep] - - | isUnboxedTupleTyCon tycon = - case alts of - [(con, args, use_mask, rhs)] -> - [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ] - _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches" - - | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty)) - - where (tycon, _, _) = splitAlgTyConApp ty -\end{code} - -The situation is simpler for primitive results, because there is only -one! - -\begin{code} -getPrimAppResultAmodes uniq (StgPrimAlts ty _ _) - = [CTemp uniq (typePrimRep ty)] -\end{code} - - -%************************************************************************ -%* * \subsection[CgCase-alts]{Alternatives} %* * %************************************************************************ @@ -407,31 +356,52 @@ 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 in - - -- Generate the instruction to restore cost centre, if any - restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> - - -- get the stack liveness for the info table (after the CC slot has - -- been freed - this is important). - buildContLivenessMask uniq `thenFC` \ liveness_mask -> - - case alts of +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 + bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) -> + -- restore the CC *after* binding the tuple components, so that we + -- get the stack offset of the saved CC right. + restoreCurrentCostCentre cc_slot True `thenC` + -- 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 True `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 - -- algebraic alts ... - (StgAlgAlts ty alts deflt) -> - - -- bind the default binder (it covers all the alternatives) - (if (isDeadBinder bndr) - then nopC - else bindNewToReg bndr node mkLFArgument) `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. @@ -442,130 +412,33 @@ cgEvalAlts cc_slot bndr srt alts -- -- which is worse than having the alt code in the switch statement - let tycon_info = getScrutineeTyCon ty - is_alg = maybeToBool tycon_info - Just spec_tycon = tycon_info - in - - -- deal with the unboxed tuple case - if is_alg && isUnboxedTupleTyCon spec_tycon then - case alts of - [alt] -> let lbl = mkReturnInfoLabel uniq in - cgUnboxedTupleAlt lbl cc_restore True alt - `thenFC` \ abs_c -> - getSRTLabel `thenFC` \srt_label -> - absC (CRetDirect uniq abs_c (srt_label, srt) - liveness_mask) `thenC` - returnFC (CaseAlts (CLbl lbl RetRep) Nothing) - _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type" - - -- 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 uniq cc_restore use_labelled_alts (not is_alg) - alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) -> - - mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask - ret_conv `thenFC` \ return_vec -> - - returnFC (CaseAlts return_vec semi_tagged_stuff) - - -- primitive alts... - (StgPrimAlts ty alts deflt) -> - - -- Generate the switch - getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c -> - - -- Generate the labelled block, starting with restore-cost-centre - getSRTLabel `thenFC` \srt_label -> - absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) - (srt_label,srt) liveness_mask) `thenC` - - -- Return an amode for the block - returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing) -\end{code} - - -\begin{code} -cgInlineAlts :: Id - -> StgCaseAlts - -> Code -\end{code} - -HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If -we do an inlining of the case no separate functions for returning are -created, so we don't have to generate a GRAN_YIELD in that case. This info -must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be -emitted). Hence, the new Bool arg to cgAlgAltRhs. + let ret_conv = case alt_type of + AlgAlt tc -> ctrlReturnConvAlg tc + PolyAlt -> UnvectoredReturn 0 -First case: primitive op returns an unboxed tuple. + use_labelled_alts = case ret_conv of + VectoredReturn _ -> True + _ -> False -\begin{code} -cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault) - | isUnboxedTupleCon con - = -- no heap check, no yield, just get in there and do it. - mapFCs bindNewToTemp args `thenFC` \ _ -> - cgExpr rhs - - | otherwise - = panic "cgInlineAlts: single alternative, not an unboxed tuple" -\end{code} - -Hack: to deal with - - case <# x y of z { - DEFAULT -> ... - } + semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts -\begin{code} -cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs)) - = bindNewToTemp bndr `thenFC` \amode -> - let - (tycon, _, _) = splitAlgTyConApp ty - closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep in - absC (CAssign amode closure_lbl) `thenC` - cgExpr rhs -\end{code} + cgAlgAlts GCMayHappen (getUnique bndr) + cc_slot use_labelled_alts + alt_type alts `thenFC` \ tagged_alt_absCs -> -Second case: algebraic case, several alternatives. -Tag is held in a temporary. + mkRetVecTarget bndr tagged_alt_absCs + srt ret_conv `thenFC` \ return_vec -> -\begin{code} -cgInlineAlts bndr (StgAlgAlts ty alts deflt) - = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-} - False{-not poly case-} alts deflt - False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) -> - - -- Do the switch - absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c) - where - -- A temporary variable to hold the tag; this is unaffected by GC because - -- the heap-checks in the branches occur after the switch - tag_amode = CTemp uniq IntRep - uniq = getUnique bndr + returnFC (CaseAlts return_vec semi_tagged_stuff False) \end{code} -Third (real) case: primitive result type. - -\begin{code} -cgInlineAlts bndr (StgPrimAlts ty alts deflt) - = cgPrimInlineAlts bndr ty alts deflt -\end{code} +HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If +we do an inlining of the case no separate functions for returning are +created, so we don't have to generate a GRAN_YIELD in that case. This info +must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be +emitted). Hence, the new Bool arg to cgAlgAltRhs. %************************************************************************ %* * @@ -583,121 +456,43 @@ are inlined alternatives. \begin{code} cgAlgAlts :: GCFlag - -> Unique - -> AbstractC -- Restore-cost-centre instruction - -> Bool -- True <=> branches must be labelled - -> Bool -- True <=> polymorphic case - -> [(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 uniq restore_cc must_label_branches is_fun 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_fun uniq restore_cc must_label_branches deflt emit_yield) -\end{code} - -\begin{code} -cgAlgDefault :: GCFlag - -> Bool -- could be a function-typed result? - -> Unique -> AbstractC -> Bool -- turgid state... - -> StgCaseDefault -- input - -> Bool - -> FCode AbstractC -- output - -cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _ - = returnFC AbsCNop - -cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch - (StgBindDefault rhs) - emit_yield{-should a yield macro be emitted?-} - - = -- We have arranged that Node points to the thing - getAbsC (absC restore_cc `thenC` - (if opt_GranMacros && emit_yield - then yield [node] False - else absC AbsCNop) `thenC` - possibleHeapCheck gc_flag is_fun [node] [] Nothing (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 -> AbstractC -> Bool -- turgid state - -> Bool -- Context switch at alts? - -> (DataCon, [Id], [Bool], StgExpr) - -> FCode (ConTag, AbstractC) - -cgAlgAlt gc_flag uniq restore_cc must_label_branch - emit_yield{-should a yield macro be emitted?-} - (con, args, use_mask, rhs) - = getAbsC (absC restore_cc `thenC` - (if opt_GranMacros && 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` - possibleHeapCheck gc_flag False [node] [] Nothing ( - 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 True `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 - :: CLabel -- label of the alternative - -> AbstractC -- junk - -> Bool -- ctxt switch - -> (DataCon, [Id], [Bool], StgExpr) -- alternative - -> FCode AbstractC - -cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs) - = getAbsC ( - absC restore_cc `thenC` - - bindUnboxedTupleComponents args - `thenFC` \ (live_regs,tags,stack_res) -> - (if opt_GranMacros && emit_yield - then yield live_regs True -- XXX live regs wrong? - else absC AbsCNop) `thenC` - let - -- ToDo: could maybe use Nothing here if stack_res is False - -- since the heap-check can just return to the top of the - -- stack. - ret_addr = Just lbl - in - - -- free up stack slots containing tags, - freeStackSlots (map fst tags) `thenC` - - -- generate a heap check if necessary - possibleHeapCheck GCMayHappen False live_regs tags ret_addr ( - - -- 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} %************************************************************************ @@ -710,34 +505,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 SLIT("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, - (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? + 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} %************************************************************************ @@ -746,7 +551,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. @@ -754,55 +559,30 @@ the maximum stack depth encountered down any branch. As usual, no binders in the alternatives are yet bound. \begin{code} -cgPrimInlineAlts bndr ty alts deflt - = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt [] - where - uniq = getUnique bndr - kind = typePrimRep ty - -cgPrimEvalAlts bndr ty alts deflt - = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg] - where - reg = dataReturnConvPrim kind - kind = typePrimRep ty - -cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs - = -- first bind the default if necessary - (if isDeadBinder bndr - then nopC - else 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 = possibleHeapCheck gc_flag False regs [] Nothing (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 (possibleHeapCheck gc_flag False regs [] Nothing (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} @@ -813,13 +593,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) -> @@ -829,7 +619,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 @@ -873,21 +663,22 @@ saveCurrentCostCentre = if not opt_SccProfilingOn then returnFC (Nothing, AbsCNop) else - allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot -> + allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot -> + dataStackSlots [slot] `thenC` getSpRelOffset slot `thenFC` \ sp_rel -> returnFC (Just slot, CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre)) -restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC - -restoreCurrentCostCentre Nothing - = returnFC AbsCNop -restoreCurrentCostCentre (Just slot) - = getSpRelOffset slot `thenFC` \ sp_rel -> - freeStackSlots [slot] `thenC` - returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) +-- Sometimes we don't free the slot containing the cost centre after restoring it +-- (see CgLetNoEscape.cgLetNoEscapeBody). +restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code +restoreCurrentCostCentre Nothing _freeit = nopC +restoreCurrentCostCentre (Just slot) freeit + = getSpRelOffset slot `thenFC` \ sp_rel -> + (if freeit then freeStackSlots [slot] else nopC) `thenC` + absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) -- we use the RESTORE_CCCS macro, rather than just - -- assigning into CurCostCentre, in case RESTORE_CCC + -- assigning into CurCostCentre, in case RESTORE_CCCS -- has some sanity-checking in it. \end{code} @@ -901,138 +692,88 @@ Build a return vector, and return a suitable label addressing mode for it. \begin{code} -mkReturnVector :: Unique - -> [(ConTag, AbstractC)] -- Branch codes - -> AbstractC -- Default case - -> SRT -- continuation's SRT - -> Liveness -- stack liveness - -> CtrlReturnConvention - -> FCode CAddrMode - -mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv - = getSRTLabel `thenFC` \srt_label -> - let - srt_info = (srt_label, srt) - - (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_label, srt) 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_label, srt) - 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_label, srt) 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 - - vtbl_label = mkVecTblLabel uniq - ret_label = mkReturnInfoLabel uniq - - deflt_lbl = - case nonemptyAbsC deflt_absC of - -- the simplifier might have eliminated a case - Nothing -> 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} -possibleHeapCheck - :: GCFlag - -> Bool -- True <=> algebraic case - -> [MagicId] -- live registers - -> [(VirtualSpOffset,Int)] -- stack slots to tag - -> Maybe CLabel -- return address - -> Code -- continuation - -> Code - -possibleHeapCheck GCMayHappen is_alg regs tags lbl code - = altHeapCheck is_alg regs tags AbsCNop lbl code -possibleHeapCheck NoGC _ _ tags lbl code - = code -\end{code} - -splitTyConAppThroughNewTypes is like splitTyConApp_maybe except -that it looks through newtypes in addition to synonyms. It's -useful in the back end where we're not interested in newtypes -anymore. +mkRetVecTarget :: Id -- Just for its unique + -> [(AltCon, AbstractC)] -- Branch codes + -> SRT -- Continuation's SRT + -> CtrlReturnConvention + -> FCode CAddrMode -Sometimes, we've thrown away the constructors during pruning in the -renamer. In these cases, we emit a warning and fall back to using a -SEQ_FRAME to evaluate the case scrutinee. +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 -\begin{code} -getScrutineeTyCon :: Type -> Maybe TyCon -getScrutineeTyCon ty = - case (splitTyConAppThroughNewTypes ty) of - Nothing -> Nothing - Just (tc,_) -> - if isFunTyCon tc then Nothing else -- not interested in funs - if isPrimTyCon tc then Just tc else -- return primitive tycons - -- otherwise (algebraic tycons) check the no. of constructors - case (tyConFamilySize tc) of - 0 -> pprTrace "Warning" (hcat [ - text "constructors for ", - ppr tc, - text " not available.\n\tUse -fno-prune-tydecls to fix." - ]) Nothing - _ -> Just tc - -splitTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type]) -splitTyConAppThroughNewTypes ty - = case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> splitTyConAppThroughNewTypes ty - | otherwise -> Just (tc, tys) - where - ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys) +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 - other -> Nothing + 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" + get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep \end{code}