Permalink
Browse files

[project @ 2003-03-24 14:46:53 by simonmar]

Fix some bugs in compacting GC.

Bug 1: When threading the fields of an AP or PAP, we were grabbing the
info table of the function without unthreading it first.

Bug 2: eval_thunk_selector() might accidentally find itself in
to-space when going through indirections in a compacted generation.
We must check for this case and bale out if necessary.

Bug 3: This is somewhat more nasty.  When we have an AP or PAP that
points to a BCO, the layout info for the AP/PAP is in the BCO's
instruction array, which is two objects deep from the AP/PAP itself.
The trouble is, during compacting GC, we can only safely look one
object deep from the current object, because pointers from objects any
deeper might have been already updated to point to their final
destinations.

The solution is to put the arity and bitmap info for a BCO into the
BCO object itself.  This means BCOs become variable-length, which is a
slight annoyance, but it also means that looking up the arity/bitmap
is quicker.  There is a slight reduction in complexity in the byte
code generator due to not having to stuff the bitmap at the front of
the instruction stream.
  • Loading branch information...
1 parent 8238730 commit b3f530814c15886a7a010ed871bb1f054a3918b3 simonmar committed Mar 24, 2003
@@ -37,6 +37,7 @@ import Control.Monad.ST ( ST, runST )
import GHC.Word ( Word(..) )
import Data.Array.MArray
+import Data.Array.Unboxed ( listArray )
import Data.Array.Base ( STUArray, UArray(..), unsafeWrite )
import Data.Array.ST ( castSTUArray )
import Foreign ( Word16, free )
@@ -65,6 +66,7 @@ data UnlinkedBCO
unlinkedBCOName :: Name,
unlinkedBCOArity :: Int,
unlinkedBCOInstrs :: ByteArray#, -- insns
+ unlinkedBCOBitmap :: ByteArray#, -- bitmap
unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals
-- Either literal words or a pointer to a asciiz
-- string, denoting a label whose *address* should
@@ -84,15 +86,15 @@ bcoFreeNames :: UnlinkedBCO -> NameSet
bcoFreeNames bco
= bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
where
- bco_refs (UnlinkedBCO _ _ _ _ ptrs itbls)
+ bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
= unionManyNameSets (
mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
mkNameSet (ssElts itbls) :
map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
)
instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm arity insns lits ptrs itbls)
+ ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs",
@@ -148,11 +150,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
- | otherwise = runST (mkInstrArray arity bitmap
- bsize n_insns asm_insns)
+ | otherwise = mkInstrArray n_insns asm_insns
insns_barr = case insns_arr of UArray _lo _hi barr -> barr
- let ul_bco = UnlinkedBCO nm arity insns_barr final_lits
+ bitmap_arr = mkBitmapArray bsize bitmap
+ bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+
+ let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
final_ptrs final_itbls
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
@@ -165,25 +169,13 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
free ptr
+mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
+mkBitmapArray bsize bitmap
+ = listArray (0, 1 + length bitmap) (fromIntegral bsize : bitmap)
-mkInstrArray :: Int -> [StgWord] -> Int -> Int -> [Word16]
- -> ST s (UArray Int Word16)
-mkInstrArray arity bitmap bsize n_insns asm_insns = do
- (arr :: STUArray s Int Word16) <- newArray_ (0, n_insns + bco_info_w16s)
- zipWithM (unsafeWrite arr) [bco_info_w16s ..]
- (fromIntegral n_insns : asm_insns)
- (arr' :: STUArray s Int StgWord) <- castSTUArray arr
- writeArray arr' 0 (fromIntegral arity)
- writeArray arr' 1 (fromIntegral bsize)
- zipWithM (writeArray arr') [2..] bitmap
- arr <- castSTUArray arr'
- unsafeFreeze arr
- where
- -- The BCO info (arity, bitmap) goes at the beginning of
- -- the instruction stream. See Closures.h for details.
- bco_info_w16s = (1 {- for the arity -} +
- 1 {- for the bitmap size -} +
- length bitmap) * (wORD_SIZE `quot` 2)
+mkInstrArray :: Int -> [Word16] -> UArray Int Word16
+mkInstrArray n_insns asm_insns
+ = listArray (0, 1 + n_insns) (fromIntegral n_insns : asm_insns)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16,
@@ -39,7 +39,7 @@ import Control.Exception ( throwDyn )
import Control.Monad ( zipWithM )
import Control.Monad.ST ( stToIO )
-import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#,
+import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import GHC.Arr ( Array(..) )
@@ -103,7 +103,7 @@ linkBCO ie ce ul_bco
linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS)
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
-- Raises an IO exception on failure
= do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
@@ -129,7 +129,9 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS)
:: UArray Int Word
literals_barr = case literals_arr of UArray lo hi barr -> barr
- newBCO insns_barr literals_barr ptrs_parr itbls_barr
+ (I# arity#) = arity
+
+ newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
-- we recursively link any sub-BCOs while making the ptrs array
@@ -170,9 +172,11 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
data BCO = BCO BCO#
-newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
-newBCO a b c d
- = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
+newBCO :: ByteArray# -> ByteArray# -> Array# a
+ -> ByteArray# -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs itbls arity bitmap
+ = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
+ (# s1, bco #) -> (# s1, BCO bco #)
lookupLiteral :: Either Word FastString -> IO Word
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.25 2003/02/21 05:34:14 sof Exp $
+-- $Id: primops.txt.pp,v 1.26 2003/03/24 14:46:53 simonmar Exp $
--
-- Primitive Operations
--
@@ -1657,7 +1657,7 @@
out_of_line = True
primop NewBCOOp "newBCO#" GenPrimOp
- ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #)
+ ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #)
with
has_side_effects = True
out_of_line = True
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.32 2002/12/11 15:36:37 simonmar Exp $
+ * $Id: Closures.h,v 1.33 2003/03/24 14:46:53 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -204,32 +204,34 @@ typedef struct _StgDeadWeak { /* Weak v */
* A BCO represents either a function or a stack frame. In each case,
* it needs a bitmap to describe to the garbage collector the
* pointerhood of its arguments/free variables respectively, and in
- * the case of a function it also needs an arity. These pieces of
- * information are stored at the beginning of the instruction array.
+ * the case of a function it also needs an arity. These are stored
+ * directly in the BCO, rather than in the instrs array, for two
+ * reasons:
+ * (a) speed: we need to get at the bitmap info quickly when
+ * the GC is examining APs and PAPs that point to this BCO
+ * (b) a subtle interaction with the compacting GC. In compacting
+ * GC, the info that describes the size/layout of a closure
+ * cannot be in an object more than one level of indirection
+ * away from the current object, because of the order in
+ * which pointers are updated to point to their new locations.
*/
typedef struct {
StgHeader header;
- StgArrWords *instrs; /* a pointer to an ArrWords */
- StgArrWords *literals; /* a pointer to an ArrWords */
- StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */
- StgArrWords *itbls; /* a pointer to an ArrWords */
+ StgArrWords *instrs; // a pointer to an ArrWords
+ StgArrWords *literals; // a pointer to an ArrWords
+ StgMutArrPtrs *ptrs; // a pointer to a MutArrPtrs
+ StgArrWords *itbls; // a pointer to an ArrWords
+ StgHalfWord arity; // arity of this BCO
+ StgHalfWord size; // size of this BCO (in words)
+ StgWord bitmap[FLEXIBLE_ARRAY]; // an StgLargeBitmap
} StgBCO;
-typedef struct {
- StgWord arity;
- StgWord bitmap[FLEXIBLE_ARRAY]; // really an StgLargeBitmap
-} StgBCOInfo;
-
-#define BCO_INFO(bco) ((StgBCOInfo *)(((StgBCO *)(bco))->instrs->payload))
-#define BCO_ARITY(bco) (BCO_INFO(bco)->arity)
-#define BCO_BITMAP(bco) ((StgLargeBitmap *)BCO_INFO(bco)->bitmap)
+#define BCO_BITMAP(bco) ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap)
#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)
#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)
#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
/ BITS_IN(StgWord))
-#define BCO_INSTRS(bco) ((StgWord16 *)(BCO_BITMAP_BITS(bco) + \
- BCO_BITMAP_SIZEW(bco)))
/* Dynamic stack frames - these have a liveness mask in the object
* itself, rather than in the info table. Useful for generic heap
View
@@ -36,7 +36,7 @@
ProjectName = The Glorious Glasgow Haskell Compilation System
ProjectNameShort = ghc
-ProjectVersion = 5.05
+ProjectVersion = 5.05.20030323
ProjectVersionInt = 505
ProjectPatchLevel = 0
View
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.148 2003/03/19 18:41:18 sof Exp $
+ * $Id: GC.c,v 1.149 2003/03/24 14:46:53 simonmar Exp $
*
* (c) The GHC Team 1998-2003
*
@@ -1752,9 +1752,11 @@ evacuate(StgClosure *q)
case WEAK:
case FOREIGN:
case STABLE_NAME:
- case BCO:
return copy(q,sizeW_fromITBL(info),stp);
+ case BCO:
+ return copy(q,bco_sizeW((StgBCO *)q),stp);
+
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
case SE_BLACKHOLE:
@@ -2000,6 +2002,11 @@ eval_thunk_selector( nat field, StgSelector * p )
selector_loop:
+ if (Bdescr((StgPtr)selectee)->flags & BF_EVACUATED) {
+ SET_INFO(p, info_ptr);
+ return NULL;
+ }
+
info = get_itbl(selectee);
switch (info->type) {
case CONSTR:
@@ -2438,7 +2445,6 @@ scavenge(step *stp)
case WEAK:
case FOREIGN:
case STABLE_NAME:
- case BCO:
{
StgPtr end;
@@ -2450,6 +2456,16 @@ scavenge(step *stp)
break;
}
+ case BCO: {
+ StgBCO *bco = (StgBCO *)p;
+ (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+ (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+ (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+ (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+ p += bco_sizeW(bco);
+ break;
+ }
+
case IND_PERM:
if (stp->gen->no != 0) {
#ifdef PROFILING
@@ -2767,7 +2783,6 @@ scavenge_mark_stack(void)
case WEAK:
case FOREIGN:
case STABLE_NAME:
- case BCO:
{
StgPtr end;
@@ -2778,6 +2793,15 @@ scavenge_mark_stack(void)
break;
}
+ case BCO: {
+ StgBCO *bco = (StgBCO *)p;
+ (StgClosure *)bco->instrs = evacuate((StgClosure *)bco->instrs);
+ (StgClosure *)bco->literals = evacuate((StgClosure *)bco->literals);
+ (StgClosure *)bco->ptrs = evacuate((StgClosure *)bco->ptrs);
+ (StgClosure *)bco->itbls = evacuate((StgClosure *)bco->itbls);
+ break;
+ }
+
case IND_PERM:
// don't need to do anything here: the only possible case
// is that we're in a 1-space compacting collector, with
Oops, something went wrong.

0 comments on commit b3f5308

Please sign in to comment.