Commit c83656b2 authored by simonmar's avatar simonmar
Browse files

[project @ 2002-09-04 10:00:45 by simonmar]

Recent changes to simplify PrimRep had introduced a bug: the heap
check code was assuming that anything with PtrRep representation was
enterable.  This isn't the case for the unpointed primitive types
(eg. ByteArray#), resulting in the ARR_WORDS crash in last night's
build.

This bug isn't in STABLE.
parent 5e2277f6
%
% (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 $
%
%********************************************************
%* *
......@@ -500,11 +500,11 @@ cgAlgAlts :: GCFlag
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}
......@@ -515,10 +515,10 @@ cgAlgDefault :: GCFlag
-> 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?-}
......@@ -529,7 +529,7 @@ cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
--(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.
......@@ -565,7 +565,7 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch
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
......@@ -607,7 +607,7 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
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)
......@@ -703,7 +703,7 @@ cgPrimAlt gc_flag regs (lit, 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
......@@ -714,7 +714,7 @@ cgPrimDefault gc_flag regs StgNoDefault
= 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}
......@@ -890,17 +890,22 @@ heap check or not. These heap checks are always in a case
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}
......@@ -236,7 +236,8 @@ have to do something about saving and restoring the other registers.
\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
......@@ -247,7 +248,7 @@ altHeapCheck
-- 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
......@@ -308,7 +309,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
-- 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
......@@ -334,28 +335,21 @@ altHeapCheck is_fun regs [] AbsCNop Nothing 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
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
% $Id: CgLetNoEscape.lhs,v 1.16 2001/10/25 02:13:11 sof Exp $
% $Id: CgLetNoEscape.lhs,v 1.17 2002/09/04 10:00:46 simonmar Exp $
%
%********************************************************
%* *
......@@ -227,7 +227,7 @@ cgLetNoEscapeBody binder cc all_args body uniq
-- Do heap check [ToDo: omit for non-recursive case by recording in
-- in envt and absorbing at call site]
altHeapCheck False arg_regs stk_tags frame_hdr_asst (Just uniq) (
altHeapCheck False True arg_regs stk_tags frame_hdr_asst (Just uniq) (
cgExpr body
)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment