%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.50 2000/11/15 14:37:08 simonpj Exp $
+% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $
%
%********************************************************
%* *
import CgUpdate ( reserveSeqFrame )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode,
- rebindToStack, getCAddrMode,
- getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ bindNewPrimToAmode, getCAddrModeAndInfo,
+ rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
-import Util
+import Util ( only )
import Outputable
\end{code}
doesn't clash with anything else.
\begin{code}
-cgCase (StgPrimApp op args _)
+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 (newTagUnique (getUnique bndr) 'C') IntRep
-
- closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) 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
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
\end{code}
-Special case #2: inline PrimOps.
+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 #3: inline PrimOps.
\begin{code}
-cgCase (StgPrimApp op args _)
+cgCase (StgOpApp op@(StgPrimOp primop) args _)
live_in_whole_case live_in_alts bndr srt alts
- | not (primOpOutOfLine op)
+ | not (primOpOutOfLine primop)
=
-- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr srt alts -- @(StgAlgAlts _ _ _)
- -- SLPJ: Surely PrimAlts is ok too?
- =
- 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) ->
`thenFC` \ scrut_eob_info ->
setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
- tailCallFun fun fun_amode lf_info arg_amodes save_assts
+ tailCallFun fun' fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
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
getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
- getSRTLabel `thenFC` \srt_label ->
+ 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)
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}
-> 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?-}
--(if emit_yield
-- then yield [node] True
-- else absC AbsCNop) `thenC`
- possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
+ 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.
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
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)
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)
)
cgPrimEvalAlts bndr tycon alts deflt
= cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
where
- reg = WARN( case kind of { PtrRep -> True; other -> False },
- text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
- dataReturnConvPrim kind
+ reg = dataReturnConvPrim kind
kind = tyConPrimRep tycon
cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
= 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
= 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}
restoreCurrentCostCentre (Just slot)
= getSpRelOffset slot `thenFC` \ sp_rel ->
freeStackSlots [slot] `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCCS
-- has some sanity-checking in it.
-> FCode CAddrMode
mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTLabel `thenFC` \srt_label ->
+ = getSRTInfo srt `thenFC` \ srt_info ->
let
(return_vec_amode, vtbl_body) = case ret_conv of {
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
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 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
+
+primAltHeapCheck GCMayHappen regs tags lbl code
+ = altHeapCheck False True regs tags AbsCNop lbl code
+primAltHeapCheck NoGC _ _ _ code
= code
\end{code}
projects / ghc-hetmet.git / blobdiff