X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=d64755b4b8c34bb2b3b73964425e0000d732b627;hb=778b2c6bdbabf2c9f394f0ca2b76b55a7123aa5f;hp=b02e248c1d9e2422e71fb8ddafff1fa87474c70e;hpb=506fa77d392191e46c12b2c19387ff5b0888f6a2;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b02e248..d64755b 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.29 1999/05/18 15:03:46 simonpj Exp $ +% $Id: CgCase.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $ % %******************************************************** %* * @@ -10,8 +10,7 @@ %******************************************************** \begin{code} -module CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre, freeCostCentreSlot +module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre ) where #include "HsVersions.h" @@ -39,7 +38,7 @@ import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, CtrlReturnConvention(..) ) import CgStackery ( allocPrimStack, allocStackTop, - deAllocStackTop, freeStackSlots + deAllocStackTop, freeStackSlots, dataStackSlots ) import CgTailCall ( tailCallFun ) import CgUsages ( getSpRelOffset, getRealSp ) @@ -50,21 +49,21 @@ import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( CostCentre ) -import CoreSyn ( isDeadBinder ) -import Id ( Id, idPrimRep ) +import Id ( Id, idPrimRep, isDeadBinder ) import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag, - isUnboxedTupleCon, dataConType ) + isUnboxedTupleCon ) 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, splitRepTyConApp_maybe ) -import Unique ( Unique, Uniquable(..), mkBuiltinUnique ) + splitTyConApp_maybe, repType ) +import PprType ( {- instance Outputable Type -} ) +import Unique ( Unique, Uniquable(..), mkPseudoUnique1 ) import Maybes ( maybeToBool ) import Util import Outputable @@ -145,17 +144,22 @@ 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 +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). + \begin{code} -cgCase (StgCon (PrimOp op) args res_ty) +cgCase (StgPrimApp op args res_ty) live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt) | isEnumerationTyCon tycon = getArgAmodes args `thenFC` \ arg_amodes -> let tag_amode = case op of TagToEnumOp -> only arg_amodes - _ -> CTemp (mkBuiltinUnique 1) IntRep + _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep - closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep + closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep in case op of { @@ -170,6 +174,7 @@ cgCase (StgCon (PrimOp op) args res_ty) } `thenC` -- bind the default binder if necessary + -- The deadness info is set by StgVarInfo (if (isDeadBinder bndr) then nopC else bindNewToTemp bndr `thenFC` \ bndr_amode -> @@ -192,7 +197,7 @@ cgCase (StgCon (PrimOp op) args res_ty) Special case #2: inline PrimOps. \begin{code} -cgCase (StgCon (PrimOp op) args res_ty) +cgCase (StgPrimApp op args res_ty) live_in_whole_case live_in_alts bndr srt alts | not (primOpOutOfLine op) = @@ -434,9 +439,6 @@ 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 @@ -500,12 +502,14 @@ cgEvalAlts cc_slot bndr srt alts -- primitive alts... (StgPrimAlts ty alts deflt) -> + -- Restore the cost centre + restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> + -- Generate the switch getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c -> -- Generate the labelled block, starting with restore-cost-centre getSRTLabel `thenFC` \srt_label -> - restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) (srt_label,srt) liveness_mask) `thenC` @@ -598,9 +602,10 @@ cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch = -- 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` + -- HWL: maybe need yield here + --(if emit_yield + -- then yield [node] True + -- else absC AbsCNop) `thenC` possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs) -- Node is live, but doesn't need to point at the thing itself; -- it's ok for Node to point to an indirection or FETCH_ME @@ -629,9 +634,10 @@ 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 @@ -663,9 +669,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 @@ -747,7 +754,8 @@ cgPrimInlineAlts bndr ty alts deflt cgPrimEvalAlts bndr ty alts deflt = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg] where - reg = dataReturnConvPrim kind + reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty ) + dataReturnConvPrim kind kind = typePrimRep ty cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs @@ -855,19 +863,17 @@ 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 -> + freeStackSlots [slot] `thenC` returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) -- we use the RESTORE_CCCS macro, rather than just -- assigning into CurCostCentre, in case RESTORE_CCC @@ -984,7 +990,7 @@ possibleHeapCheck NoGC _ _ tags lbl code \begin{code} getScrutineeTyCon :: Type -> Maybe TyCon getScrutineeTyCon ty = - case splitRepTyConApp_maybe ty of + case splitTyConApp_maybe (repType ty) of Nothing -> Nothing Just (tc,_) -> if isFunTyCon tc then Nothing else -- not interested in funs