X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FStorage.c;h=a2c111bf8b23ca3a873b882d64383b6f80263061;hb=bc5c802181b513216bc88f0d1ec9574157ee05fe;hp=58edc40d9968703140cf5300738a068424dabf42;hpb=6d35596c37601a9bf608e32034c390d516454c29;p=ghc-hetmet.git

diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c
index 58edc40..a2c111b 100644
--- a/ghc/rts/Storage.c
+++ b/ghc/rts/Storage.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.36 2001/02/11 17:51:08 simonmar Exp $
+ * $Id: Storage.c,v 1.49 2001/08/14 13:40:09 sewardj Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -7,6 +7,7 @@
  *
  * ---------------------------------------------------------------------------*/
 
+#include "PosixSource.h"
 #include "Rts.h"
 #include "RtsUtils.h"
 #include "RtsFlags.h"
@@ -29,6 +30,7 @@ StgClosure    *caf_list         = NULL;
 
 bdescr *small_alloc_list;	/* allocate()d small objects */
 bdescr *large_alloc_list;	/* allocate()d large objects */
+bdescr *pinned_object_block;    /* allocate pinned objects into this block */
 nat alloc_blocks;		/* number of allocate()d blocks since GC */
 nat alloc_blocks_lim;		/* approximate limit on alloc_blocks */
 
@@ -58,7 +60,7 @@ static void *stgReallocForGMP (void *ptr, size_t old_size, size_t new_size);
 static void  stgDeallocForGMP (void *ptr, size_t size);
 
 void
-initStorage (void)
+initStorage( void )
 {
   nat g, s;
   step *stp;
@@ -68,6 +70,10 @@ initStorage (void)
    * fixed-size allocation area so that we get roughly even-spaced
    * samples.
    */
+
+  /* As an experiment, try a 2 generation collector
+   */
+
 #if defined(PROFILING) || defined(DEBUG)
   if (RtsFlags.ProfFlags.doHeapProfile) {
     RtsFlags.GcFlags.generations = 1;
@@ -77,7 +83,8 @@ initStorage (void)
   }
 #endif
 
-  if (RtsFlags.GcFlags.heapSizeSuggestion > 
+  if (RtsFlags.GcFlags.maxHeapSize != 0 &&
+      RtsFlags.GcFlags.heapSizeSuggestion > 
       RtsFlags.GcFlags.maxHeapSize) {
     RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
   }
@@ -135,14 +142,19 @@ initStorage (void)
       stp->blocks = NULL;
       stp->n_blocks = 0;
       stp->gen = &generations[g];
+      stp->gen_no = g;
       stp->hp = NULL;
       stp->hpLim = NULL;
       stp->hp_bd = NULL;
       stp->scan = NULL;
       stp->scan_bd = NULL;
       stp->large_objects = NULL;
+      stp->n_large_blocks = 0;
       stp->new_large_objects = NULL;
       stp->scavenged_large_objects = NULL;
+      stp->n_scavenged_large_blocks = 0;
+      stp->is_compacted = 0;
+      stp->bitmap = NULL;
     }
   }
   
@@ -154,8 +166,10 @@ initStorage (void)
     generations[g].steps[s].to = &generations[g+1].steps[0];
   }
   
-  /* The oldest generation has one step and its destination is the
-   * same step. */
+  /* The oldest generation has one step and it is compacted. */
+  if (RtsFlags.GcFlags.compact) {
+      oldest_gen->steps[0].is_compacted = 1;
+  }
   oldest_gen->steps[0].to = &oldest_gen->steps[0];
 
   /* generation 0 is special: that's the nursery */
@@ -187,7 +201,7 @@ initStorage (void)
   pthread_mutex_init(&sm_mutex, NULL);
 #endif
 
-  IF_DEBUG(gc, stat_describe_gens());
+  IF_DEBUG(gc, statDescribeGens());
 }
 
 void
@@ -260,6 +274,15 @@ newCAF(StgClosure* caf)
   }
 
   RELEASE_LOCK(&sm_mutex);
+
+#ifdef PAR
+  /* If we are PAR or DIST then  we never forget a CAF */
+  { globalAddr *newGA;
+    //belch("<##> Globalising CAF %08x %s",caf,info_type(caf));
+    newGA=makeGlobal(caf,rtsTrue); /*given full weight*/
+    ASSERT(newGA);
+  } 
+#endif /* PAR */
 }
 
 /* -----------------------------------------------------------------------------
@@ -280,7 +303,7 @@ allocNurseries( void )
       cap->rNursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
       cap->rCurrentNursery = cap->rNursery;
       for (bd = cap->rNursery; bd != NULL; bd = bd->link) {
-	bd->back = (bdescr *)cap;
+	bd->u.back = (bdescr *)cap;
       }
     }
     /* Set the back links to be equal to the Capability,
@@ -288,10 +311,11 @@ allocNurseries( void )
      */
   }
 #else /* SMP */
-  nursery_blocks  = RtsFlags.GcFlags.minAllocAreaSize;
-  g0s0->blocks    = allocNursery(NULL, nursery_blocks);
-  g0s0->n_blocks  = nursery_blocks;
-  g0s0->to_space  = NULL;
+  nursery_blocks    = RtsFlags.GcFlags.minAllocAreaSize;
+  g0s0->blocks      = allocNursery(NULL, nursery_blocks);
+  g0s0->n_blocks    = nursery_blocks;
+  g0s0->to_blocks   = NULL;
+  g0s0->n_to_blocks = 0;
   MainRegTable.rNursery        = g0s0->blocks;
   MainRegTable.rCurrentNursery = g0s0->blocks;
   /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
@@ -311,7 +335,7 @@ resetNurseries( void )
   for (cap = free_capabilities; cap != NULL; cap = cap->link) {
     for (bd = cap->rNursery; bd; bd = bd->link) {
       bd->free = bd->start;
-      ASSERT(bd->gen == g0);
+      ASSERT(bd->gen_no == 0);
       ASSERT(bd->step == g0s0);
       IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
     }
@@ -320,7 +344,7 @@ resetNurseries( void )
 #else
   for (bd = g0s0->blocks; bd; bd = bd->link) {
     bd->free = bd->start;
-    ASSERT(bd->gen == g0);
+    ASSERT(bd->gen_no == 0);
     ASSERT(bd->step == g0s0);
     IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
   }
@@ -340,8 +364,8 @@ allocNursery (bdescr *last_bd, nat blocks)
     bd = allocBlock();
     bd->link = last_bd;
     bd->step = g0s0;
-    bd->gen = g0;
-    bd->evacuated = 0;
+    bd->gen_no = 0;
+    bd->flags = 0;
     bd->free = bd->start;
     last_bd = bd;
   }
@@ -393,7 +417,7 @@ resizeNursery ( nat blocks )
    -------------------------------------------------------------------------- */
 
 StgPtr
-allocate(nat n)
+allocate( nat n )
 {
   bdescr *bd;
   StgPtr p;
@@ -409,9 +433,9 @@ allocate(nat n)
     nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
     bd = allocGroup(req_blocks);
     dbl_link_onto(bd, &g0s0->large_objects);
-    bd->gen  = g0;
+    bd->gen_no  = 0;
     bd->step = g0s0;
-    bd->evacuated = 0;
+    bd->flags = BF_LARGE;
     bd->free = bd->start;
     /* don't add these blocks to alloc_blocks, since we're assuming
      * that large objects are likely to remain live for quite a while
@@ -430,25 +454,85 @@ allocate(nat n)
     bd = allocBlock();
     bd->link = small_alloc_list;
     small_alloc_list = bd;
-    bd->gen = g0;
+    bd->gen_no = 0;
     bd->step = g0s0;
-    bd->evacuated = 0;
+    bd->flags = 0;
     alloc_Hp = bd->start;
     alloc_HpLim = bd->start + BLOCK_SIZE_W;
     alloc_blocks++;
   }
-  
+
   p = alloc_Hp;
   alloc_Hp += n;
   RELEASE_LOCK(&sm_mutex);
   return p;
 }
 
-lnat allocated_bytes(void)
+lnat
+allocated_bytes( void )
 {
   return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp));
 }
 
+/* ---------------------------------------------------------------------------
+   Allocate a fixed/pinned object.
+
+   We allocate small pinned objects into a single block, allocating a
+   new block when the current one overflows.  The block is chained
+   onto the large_object_list of generation 0 step 0.
+
+   NOTE: The GC can't in general handle pinned objects.  This
+   interface is only safe to use for ByteArrays, which have no
+   pointers and don't require scavenging.  It works because the
+   block's descriptor has the BF_LARGE flag set, so the block is
+   treated as a large object and chained onto various lists, rather
+   than the individual objects being copied.  However, when it comes
+   to scavenge the block, the GC will only scavenge the first object.
+   The reason is that the GC can't linearly scan a block of pinned
+   objects at the moment (doing so would require using the
+   mostly-copying techniques).  But since we're restricting ourselves
+   to pinned ByteArrays, not scavenging is ok.
+
+   This function is called by newPinnedByteArray# which immediately
+   fills the allocated memory with a MutableByteArray#.
+   ------------------------------------------------------------------------- */
+
+StgPtr
+allocatePinned( nat n )
+{
+    StgPtr p;
+    bdescr *bd = pinned_object_block;
+
+    ACQUIRE_LOCK(&sm_mutex);
+    
+    TICK_ALLOC_HEAP_NOCTR(n);
+    CCS_ALLOC(CCCS,n);
+
+    // If the request is for a large object, then allocate()
+    // will give us a pinned object anyway.
+    if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+	RELEASE_LOCK(&sm_mutex);
+	return allocate(n);
+    }
+
+    // If we don't have a block of pinned objects yet, or the current
+    // one isn't large enough to hold the new object, allocate a new one.
+    if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
+	pinned_object_block = bd = allocBlock();
+	dbl_link_onto(bd, &g0s0->large_objects);
+	bd->gen_no = 0;
+	bd->step   = g0s0;
+	bd->flags  = BF_LARGE;
+	bd->free   = bd->start;
+	alloc_blocks++;
+    }
+
+    p = bd->free;
+    bd->free += n;
+    RELEASE_LOCK(&sm_mutex);
+    return p;
+}
+
 /* -----------------------------------------------------------------------------
    Allocation functions for GMP.
 
@@ -573,7 +657,7 @@ calcLive(void)
   step *stp;
 
   if (RtsFlags.GcFlags.generations == 1) {
-    live = (g0s0->to_blocks - 1) * BLOCK_SIZE_W + 
+    live = (g0s0->n_to_blocks - 1) * BLOCK_SIZE_W + 
       ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
     return live;
   }
@@ -587,8 +671,11 @@ calcLive(void)
 	  continue; 
       }
       stp = &generations[g].steps[s];
-      live += (stp->n_blocks - 1) * BLOCK_SIZE_W +
-	((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) / sizeof(W_);
+      live += (stp->n_large_blocks + stp->n_blocks - 1) * BLOCK_SIZE_W;
+      if (stp->hp_bd != NULL) {
+	  live += ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start) 
+	      / sizeof(W_);
+      }
     }
   }
   return live;
@@ -604,22 +691,25 @@ calcLive(void)
 extern lnat 
 calcNeeded(void)
 {
-  lnat needed = 0;
-  nat g, s;
-  step *stp;
-
-  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-    for (s = 0; s < generations[g].n_steps; s++) {
-      if (g == 0 && s == 0) { continue; }
-      stp = &generations[g].steps[s];
-      if (generations[g].steps[0].n_blocks > generations[g].max_blocks) {
-	needed += 2 * stp->n_blocks;
-      } else {
-	needed += stp->n_blocks;
-      }
+    lnat needed = 0;
+    nat g, s;
+    step *stp;
+    
+    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+	for (s = 0; s < generations[g].n_steps; s++) {
+	    if (g == 0 && s == 0) { continue; }
+	    stp = &generations[g].steps[s];
+	    if (generations[g].steps[0].n_blocks +
+		generations[g].steps[0].n_large_blocks 
+		> generations[g].max_blocks
+		&& stp->is_compacted == 0) {
+		needed += 2 * stp->n_blocks;
+	    } else {
+		needed += stp->n_blocks;
+	    }
+	}
     }
-  }
-  return needed;
+    return needed;
 }
 
 /* -----------------------------------------------------------------------------
@@ -632,7 +722,7 @@ calcNeeded(void)
 
 #ifdef DEBUG
 
-extern void
+void
 memInventory(void)
 {
   nat g, s;
@@ -648,7 +738,7 @@ memInventory(void)
       total_blocks += stp->n_blocks;
       if (RtsFlags.GcFlags.generations == 1) {
 	/* two-space collector has a to-space too :-) */
