X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCase.lhs;h=339569b4df3602665ce3f51d85c61b1eada92cb5;hb=798374a5fa613d622b70cd4c37bb97f203abb6ba;hp=aa09d5db6db1fe0b7e1fc3af2e85180037ff1369;hpb=589b7946b0847a47d1a5493dcec0976c84814312;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index aa09d5d..339569b 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.28 1999/05/13 17:30:55 simonm Exp $ +% $Id: CgCase.lhs,v 1.44 2000/07/14 08:14:53 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,9 +24,8 @@ 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, @@ -40,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,22 +48,20 @@ import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel, ) import ClosureInfo ( mkLFArgument ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) -import CostCentre ( CostCentre ) -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, - splitFunTys, applyTys ) -import Unique ( Unique, Uniquable(..), mkBuiltinUnique ) + splitTyConApp_maybe, repType ) +import Unique ( Unique, Uniquable(..), mkPseudoUnique1 ) import Maybes ( maybeToBool ) import Util import Outputable @@ -146,17 +142,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 { @@ -171,6 +172,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 -> @@ -193,7 +195,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) = @@ -238,10 +240,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} @@ -437,9 +437,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 @@ -448,9 +445,7 @@ cgEvalAlts cc_slot bndr srt alts (StgAlgAlts ty 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. @@ -505,12 +500,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` @@ -603,9 +600,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 @@ -634,9 +632,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 @@ -668,9 +667,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 @@ -752,14 +752,13 @@ 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 = -- 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 @@ -862,19 +861,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 @@ -902,8 +899,6 @@ mkReturnVector :: Unique mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv = getSRTLabel `thenFC` \srt_label -> let - srt_info = (srt_label, srt) - (return_vec_amode, vtbl_body) = case ret_conv of { -- might be a polymorphic case... @@ -988,41 +983,14 @@ possibleHeapCheck 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 + 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 - 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 - + Just tc \end{code}