%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.58 2002/08/02 13:08:34 simonmar Exp $
+% $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 simonmar Exp $
%
%********************************************************
%* *
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)
= 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}
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}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.32 2002/08/29 15:44:13 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.33 2002/09/04 10:00:46 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
\begin{code}
altHeapCheck
- :: Bool -- is an algebraic alternative
+ :: Bool -- is a polymorphic case alt
+ -> Bool -- is an primitive case alt
-> [MagicId] -- live registers
-> [(VirtualSpOffset,Int)] -- stack slots to tag
-> AbstractC
-- unboxed tuple alternatives and let-no-escapes (the two most annoying
-- constructs to generate code for!):
-altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
+altHeapCheck is_poly is_prim regs tags fail_code (Just ret_addr) code
= mkTagAssts tags `thenFC` \tag_assts1 ->
let tag_assts = mkAbstractCs [fail_code, tag_assts1]
in
-- normal algebraic and primitive case alternatives:
-altHeapCheck is_fun regs [] AbsCNop Nothing code
+altHeapCheck is_poly is_prim regs [] AbsCNop Nothing code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
where
do_heap_chk :: HeapOffset -> Code
[] ->
CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
- -- The SEQ case (polymophic/function typed case branch)
- -- We need this case because the closure in Node won't return
- -- directly when we enter it (it could be a function), so the
- -- heap check code needs to push a seq frame on top of the stack.
+ -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
+ --
+ -- We also lump the polymorphic case in here, because we don't
+ -- want to enter R1 if it is a function, and we're guarnateed
+ -- that the return point has a direct return.
[VanillaReg rep 1#]
- | rep == PtrRep
- && is_fun ->
- CCheck HP_CHK_SEQ_NP
- [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
- AbsCNop
+ | isFollowableRep rep && (is_poly || is_prim) ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-- R1 is lifted (the common case)
- [VanillaReg rep 1#]
- | rep == PtrRep ->
- CCheck HP_CHK_NP
+ | isFollowableRep rep ->
+ CCheck HP_CHK_NP
[mkIntCLit words_required, mkIntCLit 1{-regs live-}]
AbsCNop
- -- R1 is boxed, but unlifted
- | isFollowableRep rep ->
- CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-
-- R1 is unboxed
| otherwise ->
CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
projects / ghc-hetmet.git / commitdiff