From c83656b25b1bf88e319311ee6b4068bf20dd2e09 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 4 Sep 2002 10:00:46 +0000 Subject: [PATCH] [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. --- ghc/compiler/codeGen/CgCase.lhs | 35 ++++++++++++++++++-------------- ghc/compiler/codeGen/CgHeapery.lhs | 34 +++++++++++++------------------ ghc/compiler/codeGen/CgLetNoEscape.lhs | 4 ++-- 3 files changed, 36 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index e76f517..fbc037e 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (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} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 3b3c403..0d8e4d2 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 8562b67..db8dbcd 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (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 ) -- 1.7.10.4