[project @ 2000-04-14 15:18:05 by sewardj]

[ghc-hetmet.git] / ghc / interpreter / storage.c

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index cdb519b..637c15b 100644 (file)
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.63 $
- * $Date: 2000/04/05 16:57:18 $
+ * $Revision: 1.71 $
+ * $Date: 2000/04/14 15:18:06 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -19,6 +19,7 @@
 #include "errors.h"
 #include "object.h"
 #include <setjmp.h>
+#include "Stg.h"
 
 /*#define DEBUG_SHOWUSE*/
 
@@ -523,7 +524,7 @@ static Bool debugStorageExtra = FALSE;
             newTab[i].inUse = FALSE;                                    \
             newTab[i].nextFree = i-1+TAB_BASE_ADDR;                     \
          }                                                              \
-         if (debugStorageExtra)                                         \
+         if (0 && debugStorageExtra)                                    \
             fprintf(stderr, "Expanding " #type_name                     \
                             "table to size %d\n", newSz );              \
          newTab[tab_size].nextFree = TAB_BASE_ADDR-1;                   \
@@ -1049,7 +1050,7 @@ Tycon addTupleTycon ( Int n )
 
    if (combined)
       m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
-      m = findModule(findText("PrimPrel"));
+      m = findModule(findText("PrelPrim"));
 
    setCurrModule(m);
    k = STAR;
@@ -1532,6 +1533,15 @@ List getAllKnownTyconsAndClasses ( void )
    return xs;
 }
 
+Int numQualifiers ( Type t )
+{
+   if (isPolyType(t)) t = monotypeOf(t);
+   if (isQualType(t)) 
+       return length ( fst(snd(t)) ); else
+       return 0;
+}
+
+
 /* Purely for debugging. */
 void locateSymbolByName ( Text t )
 {
@@ -1619,13 +1629,27 @@ Module newModule ( Text t )             /* add new module to module table  */
     return mod;
 }
 
+
+Bool nukeModule_needs_major_gc = TRUE;
+
 void nukeModule ( Module m )
 {
    ObjectCode* oc;
    ObjectCode* oc2;
    Int         i;
-assert(isModule(m));
-/*fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); */
+
+   if (!isModule(m)) internal("nukeModule");
+
+   /* fprintf ( stderr, "NUKE MODULE %s\n", textToStr(module(m).text) ); */
+
+   /* see comment in compiler.c about this, 
+      and interaction with info tables */
+   if (nukeModule_needs_major_gc) {
+      /* fprintf ( stderr, "doing major GC in nukeModule\n"); */
+      /* performMajorGC(); */
+      nukeModule_needs_major_gc = FALSE;
+   }
+
    oc = module(m).object;
    while (oc) {
       oc2 = oc->next;
@@ -1641,14 +1665,20 @@ assert(isModule(m));
 
    for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++)
       if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) {
-         if (name(i).itbl) free(name(i).itbl);
+         if (name(i).itbl && 
+             module(name(i).mod).mode == FM_SOURCE) {
+            free(name(i).itbl);
+         }
          name(i).itbl = NULL;
          freeName(i);
       }
 
    for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++)
       if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) {
-        if (tycon(i).itbl) free(tycon(i).itbl);
+         if (tycon(i).itbl &&
+             module(tycon(i).mod).mode == FM_SOURCE) {
+            free(tycon(i).itbl);
+         }
          tycon(i).itbl = NULL;
          freeTycon(i);
       }
@@ -1819,6 +1849,31 @@ void* lookupOExtraTabName ( char* sym )
 }
 
 
+/* Only call this if in dire straits; searches every object symtab
+   in the system -- so is therefore slow.
+*/
+void* lookupOTabNameAbsolutelyEverywhere ( char* sym )
+{
+   ObjectCode* oc;
+   Module      m;
+   void*       ad;
+   for (m = MODULE_BASE_ADDR; 
+        m < MODULE_BASE_ADDR+tabModuleSz; m++) {
+      if (tabModule[m-MODULE_BASE_ADDR].inUse) {
+         if (module(m).object) {
+            ad = ocLookupSym ( module(m).object, sym );
+            if (ad) return ad;
+         }
+         for (oc = module(m).objectExtras; oc; oc=oc->next) {
+            ad = ocLookupSym ( oc, sym );
+            if (ad) return ad;
+         }
+      }
+   }
+   return NULL;
+}
+
+
 OSectionKind lookupSection ( void* ad )
 {
    int          i;
@@ -2013,7 +2068,7 @@ Void garbageCollect()     {             /* Run garbage collector ...       */
     everybody(GCDONE);
 
 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
-    fprintf(stderr, "\n--- GC recovered %d\n",recovered );
+    /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
 #endif
 
     /* can only return if freeList is nonempty on return. */
@@ -2191,7 +2246,7 @@ Void print ( Cell c, Int depth )
     else if (isTagNonPtr(c)) {
         Printf("TagNP(%d)", c);
     }
-    else if (isSpec(c)) {
+    else if (isSpec(c) && c != STAR) {
         Printf("TagS(%d)", c);
     }
     else if (isText(c)) {
@@ -2677,6 +2732,7 @@ QualId qualidIsMember ( QualId q, List xs )
 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
 Text t;                                /* given list of variables          */
 List xs; {
+    assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
     for (; nonNull(xs); xs=tl(xs))
         if (t==textOf(hd(xs)))
             return hd(xs);
@@ -2954,6 +3010,27 @@ List args; {
  * debugging support
  * ------------------------------------------------------------------------*/
 
+/* Given the address of an info table, find the constructor/tuple
+   that it belongs to, and return the name.  Only needed for debugging.
+*/
+char* lookupHugsItblName ( void* v )
+{
+   int i;
+   for (i = TYCON_BASE_ADDR; 
+        i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
+      if (tabTycon[i-TYCON_BASE_ADDR].inUse
+          && tycon(i).itbl == v)
+         return textToStr(tycon(i).text);
+   }
+   for (i = NAME_BASE_ADDR; 
+        i < NAME_BASE_ADDR+tabNameSz; ++i) {
+      if (tabName[i-NAME_BASE_ADDR].inUse
+          && name(i).itbl == v)
+         return textToStr(name(i).text);
+   }
+   return NULL;
+}
+
 static String maybeModuleStr ( Module m )
 {
    if (isModule(m)) return textToStr(module(m).text); else return "??";