-	total_blocks += g0s0->to_blocks;
+	total_blocks += g0s0->n_to_blocks;
       }
       for (bd = stp->large_objects; bd; bd = bd->link) {
 	total_blocks += bd->blocks;
@@ -675,45 +765,54 @@ memInventory(void)
   /* count the blocks on the free list */
   free_blocks = countFreeList();
 
-  ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
-
-#if 0
   if (total_blocks + free_blocks != mblocks_allocated *
       BLOCKS_PER_MBLOCK) {
     fprintf(stderr, "Blocks: %ld live + %ld free  = %ld total (%ld around)\n",
 	    total_blocks, free_blocks, total_blocks + free_blocks,
 	    mblocks_allocated * BLOCKS_PER_MBLOCK);
   }
-#endif
-}
 
-/* Full heap sanity check. */
+  ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
+}
 
-extern void
-checkSanity(nat N)
+static nat
+countBlocks(bdescr *bd)
 {
-  nat g, s;
-
-  if (RtsFlags.GcFlags.generations == 1) {
-    checkHeap(g0s0->to_space, NULL);
-    checkChain(g0s0->large_objects);
-  } else {
-    
-    for (g = 0; g <= N; g++) {
-      for (s = 0; s < generations[g].n_steps; s++) {
-	if (g == 0 && s == 0) { continue; }
-	checkHeap(generations[g].steps[s].blocks, NULL);
-      }
+    nat n;
+    for (n=0; bd != NULL; bd=bd->link) {
+	n += bd->blocks;
     }
-    for (g = N+1; g < RtsFlags.GcFlags.generations; g++) {
-      for (s = 0; s < generations[g].n_steps; s++) {
-	checkHeap(generations[g].steps[s].blocks,
-		  generations[g].steps[s].blocks->start);
-	checkChain(generations[g].steps[s].large_objects);
-      }
+    return n;
+}
+
+/* Full heap sanity check. */
+void
+checkSanity( void )
+{
+    nat g, s;
+
+    if (RtsFlags.GcFlags.generations == 1) {
+	checkHeap(g0s0->to_blocks);
+	checkChain(g0s0->large_objects);
+    } else {
+	
+	for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+	    for (s = 0; s < generations[g].n_steps; s++) {
+		if (g == 0 && s == 0) { continue; }
+		checkHeap(generations[g].steps[s].blocks);
+		checkChain(generations[g].steps[s].large_objects);
+		ASSERT(countBlocks(generations[g].steps[s].blocks)
+		       == generations[g].steps[s].n_blocks);
+		ASSERT(countBlocks(generations[g].steps[s].large_objects)
+		       == generations[g].steps[s].n_large_blocks);
+		if (g > 0) {
+		    checkMutableList(generations[g].mut_list, g);
+		    checkMutOnceList(generations[g].mut_once_list, g);
+		}
+	    }
+	}
+	checkFreeListSanity();
     }
-    checkFreeListSanity();
-  }
 }
 
 #endif