[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.

ghc/compiler/ghci/ByteCodeAsm.lhs

@@ -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, 

ghc/compiler/ghci/ByteCodeLink.lhs

@@ -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

ghc/compiler/prelude/primops.txt.pp

@@ -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

ghc/includes/Closures.h

@@ -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

ghc/mk/version.mk

@@ -36,7 +36,7 @@
 
 ProjectName       = The Glorious Glasgow Haskell Compilation System
 ProjectNameShort  = ghc
-ProjectVersion    = 5.05
+ProjectVersion = 5.05.20030323
 ProjectVersionInt = 505
 ProjectPatchLevel = 0
 

ghc/rts/GC.c

@@ -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