X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=8c67334b2814f360bac336549507ee89c2ec6b6e;hb=0c33b675b26b627963c7a2ac00d6dd4c551fbcac;hp=2182c17b8d8b15de5fec0f49d51fc5d2bb01b705;hpb=699e9f229be993270e49ff7fcdd155508502c6ea;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 2182c17..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.26 1999/04/23 13:53:28 simonm Exp $ +% $Id: CgCase.lhs,v 1.62 2003/05/14 09:13:53 simonmar Exp $ % %******************************************************** %* * @@ -10,9 +10,8 @@ %******************************************************** \begin{code} -module CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre, freeCostCentreSlot, - splitTyConAppThroughNewTypes ) where +module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre + ) where #include "HsVersions.h" @@ -25,48 +24,39 @@ import AbsCSyn import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep, nonemptyAbsC ) -import CoreSyn ( isDeadBinder ) -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 + 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, idPrimRep, isDeadBinder ) +import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag ) import VarSet ( varSetElems ) -import Const ( Con(..), Literal ) +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, - splitFunTys, applyTys ) -import Unique ( Unique, Uniquable(..) ) +import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep ) +import Name ( Name, getName ) +import Unique ( Unique, Uniquable(..), newTagUnique ) import Maybes ( maybeToBool ) +import Util ( only ) import Outputable \end{code} @@ -127,45 +117,114 @@ cgCase :: StgExpr -> Code \end{code} -Several special cases for inline primitive operations. +Special case #1: PrimOps returning enumeration types. + +For enumeration types, we invent a temporary (builtin-unique 1) to +hold the tag, and cross our fingers that this doesn't clash with +anything else. Builtin-unique 0 is used for a similar reason when +compiling enumerated-type primops in CgExpr.lhs. We can't use the +unique from the case binder, because this is used to hold the actual +closure (when the case binder is live, that is). + +There is an extra special case for + + case tagToEnum# x of + ... + +which generates no code for the primop, unless x is used in the +alternatives (in which case we lookup the tag in the relevant closure +table to get the closure). + +Being a bit short of uniques for temporary variables here, we use +newTagUnique to generate a new unique from the case binder. The case +binder's unique will presumably have the 'c' tag (generated by +CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it +doesn't clash with anything else. \begin{code} -cgCase (StgCon (PrimOp TagToEnumOp) [arg] res_ty) - live_in_whole_case live_in_alts bndr srt alts +cgCase (StgOpApp op args _) + live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt) | isEnumerationTyCon tycon - = getArgAmode arg `thenFC` \amode -> + = getArgAmodes args `thenFC` \ arg_amodes -> + + case op of { + StgPrimOp TagToEnumOp -- No code! + -> returnFC (only arg_amodes) ; + + _ -> -- Perform the operation + let + tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep + in + getVolatileRegs live_in_alts `thenFC` \ vol_regs -> + absC (COpStmt [tag_amode] op arg_amodes vol_regs) + `thenC` + -- NB: no liveness arg + returnFC tag_amode + } `thenFC` \ tag_amode -> + let - [res] = getPrimAppResultAmodes (getUnique bndr) alts + closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) + tag_amode PtrRep) + PtrRep in - absC (CAssign res (CTableEntry - (CLbl (mkClosureTblLabel tycon) PtrRep) - amode PtrRep)) `thenC` - -- Scrutinise the result - cgInlineAlts bndr alts + -- Bind the default binder if necessary + -- The deadness info is set by StgVarInfo + (if (isDeadBinder bndr) + then nopC + else bindNewToTemp bndr `thenFC` \ bndr_amode -> + absC (CAssign bndr_amode closure)) + `thenC` + + -- compile the alts + cgAlgAlts NoGC False{-not polymorphic-} (getUnique bndr) + Nothing{-cc_slot-} False{-no semi-tagging-} + alts deflt False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) -> - | otherwise = panic "cgCase: tagToEnum# of non-enumerated type" - where - (Just (tycon,_)) = splitTyConApp_maybe res_ty + -- Do the switch + absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c) +\end{code} -cgCase (StgCon (PrimOp op) args res_ty) - live_in_whole_case live_in_alts bndr srt alts - | not (primOpOutOfLine op) +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 #3: inline PrimOps. + +\begin{code} +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 @@ -182,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 -> @@ -193,10 +252,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt 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` + bindNewToTemp bndr `thenFC` \deflt_amode -> + absC (CAssign deflt_amode amode) `thenC` cgPrimAlts NoGC amode alts deflt [] \end{code} @@ -207,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 @@ -266,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 @@ -323,89 +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) - -This is all disgusting, because these amodes must be consistent with those -invented by CgAlgAlts. - -\begin{code} -getPrimAppResultAmodes - :: Unique - -> StgCaseAlts - -> [CAddrMode] -\end{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 +maybeReserveSeqFrame (StgAlgAlts Nothing _ _) + (EndOfBlockInfo args_sp (CaseAlts amode stuff _)) + = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True) -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. - -\begin{code} -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 +maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info \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} @@ -427,22 +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 - -- get the stack liveness for the info table (after the CC slot has - -- been freed - this is important). - freeCostCentreSlot cc_slot `thenC` - 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) - (if (isDeadBinder bndr) - then nopC - else 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. @@ -453,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 lbl 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 @@ -486,107 +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 -> -- 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 -> - restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> + 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 (mkReturnPtLabel 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} - -Hack: to deal with - - case <# x y of z { - DEFAULT -> ... - } - -\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} - -Second case: algebraic case, several alternatives. -Tag is held in a temporary. - -\begin{code} -cgInlineAlts bndr (StgAlgAlts ty alts deflt) - = -- bind the default binder (it covers all the alternatives) - - -- ToDo: BUG! bndr isn't bound in the alternatives - -- Shows up when compiling Word.lhs - -- case cmp# a b of r { - -- True -> f1 r - -- False -> f2 r - - 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) -> - - -- 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 -\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} @@ -603,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? @@ -614,35 +507,36 @@ 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?-} = -- We have arranged that Node points to the thing restoreCurrentCostCentre cc_slot `thenFC` \restore_cc -> 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) + -- HWL: maybe need yield here + --(if emit_yield + -- then yield [node] True + -- else absC AbsCNop) `thenC` + algAltHeapCheck gc_flag is_poly [node] (cgExpr rhs) -- Node is live, but doesn't need to point at the thing itself; -- it's ok for Node to point to an indirection or FETCH_ME -- Hence no need to re-enter Node. @@ -670,14 +564,15 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch = restoreCurrentCostCentre cc_slot `thenFC` \restore_cc -> getAbsC (absC restore_cc `thenC` - (if opt_GranMacros && emit_yield - then yield [node] True -- XXX live regs wrong - else absC AbsCNop) `thenC` + -- HWL: maybe need yield here + -- (if emit_yield + -- then yield [node] True -- XXX live regs wrong + -- else absC AbsCNop) `thenC` (case gc_flag of NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC GCMayHappen -> bindConArgs con args ) `thenC` - possibleHeapCheck gc_flag False [node] [] Nothing ( + algAltHeapCheck gc_flag False{-not poly-} [node] ( cgExpr rhs) ) `thenFC` \ abs_c -> let @@ -690,7 +585,7 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch lbl = mkAltLabel uniq tag cgUnboxedTupleAlt - :: CLabel -- label of the alternative + :: Unique -- unique for label of the alternative -> Maybe VirtualSpOffset -- Restore cost centre -> Bool -- ctxt switch -> (DataCon, [Id], [Bool], StgExpr) -- alternative @@ -699,26 +594,18 @@ 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` - (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` + -- HWL: maybe need yield here + -- (if emit_yield + -- then yield live_regs True -- XXX live regs wrong? + -- else absC AbsCNop) `thenC` -- generate a heap check if necessary - possibleHeapCheck GCMayHappen False live_regs tags ret_addr ( + possibleUnbxTupleHeapCheck GCMayHappen live_regs ptrs nptrs ( -- and finally the code for the alternative cgExpr rhs) @@ -749,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) ) @@ -779,23 +666,21 @@ 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 = 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 - (if isDeadBinder bndr - then nopC - else bindNewPrimToAmode bndr scrutinee) `thenC` + bindNewPrimToAmode bndr scrutinee `thenC` cgPrimAlts gc_flag scrutinee alts deflt regs cgPrimAlts gc_flag scrutinee alts deflt regs @@ -816,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 @@ -827,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} @@ -898,22 +783,20 @@ 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)) -freeCostCentreSlot :: Maybe VirtualSpOffset -> Code -freeCostCentreSlot Nothing = nopC -freeCostCentreSlot (Just slot) = freeStackSlots [slot] - restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC restoreCurrentCostCentre Nothing = returnFC AbsCNop restoreCurrentCostCentre (Just slot) = getSpRelOffset slot `thenFC` \ sp_rel -> - returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) + freeStackSlots [slot] `thenC` + 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} @@ -927,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 @@ -935,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. @@ -958,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 @@ -980,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 @@ -987,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) @@ -1004,61 +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 CLabel -- return address - -> 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 -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. +primAltHeapCheck + :: GCFlag + -> [MagicId] -- live registers + -> Code -- continuation + -> Code -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. +primAltHeapCheck GCMayHappen regs code = altHeapCheck True regs code +primAltHeapCheck NoGC _ code = code -\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) - - other -> Nothing +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}