%
% (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.33 1999/06/24 13:04:16 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre, freeCostCentreSlot,
- splitTyConAppThroughNewTypes ) where
+module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+ ) where
#include "HsVersions.h"
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
getAmodeRep, nonemptyAbsC
)
-import CoreSyn ( isDeadBinder )
import CgUpdate ( reserveSeqFrame )
import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
bindNewToReg, bindNewToTemp,
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots
+ deAllocStackTop, freeStackSlots, dataStackSlots
)
import CgTailCall ( tailCallFun )
import CgUsages ( getSpRelOffset, getRealSp )
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( CostCentre )
+import CoreSyn ( isDeadBinder )
import Id ( Id, idPrimRep )
import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
isUnboxedTupleCon, dataConType )
isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
tyConDataCons, tyConFamilySize )
import Type ( Type, typePrimRep, splitAlgTyConApp,
- splitTyConApp_maybe,
- splitFunTys, applyTys )
+ splitTyConApp_maybe, splitRepTyConApp_maybe )
import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
import Maybes ( maybeToBool )
import Util
TagToEnumOp -> only arg_amodes
_ -> CTemp (mkBuiltinUnique 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 {
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}
=
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
(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.
-- 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`
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
= 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
= 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 splitRepTyConApp_maybe 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}
projects / ghc-hetmet.git / blobdiff