%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj Exp $
+% $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 simonmar Exp $
%
%********************************************************
%* *
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`
+ absC (COpStmt [tag_amode] op arg_amodes vol_regs)
+ `thenC`
-- NB: no liveness arg
returnFC tag_amode
} `thenFC` \ tag_amode ->
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 (StgOpApp op@(StgPrimOp primop) args _)
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.
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