%
% (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.57 2002/04/29 14:03:41 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,
+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}
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 ->
`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
\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 ->
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}
\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) ->
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
-- 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
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}
=
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.
--
-- 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 uniq 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
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 (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}
= -- 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
=
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
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
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)
)
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 = WARN( case kind of { PtrRep -> True; other -> False },
+ text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
+ 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
= 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}
-> 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.
(CLbl ret_label RetRep,
absC (CRetDirect uniq
(mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- (srt_label, srt)
+ srt_info
liveness));
VectoredReturn table_size ->
(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
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)
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
- 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
-
-\end{code}
projects / ghc-hetmet.git / blobdiff