[project @ 2000-12-11 12:36:59 by simonmar]

[ghc-hetmet.git] / ghc / rts / Storage.c

diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c
index 3dd36f7..51e1fb0 100644 (file)
--- a/ghc/rts/Storage.c
+++ b/ghc/rts/Storage.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.23 2000/02/14 10:58:05 sewardj Exp $
+ * $Id: Storage.c,v 1.30 2000/12/11 12:37:00 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -14,7 +14,6 @@
 #include "Hooks.h"
 #include "BlockAlloc.h"
 #include "MBlock.h"
-#include "gmp.h"
 #include "Weak.h"
 #include "Sanity.h"
 
@@ -41,6 +40,8 @@ generation *g0;                       /* generation 0, for convenience */
 generation *oldest_gen;                /* oldest generation, for convenience */
 step *g0s0;                    /* generation 0, step 0, for convenience */
 
+lnat total_allocated = 0;      /* total memory allocated during run */
+
 /*
  * Storage manager mutex:  protects all the above state from
  * simultaneous access by two STG threads.
@@ -192,9 +193,28 @@ initStorage (void)
 void
 exitStorage (void)
 {
-  stat_exit(calcAllocated());
+    stat_exit(calcAllocated());
 }
 
+/* -----------------------------------------------------------------------------
+   Setting the heap size.  This function is callable from Haskell (GHC
+   uses it to implement the -H<size> option).
+   -------------------------------------------------------------------------- */
+
+void
+setHeapSize( HsInt size )
+{
+    RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE;
+    if (RtsFlags.GcFlags.heapSizeSuggestion > 
+       RtsFlags.GcFlags.maxHeapSize) {
+       RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   CAF management.
+   -------------------------------------------------------------------------- */
+
 void
 newCAF(StgClosure* caf)
 {
@@ -206,24 +226,78 @@ newCAF(StgClosure* caf)
    * any more and can use it as a STATIC_LINK.
    */
   ACQUIRE_LOCK(&sm_mutex);
+
+  ASSERT( ((StgMutClosure*)caf)->mut_link == NULL );
   ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
   oldest_gen->mut_once_list = (StgMutClosure *)caf;
 
-#ifdef DEBUG
-  { 
-    const StgInfoTable *info;
-    
-    info = get_itbl(caf);
-    ASSERT(info->type == IND_STATIC);
-#if 0
-    STATIC_LINK2(info,caf) = caf_list;
-    caf_list = caf;
-#endif
-  }
+#ifdef INTERPRETER
+  /* If we're Hugs, we also have to put it in the CAF table, so that
+     the CAF can be reverted.  When reverting, CAFs created by compiled
+     code are recorded in the CAF table, which lives outside the
+     heap, in mallocville.  CAFs created by interpreted code are
+     chained together via the link fields in StgCAFs, and are not
+     recorded in the CAF table.
+  */
+  ASSERT( get_itbl(caf)->type == THUNK_STATIC );
+  addToECafTable ( caf, get_itbl(caf) );
 #endif
+
   RELEASE_LOCK(&sm_mutex);
 }
 
+#ifdef INTERPRETER
+void
+newCAF_made_by_Hugs(StgCAF* caf)
+{
+  ACQUIRE_LOCK(&sm_mutex);
+
+  ASSERT( get_itbl(caf)->type == CAF_ENTERED );
+  recordOldToNewPtrs((StgMutClosure*)caf);
+  caf->link = ecafList;
+  ecafList = caf->link;
+
+  RELEASE_LOCK(&sm_mutex);
+}
+#endif
+
+#ifdef INTERPRETER
+/* These initialisations are critical for correct operation
+   on the first call of addToECafTable. 
+*/
+StgCAF*         ecafList      = END_ECAF_LIST;
+StgCAFTabEntry* ecafTable     = NULL;
+StgInt          usedECafTable = 0;
+StgInt          sizeECafTable = 0;
+
+
+void clearECafTable ( void )
+{
+   usedECafTable = 0;
+}
+
+void addToECafTable ( StgClosure* closure, StgInfoTable* origItbl )
+{
+   StgInt          i;
+   StgCAFTabEntry* et2;
+   if (usedECafTable == sizeECafTable) {
+      /* Make the initial table size be 8 */
+      sizeECafTable *= 2;
+      if (sizeECafTable == 0) sizeECafTable = 8;
+      et2 = stgMallocBytes ( 
+               sizeECafTable * sizeof(StgCAFTabEntry),
+               "addToECafTable" );
+      for (i = 0; i < usedECafTable; i++) 
+         et2[i] = ecafTable[i];
+      if (ecafTable) free(ecafTable);
+      ecafTable = et2;
+   }
+   ecafTable[usedECafTable].closure  = closure;
+   ecafTable[usedECafTable].origItbl = origItbl;
+   usedECafTable++;
+}
+#endif
+
 /* -----------------------------------------------------------------------------
    Nursery management.
    -------------------------------------------------------------------------- */
@@ -380,6 +454,7 @@ allocate(nat n)
      * (eg. running threads), so garbage collecting early won't make
      * much difference.
      */
+    alloc_blocks += req_blocks;
     RELEASE_LOCK(&sm_mutex);
     return bd->start;
 
@@ -435,7 +510,7 @@ stgAllocForGMP (size_t size_in_bytes)
   
   /* allocate and fill it in. */
   arr = (StgArrWords *)allocate(total_size_in_words);
-  SET_ARR_HDR(arr, &ARR_WORDS_info, CCCS, data_size_in_words);
+  SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
   
   /* and return a ptr to the goods inside the array */
   return(BYTE_ARR_CTS(arr));
@@ -519,6 +594,7 @@ calcAllocated( void )
   }
 #endif
 
+  total_allocated += allocated;
   return allocated;
 }