X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=404e38510e12a21b4861529e234b0d3f0f240897;hb=7370adc00c9de2092c2323c7a8e20902dc4bbe41;hp=de7a898468c7816acc5ee4d4bd063aab69a9eeb8;hpb=084c8a024934d05d39e2c080b00b362605f893b9;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index de7a898..404e385 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.43 2000/07/11 16:03:37 simonmar Exp $ +% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $ % %******************************************************** %* * @@ -27,13 +27,12 @@ import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, import CgUpdate ( reserveSeqFrame ) import CgBindery ( getVolatileRegs, getArgAmodes, bindNewToReg, bindNewToTemp, - bindNewPrimToAmode, - rebindToStack, getCAddrMode, - getCAddrModeAndInfo, getCAddrModeIfVolatile, + bindNewPrimToAmode, getCAddrModeAndInfo, + rebindToStack, getCAddrMode, getCAddrModeIfVolatile, buildContLivenessMask, nukeDeadBindings, ) import CgCon ( bindConArgs, bindUnboxedTupleComponents ) -import CgHeapery ( altHeapCheck, yield ) +import CgHeapery ( altHeapCheck ) import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) @@ -41,29 +40,23 @@ import CgStackery ( allocPrimStack, allocStackTop, deAllocStackTop, freeStackSlots, dataStackSlots ) import CgTailCall ( tailCallFun ) -import CgUsages ( getSpRelOffset, getRealSp ) -import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, - mkDefaultLabel, mkAltLabel, mkReturnInfoLabel, - mkErrorStdEntryLabel, mkClosureTblLabel +import CgUsages ( getSpRelOffset ) +import CLabel ( mkVecTblLabel, mkClosureTblLabel, + mkDefaultLabel, mkAltLabel, mkReturnInfoLabel ) import ClosureInfo ( mkLFArgument ) -import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) +import CmdLineOpts ( opt_SccProfilingOn ) import Id ( Id, idPrimRep, isDeadBinder ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag, - isUnboxedTupleCon ) +import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag ) import VarSet ( varSetElems ) import Literal ( Literal ) import PrimOp ( primOpOutOfLine, PrimOp(..) ) import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) -import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, - isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon, - ) -import Type ( Type, typePrimRep, splitAlgTyConApp, - splitTyConApp_maybe, repType ) -import Unique ( Unique, Uniquable(..), mkPseudoUnique1 ) +import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep ) +import Unique ( Unique, Uniquable(..), newTagUnique ) import Maybes ( maybeToBool ) -import Util +import Util ( only ) import Outputable \end{code} @@ -143,35 +136,39 @@ 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 -mkPseudoUnique1 to generate a temporary for the tag. We can't use -mkBuiltinUnique, because that occasionally clashes with some -temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs). +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. \begin{code} -cgCase (StgPrimApp op args res_ty) - live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt) +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 -> - let tag_amode = case op of - TagToEnumOp -> only arg_amodes - _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep - - closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep - in - case op of { - TagToEnumOp -> nopC; -- no code! + 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 -> - _ -> -- Perform the operation - getVolatileRegs live_in_alts `thenFC` \ vol_regs -> - - absC (COpStmt [tag_amode] op - arg_amodes -- note: no liveness arg - vol_regs) - } `thenC` + let + closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) + tag_amode PtrRep) + PtrRep + in - -- bind the default binder if necessary + -- Bind the default binder if necessary -- The deadness info is set by StgVarInfo (if (isDeadBinder bndr) then nopC @@ -180,39 +177,54 @@ cgCase (StgPrimApp op args res_ty) `thenC` -- compile the alts - cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-} + cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} 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) +\end{code} - where - (Just (tycon,_)) = splitTyConApp_maybe res_ty - uniq = getUnique bndr +Special case #2: case of literal. + +\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} -Special case #2: inline PrimOps. +Special case #3: inline PrimOps. \begin{code} -cgCase (StgPrimApp op args res_ty) - live_in_whole_case live_in_alts bndr srt alts - | not (primOpOutOfLine op) +cgCase (StgOpApp op@(StgPrimOp primop) args _) + live_in_whole_case live_in_alts bndr srt alts + | not (primOpOutOfLine primop) = -- 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 + 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` \ _ -> + cgExpr rhs + + other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts) \end{code} TODO: Case-of-case of primop can probably be done inline too (but @@ -229,7 +241,7 @@ eliminate a heap check altogether. \begin{code} cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt - (StgPrimAlts ty alts deflt) + (StgPrimAlts tycon alts deflt) = getCAddrMode v `thenFC` \amode -> @@ -252,12 +264,11 @@ 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) -> - getArgAmodes args `thenFC` \ arg_amodes -> + live_in_whole_case live_in_alts bndr srt alts + = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> + getArgAmodes args `thenFC` \ arg_amodes -> - -- Squish the environment + -- Squish the environment nukeDeadBindings live_in_alts `thenC` saveVolatileVarsAndRegs live_in_alts `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> @@ -265,24 +276,12 @@ cgCase (StgApp fun args) allocStackTop retPrimRepSize `thenFC` \_ -> forkEval alts_eob_info nopC ( - deAllocStackTop retPrimRepSize `thenFC` \_ -> - cgEvalAlts maybe_cc_slot bndr srt alts) + 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 - - 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 alts scrut_eob_info) $ + tailCallFun fun' fun_amode lf_info arg_amodes save_assts \end{code} Note about return addresses: we *always* push a return address, even @@ -311,26 +310,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 - - setEndOfBlockInfo real_scrut_eob_info (cgExpr expr) - - where - not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of - Just _ -> False - other -> True + setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $ + cgExpr expr \end{code} There's a lot of machinery going on behind the scenes to manage the @@ -368,52 +356,11 @@ 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 -\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] - -getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default) - - | 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 - --- The situation is simpler for primitive results, because there is only --- one! - -getPrimAppResultAmodes uniq (StgPrimAlts ty _ _) - = [CTemp uniq (typePrimRep ty)] +-- We need to reserve a seq frame for a polymorphic case +maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info +maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info \end{code} - %************************************************************************ %* * \subsection[CgCase-alts]{Alternatives} @@ -442,7 +389,7 @@ cgEvalAlts cc_slot bndr srt alts case alts of -- algebraic alts ... - (StgAlgAlts ty alts deflt) -> + StgAlgAlts maybe_tycon alts deflt -> -- bind the default binder (it covers all the alternatives) bindNewToReg bndr node mkLFArgument `thenC` @@ -456,22 +403,26 @@ 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 + let is_alg = maybeToBool maybe_tycon + Just spec_tycon = maybe_tycon in - -- deal with the unboxed tuple case + -- Deal with the unboxed tuple case if is_alg && isUnboxedTupleTyCon spec_tycon then - case alts of - [alt] -> let lbl = mkReturnInfoLabel uniq in - cgUnboxedTupleAlt uniq cc_slot 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" + -- 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 srt `thenFC` \ srt_info -> + absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC` + returnFC (CaseAlts (CLbl lbl RetRep) Nothing) -- normal algebraic (or polymorphic) case alternatives else let @@ -498,56 +449,30 @@ cgEvalAlts cc_slot bndr srt alts returnFC (CaseAlts return_vec semi_tagged_stuff) -- primitive alts... - (StgPrimAlts ty alts deflt) -> + StgPrimAlts tycon alts deflt -> -- Restore the cost centre - restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> + restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> -- Generate the switch - getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c -> + getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c -> -- Generate the labelled block, starting with restore-cost-centre - getSRTLabel `thenFC` \srt_label -> + getSRTInfo srt `thenFC` \srt_info -> absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) - (srt_label,srt) liveness_mask) `thenC` + srt_info liveness_mask) `thenC` -- Return an amode for the block returnFC (CaseAlts (CLbl (mkReturnInfoLabel 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. -First case: primitive op returns an unboxed tuple. - -\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} - -Third (real) case: primitive result type. - -\begin{code} -cgInlineAlts bndr (StgPrimAlts ty alts deflt) - = cgPrimInlineAlts bndr ty alts deflt -\end{code} - %************************************************************************ %* * \subsection[CgCase-alg-alts]{Algebraic alternatives} @@ -575,11 +500,11 @@ cgAlgAlts :: GCFlag AbstractC -- The default case ) -cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt +cgAlgAlts gc_flag uniq restore_cc must_label_branches is_poly 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) + (cgAlgDefault gc_flag is_poly uniq restore_cc must_label_branches deflt emit_yield) \end{code} \begin{code} @@ -590,10 +515,10 @@ cgAlgDefault :: GCFlag -> Bool -> FCode AbstractC -- output -cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _ +cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch StgNoDefault _ = returnFC AbsCNop -cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch +cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch (StgBindDefault rhs) emit_yield{-should a yield macro be emitted?-} @@ -604,7 +529,7 @@ cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch --(if emit_yield -- then yield [node] True -- else absC AbsCNop) `thenC` - possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs) + algAltHeapCheck gc_flag is_poly [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. @@ -640,7 +565,7 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC GCMayHappen -> bindConArgs con args ) `thenC` - possibleHeapCheck gc_flag False [node] [] Nothing ( + algAltHeapCheck gc_flag False [node] [] Nothing ( cgExpr rhs) ) `thenFC` \ abs_c -> let @@ -682,7 +607,7 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs) freeStackSlots (map fst tags) `thenC` -- generate a heap check if necessary - possibleHeapCheck GCMayHappen False live_regs tags ret_addr ( + primAltHeapCheck GCMayHappen live_regs tags ret_addr ( -- and finally the code for the alternative cgExpr rhs) @@ -713,14 +638,14 @@ cgSemiTaggedAlts binder alts deflt st_deflt (StgBindDefault _) = Just (Just binder, - (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise? + (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, - (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? + (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise? [mkIntCLit (length args)], -- how big the thing in the heap is join_label) ) @@ -743,18 +668,17 @@ 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 +cgPrimInlineAlts bndr tycon alts deflt = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt [] where uniq = getUnique bndr - kind = typePrimRep ty + kind = tyConPrimRep tycon -cgPrimEvalAlts bndr ty alts deflt +cgPrimEvalAlts bndr tycon alts deflt = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg] where - reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty ) - dataReturnConvPrim kind - kind = typePrimRep ty + reg = dataReturnConvPrim kind + kind = tyConPrimRep tycon cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs = -- first bind the default if necessary @@ -779,7 +703,7 @@ 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) + rhs_code = primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs) cgPrimDefault :: GCFlag -> [MagicId] -- live registers @@ -790,7 +714,7 @@ 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)) + = getAbsC (primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs)) \end{code} @@ -872,9 +796,9 @@ restoreCurrentCostCentre Nothing = returnFC AbsCNop restoreCurrentCostCentre (Just slot) = getSpRelOffset slot `thenFC` \ sp_rel -> freeStackSlots [slot] `thenC` - returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) + returnFC (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} @@ -897,17 +821,15 @@ mkReturnVector :: Unique -> FCode CAddrMode mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv - = getSRTLabel `thenFC` \srt_label -> + = getSRTInfo srt `thenFC` \ srt_info -> 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)); + absC (CRetDirect uniq deflt_absC srt_info liveness)); UnvectoredReturn n -> -- find the tag explicitly rather than using tag_reg for now. @@ -919,7 +841,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv (CLbl ret_label RetRep, absC (CRetDirect uniq (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC) - (srt_label, srt) + srt_info liveness)); VectoredReturn table_size -> @@ -927,9 +849,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv (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 + 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 @@ -948,7 +868,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv deflt_lbl = case nonemptyAbsC deflt_absC of -- the simplifier might have eliminated a case - Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep + Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep mk_vector_entry :: ConTag -> (CAddrMode, AbstractC) @@ -970,29 +890,22 @@ heap check or not. These heap checks are always in a case alternative, so we use altHeapCheck. \begin{code} -possibleHeapCheck +algAltHeapCheck :: GCFlag - -> Bool -- True <=> algebraic case + -> Bool -- True <=> polymorphic case -> [MagicId] -- live registers -> [(VirtualSpOffset,Int)] -- stack slots to tag -> Maybe Unique -- return address unique -> Code -- continuation -> Code -possibleHeapCheck GCMayHappen is_alg regs tags lbl code - = altHeapCheck is_alg regs tags AbsCNop lbl code -possibleHeapCheck NoGC _ _ tags lbl code +algAltHeapCheck GCMayHappen is_poly regs tags lbl code + = altHeapCheck is_poly False regs tags AbsCNop lbl code +algAltHeapCheck NoGC _ _ tags lbl code = code -\end{code} -\begin{code} -getScrutineeTyCon :: Type -> Maybe TyCon -getScrutineeTyCon ty = - case splitTyConApp_maybe (repType 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 - Just tc +primAltHeapCheck GCMayHappen regs tags lbl code + = altHeapCheck False True regs tags AbsCNop lbl code +primAltHeapCheck NoGC _ _ _ code + = code \end{code}