X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=8c67334b2814f360bac336549507ee89c2ec6b6e;hb=7a236a564b90cd060612e1e979ce7d552da61fa1;hp=b9c314919492e076ea0a3f681d8fa48a5612ed89;hpb=f5262d4457cabda7112af850d4659366a7ce34a1;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b9c3149..8c67334 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.41 2000/04/13 20:41:30 panne Exp $ +% $Id: CgCase.lhs,v 1.62 2003/05/14 09:13:53 simonmar Exp $ % %******************************************************** %* * @@ -24,48 +24,39 @@ import AbsCSyn import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep, nonemptyAbsC ) -import CgUpdate ( reserveSeqFrame ) -import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode, +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, unbxTupleHeapCheck ) import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) 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 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 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, - tyConDataCons, tyConFamilySize ) -import Type ( Type, typePrimRep, splitAlgTyConApp, - splitTyConApp_maybe, repType ) -import PprType ( {- instance Outputable Type -} ) -import Unique ( Unique, Uniquable(..), mkPseudoUnique1 ) +import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep ) +import Name ( Name, getName ) +import Unique ( Unique, Uniquable(..), newTagUnique ) import Maybes ( maybeToBool ) -import Util +import Util ( only ) import Outputable \end{code} @@ -145,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 @@ -182,39 +177,54 @@ cgCase (StgPrimApp op args res_ty) `thenC` -- compile the alts - cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-} - False{-not poly case-} alts deflt - False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) -> + 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) +\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 @@ -231,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 -> @@ -254,37 +264,29 @@ 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 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 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) $ + performTailCall fun' fun_amode lf_info arg_amodes save_assts \end{code} Note about return addresses: we *always* push a return address, even @@ -313,26 +315,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 @@ -370,52 +361,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 -\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) +maybeReserveSeqFrame (StgAlgAlts Nothing _ _) + (EndOfBlockInfo args_sp (CaseAlts amode stuff _)) + = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True) -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)] +maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info \end{code} - %************************************************************************ %* * \subsection[CgCase-alts]{Alternatives} @@ -437,17 +389,17 @@ cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if cgEvalAlts cc_slot bndr srt alts = - let uniq = getUnique bndr in + let uniq = getUnique bndr; name = getName bndr in - buildContLivenessMask uniq `thenFC` \ liveness_mask -> + buildContLivenessMask name `thenFC` \ liveness -> 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` + 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. @@ -458,22 +410,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 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 @@ -491,65 +447,39 @@ cgEvalAlts cc_slot bndr srt alts Nothing -- no semi-tagging info in - cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg) + cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) -> - mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask + mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv `thenFC` \ return_vec -> - returnFC (CaseAlts return_vec semi_tagged_stuff) + returnFC (CaseAlts return_vec semi_tagged_stuff False) -- 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 name srt `thenFC` \srt_info -> absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) - (srt_label,srt) liveness_mask) `thenC` + srt_info liveness) `thenC` -- Return an amode for the block - returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing) + returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing False) \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} @@ -566,10 +496,10 @@ are inlined alternatives. \begin{code} cgAlgAlts :: GCFlag + -> Bool -- polymorphic case -> Unique -> Maybe VirtualSpOffset -> Bool -- True <=> branches must be labelled - -> Bool -- True <=> polymorphic case -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives -> StgCaseDefault -- The default -> Bool -- Context switch at alts? @@ -577,25 +507,25 @@ cgAlgAlts :: GCFlag AbstractC -- The default case ) -cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt +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_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} cgAlgDefault :: GCFlag - -> Bool -- could be a function-typed result? + -> Bool -- polymorphic case -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state... -> StgCaseDefault -- input -> 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?-} @@ -606,7 +536,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] (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. @@ -642,7 +572,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{-not poly-} [node] ( cgExpr rhs) ) `thenFC` \ abs_c -> let @@ -664,7 +594,7 @@ cgUnboxedTupleAlt cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs) = getAbsC ( bindUnboxedTupleComponents args - `thenFC` \ (live_regs,tags,stack_res) -> + `thenFC` \ (live_regs, ptrs, nptrs, stack_res) -> restoreCurrentCostCentre cc_slot `thenFC` \restore_cc -> absC restore_cc `thenC` @@ -673,18 +603,9 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs) -- (if 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 ( + possibleUnbxTupleHeapCheck GCMayHappen live_regs ptrs nptrs ( -- and finally the code for the alternative cgExpr rhs) @@ -715,14 +636,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) ) @@ -745,18 +666,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 @@ -781,7 +701,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 (cgExpr rhs) cgPrimDefault :: GCFlag -> [MagicId] -- live registers @@ -792,7 +712,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 (cgExpr rhs)) \end{code} @@ -874,9 +794,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} @@ -890,7 +810,7 @@ Build a return vector, and return a suitable label addressing mode for it. \begin{code} -mkReturnVector :: Unique +mkReturnVector :: Name -> [(ConTag, AbstractC)] -- Branch codes -> AbstractC -- Default case -> SRT -- continuation's SRT @@ -898,18 +818,16 @@ mkReturnVector :: Unique -> CtrlReturnConvention -> FCode CAddrMode -mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv - = getSRTLabel `thenFC` \srt_label -> +mkReturnVector name tagged_alt_absCs deflt_absC srt liveness ret_conv + = getSRTInfo name 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. @@ -921,17 +839,14 @@ 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) - liveness)); + 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_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 @@ -943,6 +858,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv returnFC return_vec_amode -- ) where + uniq = getUnique name vtbl_label = mkVecTblLabel uniq ret_label = mkReturnInfoLabel uniq @@ -950,7 +866,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) @@ -967,34 +883,40 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv %* * %************************************************************************ -@possibleHeapCheck@ tests a flag passed in to decide whether to do a +'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 +algAltHeapCheck :: GCFlag - -> Bool -- True <=> algebraic case - -> [MagicId] -- live registers - -> [(VirtualSpOffset,Int)] -- stack slots to tag - -> Maybe Unique -- return address unique - -> Code -- continuation + -> Bool -- polymorphic case + -> [MagicId] -- live registers + -> 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} +algAltHeapCheck GCMayHappen is_poly regs code = altHeapCheck is_poly regs code +algAltHeapCheck NoGC _ _ code = 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 + :: GCFlag + -> [MagicId] -- live registers + -> Code -- continuation + -> Code + +primAltHeapCheck GCMayHappen regs code = altHeapCheck True regs code +primAltHeapCheck NoGC _ code = code + +possibleUnbxTupleHeapCheck + :: GCFlag + -> [MagicId] -- live registers + -> Int -- no. of stack slots containing ptrs + -> Int -- no. of stack slots containing nonptrs + -> Code -- continuation + -> Code + +possibleUnbxTupleHeapCheck GCMayHappen regs ptrs nptrs code + = unbxTupleHeapCheck regs ptrs nptrs AbsCNop code +possibleUnbxTupleHeapCheck NoGC _ _ _ code + = code \end{code}