X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=404e38510e12a21b4861529e234b0d3f0f240897;hb=063123a0a1b51609108aa4487894b78492411fb1;hp=a99a8fe7542a6884cad3306838cb55e5e37ffc22;hpb=0a4e3ee6a32f3c3bcabcdccf62e4768219fc12fa;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index a99a8fe..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.27 1999/04/27 12:34:52 simonm Exp $ +% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj 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,49 +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 ) 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 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(..), mkBuiltinUnique ) +import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep ) +import Unique ( Unique, Uniquable(..), newTagUnique ) import Maybes ( maybeToBool ) -import Util +import Util ( only ) import Outputable \end{code} @@ -146,31 +135,41 @@ 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 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 (mkBuiltinUnique 1) IntRep - - closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep - in - case op of { - TagToEnumOp -> nopC; -- no code! - - _ -> -- Perform the operation - getVolatileRegs live_in_alts `thenFC` \ vol_regs -> + 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 -> - 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 else bindNewToTemp bndr `thenFC` \ bndr_amode -> @@ -178,39 +177,54 @@ cgCase (StgCon (PrimOp 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 (StgCon (PrimOp 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 @@ -227,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 -> @@ -238,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} @@ -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} @@ -437,20 +384,15 @@ cgEvalAlts cc_slot bndr srt alts = let uniq = getUnique 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 -> 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 `thenC` -- Generate sequel info for use downstream -- At the moment, we only do it if the type is vector-returnable. @@ -461,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 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 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 @@ -503,54 +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 -> -- 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 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 (mkReturnPtLabel uniq) RetRep) Nothing) + 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} @@ -578,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} @@ -593,20 +515,21 @@ 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?-} = -- 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] [] 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. @@ -634,14 +557,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 [node] [] Nothing ( cgExpr rhs) ) `thenFC` \ abs_c -> let @@ -654,7 +578,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 @@ -668,9 +592,10 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs) 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` + -- HWL: maybe need yield here + -- (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 @@ -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,23 +668,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 @@ -780,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 @@ -791,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} @@ -862,22 +785,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} @@ -900,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. @@ -922,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 -> @@ -930,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 @@ -951,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) @@ -973,56 +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 CLabel -- return address + -> 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} - -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. - -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. - -\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 +primAltHeapCheck GCMayHappen regs tags lbl code + = altHeapCheck False True regs tags AbsCNop lbl code +primAltHeapCheck NoGC _ _ _ code + = code \end{code}