ghc/interpreter/storage.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Primitives for manipulating global data structures
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: storage.c,v $
  12  * $Revision: 1.75 $
  13  * $Date: 2000/05/09 17:38:19 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "hugsbasictypes.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20 #include "object.h"
  21 #include <setjmp.h>
  22 #include "Stg.h"
  23
  24 /*#define DEBUG_SHOWUSE*/
  25
  26 /* --------------------------------------------------------------------------
  27  * local function prototypes:
  28  * ------------------------------------------------------------------------*/
  29
  30 static Int    local hash                ( String );
  31 static Int    local saveText            ( Text );
  32 static Module local findQualifier       ( Text );
  33 static Void   local hashTycon           ( Tycon );
  34 static List   local insertTycon         ( Tycon,List );
  35 static Void   local hashName            ( Name );
  36 static List   local insertName          ( Name,List );
  37 static Void   local patternError        ( String );
  38 static Bool   local stringMatch         ( String,String );
  39 static Bool   local typeInvolves        ( Type,Type );
  40 static Cell   local markCell            ( Cell );
  41 static Void   local markSnd             ( Cell );
  42 static Cell   local lowLevelLastIn      ( Cell );
  43 static Cell   local lowLevelLastOut     ( Cell );
  44
  45
  46 /* --------------------------------------------------------------------------
  47  * Text storage:
  48  *
  49  * provides storage for the characters making up identifier and symbol
  50  * names, string literals, character constants etc...
  51  *
  52  * All character strings are stored in a large character array, with textHw
  53  * pointing to the next free position.  Lookup in the array is improved using
  54  * a hash table.  Internally, text strings are represented by integer offsets
  55  * from the beginning of the array to the string in question.
  56  *
  57  * Where memory permits, the use of multiple hashtables gives a significant
  58  * increase in performance, particularly when large source files are used.
  59  *
  60  * Each string in the array is terminated by a zero byte.  No string is
  61  * stored more than once, so that it is safe to test equality of strings by
  62  * comparing the corresponding offsets.
  63  *
  64  * Special text values (beyond the range of the text array table) are used
  65  * to generate unique `new variable names' as required.
  66  *
  67  * The same text storage is also used to hold text values stored in a saved
  68  * expression.  This grows downwards from the top of the text table (and is
  69  * not included in the hash table).
  70  * ------------------------------------------------------------------------*/
  71
  72 #define TEXTHSZ 512                     /* Size of Text hash table         */
  73 #define NOTEXT  ((Text)(~0))            /* Empty bucket in Text hash table */
  74 static  Text    textHw;                 /* Next unused position            */
  75 static  Text    savedText = TEXT_SIZE;  /* Start of saved portion of text  */
  76 static  Text    nextNewText;            /* Next new text value             */
  77 static  Text    nextNewDText;           /* Next new dict text value        */
  78 static  char    text[TEXT_SIZE];        /* Storage of character strings    */
  79 static  Text    textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage        */
  80
  81 String textToStr(t)                    /* find string corresp to given Text*/
  82 Text t; {
  83     static char newVar[16];
  84
  85     if (isText(t))                              /* standard char string    */
  86         return text + t - TEXT_BASE_ADDR;
  87     if (isInventedDictVar(t)) {
  88         sprintf(newVar,"d%d",
  89                 t-INDVAR_BASE_ADDR);            /* dictionary variable     */
  90         return newVar;
  91     }
  92     if (isInventedVar(t)) {
  93         sprintf(newVar,"v%d",
  94                 t-INVAR_BASE_ADDR);             /* normal variable         */
  95        return newVar;
  96     }
  97     internal("textToStr");
  98 }
  99
 100 String identToStr(v) /*find string corresp to given ident or qualified name*/
 101 Cell v; {
 102     if (!isPair(v)) {
 103         internal("identToStr");
 104     }
 105     switch (whatIs(v)) {
 106         case VARIDCELL  :
 107         case VAROPCELL  :
 108         case CONIDCELL  :
 109         case CONOPCELL  : return textToStr(textOf(v));
 110
 111         case QUALIDENT  : {   String qmod = textToStr(qmodOf(v));
 112                               String qtext = textToStr(qtextOf(v));
 113                               Text pos = textHw;
 114
 115                               while (pos+1 < savedText && *qmod!=0) {
 116                                   text[pos++] = *qmod++;
 117                               }
 118                               if (pos+1 < savedText) {
 119                                   text[pos++] = '.';
 120                               }
 121                               while (pos+1 < savedText && *qtext!=0) {
 122                                   text[pos++] = *qtext++;
 123                               }
 124                               text[pos] = '\0';
 125                               return text+textHw;
 126                           }
 127     }
 128     internal("identToStr2");
 129     return 0; /* NOTREACHED */
 130 }
 131
 132 Text inventText()     {                 /* return new unused variable name */
 133    if (nextNewText >= INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
 134       internal("inventText: too many invented variables");
 135    return nextNewText++;
 136 }
 137
 138 Text inventDictText() {                 /* return new unused dictvar name  */
 139    if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
 140      internal("inventDictText: too many invented variables");
 141    return nextNewDText++;
 142 }
 143
 144 Bool inventedText(t)                    /* Signal TRUE if text has been    */
 145 Text t; {                               /* generated internally            */
 146     return isInventedVar(t) || isInventedDictVar(t);
 147 }
 148
 149 #define MAX_FIXLIT 100
 150 Text fixLitText(t)                /* fix literal text that might include \ */
 151 Text t; {
 152     String   s = textToStr(t);
 153     char     p[MAX_FIXLIT];
 154     Int      i;
 155     for(i = 0;i < MAX_FIXLIT-2 && *s;s++) {
 156       p[i++] = *s;
 157       if (*s == '\\') {
 158         p[i++] = '\\';
 159       }
 160     }
 161     if (i < MAX_FIXLIT-2) {
 162       p[i] = 0;
 163     } else {
 164         ERRMSG(0) "storage space exhausted for internal literal string"
 165         EEND;
 166     }
 167     return (findText(p));
 168 }
 169 #undef MAX_FIXLIT
 170
 171 static Int local hash(s)                /* Simple hash function on strings */
 172 String s; {
 173     int v, j = 3;
 174
 175     for (v=((int)(*s))*8; *s; s++)
 176         v += ((int)(*s))*(j++);
 177     if (v<0)
 178         v = (-v);
 179     return(v%TEXTHSZ);
 180 }
 181
 182 Text findText(s)                       /* Locate string in Text array      */
 183 String s; {
 184     int    h       = hash(s);
 185     int    hashno  = 0;
 186     Text   textPos = textHash[h][hashno];
 187
 188 #   define TryMatch     {   Text   originalTextPos = textPos;              \
 189                             String t;                                      \
 190                             for (t=s; *t==text[textPos]; textPos++,t++)    \
 191                                 if (*t=='\0')                              \
 192                                     return originalTextPos+TEXT_BASE_ADDR; \
 193                         }
 194 #   define Skip         while (text[textPos++]) ;
 195
 196     while (textPos!=NOTEXT) {
 197         TryMatch
 198         if (++hashno<NUM_TEXTH)         /* look in next hashtable entry    */
 199             textPos = textHash[h][hashno];
 200         else {
 201             Skip
 202             while (textPos < textHw) {
 203                 TryMatch
 204                 Skip
 205             }
 206             break;
 207         }
 208     }
 209
 210 #undef TryMatch
 211 #undef Skip
 212
 213     textPos = textHw;                  /* if not found, save in array      */
 214     if (textHw + (Int)strlen(s) + 1 > savedText) {
 215         ERRMSG(0) "Character string storage space exhausted"
 216         EEND;
 217     }
 218     while ((text[textHw++] = *s++) != 0) {
 219     }
 220     if (hashno<NUM_TEXTH) {            /* updating hash table as necessary */
 221         textHash[h][hashno] = textPos;
 222         if (hashno<NUM_TEXTH-1)
 223             textHash[h][hashno+1] = NOTEXT;
 224     }
 225
 226     return textPos+TEXT_BASE_ADDR;
 227 }
 228
 229 static Int local saveText(t)            /* Save text value in buffer       */
 230 Text t; {                               /* at top of text table            */
 231     String s = textToStr(t);
 232     Int    l = strlen(s);
 233     if (textHw + l + 1 > savedText) {
 234         ERRMSG(0) "Character string storage space exhausted"
 235         EEND;
 236     }
 237     savedText -= l+1;
 238     strcpy(text+savedText,s);
 239     return savedText;
 240 }
 241
 242
 243 static int fromHexDigit ( char c )
 244 {
 245    switch (c) {
 246       case '0': case '1': case '2': case '3': case '4':
 247       case '5': case '6': case '7': case '8': case '9':
 248          return c - '0';
 249       case 'a': case 'A': return 10;
 250       case 'b': case 'B': return 11;
 251       case 'c': case 'C': return 12;
 252       case 'd': case 'D': return 13;
 253       case 'e': case 'E': return 14;
 254       case 'f': case 'F': return 15;
 255       default: return -1;
 256    }
 257 }
 258
 259
 260 /* returns findText (unZencode s) */
 261 Text unZcodeThenFindText ( String s )
 262 {
 263    unsigned char* p;
 264    Int            n, nn, i;
 265    Text           t;
 266
 267    assert(s);
 268    nn = 100 + 10 * strlen(s);
 269    p = malloc ( nn );
 270    if (!p) internal ("unZcodeThenFindText: malloc failed");
 271    n = 0;
 272
 273    while (1) {
 274       if (!(*s)) break;
 275       if (n > nn-90) internal ("unZcodeThenFindText: result is too big");
 276       if (*s != 'z' && *s != 'Z') {
 277          p[n] = *s; n++; s++;
 278          continue;
 279       }
 280       s++;
 281       if (!(*s)) goto parse_error;
 282       switch (*s++) {
 283          case 'Z': p[n++] = 'Z'; break;
 284          case 'C': p[n++] = ':'; break;
 285          case 'L': p[n++] = '('; break;
 286          case 'R': p[n++] = ')'; break;
 287          case 'M': p[n++] = '['; break;
 288          case 'N': p[n++] = ']'; break;
 289          case 'z': p[n++] = 'z'; break;
 290          case 'a': p[n++] = '&'; break;
 291          case 'b': p[n++] = '|'; break;
 292          case 'd': p[n++] = '$'; break;
 293          case 'e': p[n++] = '='; break;
 294          case 'g': p[n++] = '>'; break;
 295          case 'h': p[n++] = '#'; break;
 296          case 'i': p[n++] = '.'; break;
 297          case 'l': p[n++] = '<'; break;
 298          case 'm': p[n++] = '-'; break;
 299          case 'n': p[n++] = '!'; break;
 300          case 'p': p[n++] = '+'; break;
 301          case 'q': p[n++] = '\\'; break;
 302          case 'r': p[n++] = '\''; break;
 303          case 's': p[n++] = '/'; break;
 304          case 't': p[n++] = '*'; break;
 305          case 'u': p[n++] = '^'; break;
 306          case 'v': p[n++] = '%'; break;
 307          case 'x':
 308             if (!s[0] || !s[1]) goto parse_error;
 309             if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error;
 310             p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]);
 311             p += 2; s += 2;
 312             break;
 313          case '0': case '1': case '2': case '3': case '4':
 314          case '5': case '6': case '7': case '8': case '9':
 315             i = 0;
 316             s--;
 317             while (*s && isdigit((int)(*s))) {
 318                i = 10 * i + (*s - '0');
 319                s++;
 320             }
 321             if (*s != 'T') goto parse_error;
 322             s++;
 323             p[n++] = '(';
 324             while (i > 0) { p[n++] = ','; i--; };
 325             p[n++] = ')';
 326             break;
 327          default:
 328             goto parse_error;
 329       }
 330    }
 331    p[n] = 0;
 332    t = findText(p);
 333    free(p);
 334    return t;
 335
 336   parse_error:
 337    free(p);
 338    fprintf ( stderr, "\nstring = `%s'\n", s );
 339    internal ( "unZcodeThenFindText: parse error on above string");
 340    return NIL; /*notreached*/
 341 }
 342
 343
 344 Text enZcodeThenFindText ( String s )
 345 {
 346    unsigned char* p;
 347    Int            n, nn;
 348    Text           t;
 349    char toHex[16] = "0123456789ABCDEF";
 350
 351    assert(s);
 352    nn = 100 + 10 * strlen(s);
 353    p = malloc ( nn );
 354    if (!p) internal ("enZcodeThenFindText: malloc failed");
 355    n = 0;
 356    while (1) {
 357       if (!(*s)) break;
 358       if (n > nn-90) internal ("enZcodeThenFindText: result is too big");
 359       if (*s != 'z'
 360           && *s != 'Z'
 361           && (isalnum((int)(*s)) || *s == '_')) {
 362          p[n] = *s; n++; s++;
 363          continue;
 364       }
 365       if (*s == '(') {
 366          int tup = 0;
 367          char num[12];
 368          s++;
 369          while (*s && *s==',') { s++; tup++; };
 370          if (*s != ')') internal("enZcodeThenFindText: invalid tuple type");
 371          s++;
 372          p[n++] = 'Z';
 373          sprintf(num,"%d",tup);
 374          p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num);
 375          p[n++] = 'T';
 376          continue;
 377       }
 378       switch (*s++) {
 379          case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
 380          case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
 381          case '[': p[n++] = 'Z'; p[n++] = 'M'; break;
 382          case ']': p[n++] = 'Z'; p[n++] = 'N'; break;
 383          case ':': p[n++] = 'Z'; p[n++] = 'C'; break;
 384          case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break;
 385          case 'z': p[n++] = 'z'; p[n++] = 'z'; break;
 386          case '&': p[n++] = 'z'; p[n++] = 'a'; break;
 387          case '|': p[n++] = 'z'; p[n++] = 'b'; break;
 388          case '$': p[n++] = 'z'; p[n++] = 'd'; break;
 389          case '=': p[n++] = 'z'; p[n++] = 'e'; break;
 390          case '>': p[n++] = 'z'; p[n++] = 'g'; break;
 391          case '#': p[n++] = 'z'; p[n++] = 'h'; break;
 392          case '.': p[n++] = 'z'; p[n++] = 'i'; break;
 393          case '<': p[n++] = 'z'; p[n++] = 'l'; break;
 394          case '-': p[n++] = 'z'; p[n++] = 'm'; break;
 395          case '!': p[n++] = 'z'; p[n++] = 'n'; break;
 396          case '+': p[n++] = 'z'; p[n++] = 'p'; break;
 397          case '\'': p[n++] = 'z'; p[n++] = 'q'; break;
 398          case '\\': p[n++] = 'z'; p[n++] = 'r'; break;
 399          case '/': p[n++] = 'z'; p[n++] = 's'; break;
 400          case '*': p[n++] = 'z'; p[n++] = 't'; break;
 401          case '^': p[n++] = 'z'; p[n++] = 'u'; break;
 402          case '%': p[n++] = 'z'; p[n++] = 'v'; break;
 403          default: s--; p[n++] = 'z'; p[n++] = 'x';
 404                        p[n++] = toHex[(int)(*s)/16];
 405                        p[n++] = toHex[(int)(*s)%16];
 406                   s++; break;
 407       }
 408    }
 409    p[n] = 0;
 410    t = findText(p);
 411    free(p);
 412    return t;
 413 }
 414
 415
 416 Text textOf ( Cell c )
 417 {
 418    Int  wot = whatIs(c);
 419    Bool ok =
 420           (wot==VARIDCELL
 421            || wot==CONIDCELL
 422            || wot==VAROPCELL
 423            || wot==CONOPCELL
 424            || wot==STRCELL
 425            || wot==DICTVAR
 426            || wot==IPCELL
 427            || wot==IPVAR
 428           );
 429    if (!ok) {
 430       fprintf(stderr, "\ntextOf: bad tag %d\n",wot );
 431       internal("textOf: bad tag");
 432    }
 433    return snd(c);
 434 }
 435
 436 /* --------------------------------------------------------------------------
 437  * Ext storage:
 438  *
 439  * Currently, the only attributes that we store for each Ext value is the
 440  * corresponding Text label.  At some later stage, we may decide to cache
 441  * types, predicates, etc. here as a space saving gesture.  Given that Text
 442  * comparison is cheap, and that this is an experimental implementation, we
 443  * will use a straightforward linear search to locate Ext values from their
 444  * corresponding Text labels; a hashing scheme can be introduced later if
 445  * this turns out to be a problem.
 446  * ------------------------------------------------------------------------*/
 447
 448 #if TREX
 449 Text  DEFTABLE(tabExt,NUM_EXT);         /* Storage for Ext names           */
 450 Ext   extHw;
 451
 452 Ext mkExt(t)                            /* Allocate or find an Ext value   */
 453 Text t; {
 454     Ext e = EXTMIN;
 455     for (; e<extHw; e++)
 456         if (t==extText(e))
 457             return e;
 458     if (extHw-EXTMIN >= NUM_EXT) {
 459         ERRMSG(0) "Ext storage space exhausted"
 460         EEND;
 461     }
 462     extText(extHw) = t;
 463     return extHw++;
 464 }
 465 #endif
 466
 467
 468 /* --------------------------------------------------------------------------
 469  * Expandable symbol tables.  A template, which is instantiated for the name,
 470  * tycon, class, instance and module tables.  Also, potentially, TREX Exts.
 471  * ------------------------------------------------------------------------*/
 472
 473 #ifdef DEBUG_STORAGE_EXTRA
 474 static Bool debugStorageExtra = TRUE;
 475 #else
 476 static Bool debugStorageExtra = FALSE;
 477 #endif
 478
 479
 480 #define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name,                  \
 481                                 proc_name,free_proc_name,               \
 482                                 free_list,tab_name,tab_size,err_msg,    \
 483                                 TAB_INIT_SIZE,TAB_MAX_SIZE,             \
 484                                 TAB_BASE_ADDR)                          \
 485                                                                         \
 486              struct struct_name* tab_name  = NULL;                      \
 487              int                 tab_size  = 0;                         \
 488       static type_name           free_list = TAB_BASE_ADDR-1;           \
 489                                                                         \
 490       void free_proc_name ( type_name n )                               \
 491       {                                                                 \
 492          assert(TAB_BASE_ADDR <= n);                                    \
 493          assert(n < TAB_BASE_ADDR+tab_size);                            \
 494          assert(tab_name[n-TAB_BASE_ADDR].inUse);                       \
 495          tab_name[n-TAB_BASE_ADDR].inUse = FALSE;                       \
 496          if (!debugStorageExtra) {                                      \
 497             tab_name[n-TAB_BASE_ADDR].nextFree = free_list;             \
 498             free_list = n;                                              \
 499          }                                                              \
 500       }                                                                 \
 501                                                                         \
 502       type_name proc_name ( void )                                      \
 503       {                                                                 \
 504          Int    i;                                                      \
 505          Int    newSz;                                                  \
 506          struct struct_name* newTab;                                    \
 507          struct struct_name* temp;                                      \
 508          try_again:                                                     \
 509          if (free_list != TAB_BASE_ADDR-1) {                            \
 510             type_name t = free_list;                                    \
 511             free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree;     \
 512             assert (!(tab_name[t-TAB_BASE_ADDR].inUse));                \
 513             tab_name[t-TAB_BASE_ADDR].inUse = TRUE;                     \
 514             return t;                                                   \
 515          }                                                              \
 516                                                                         \
 517          newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size);        \
 518          if (newSz > TAB_MAX_SIZE) goto cant_allocate;                  \
 519          newTab = malloc(newSz * sizeof(struct struct_name));           \
 520          if (!newTab) goto cant_allocate;                               \
 521          for (i = 0; i < tab_size; i++)                                 \
 522             newTab[i] = tab_name[i];                                    \
 523          for (i = tab_size; i < newSz; i++) {                           \
 524             newTab[i].inUse = FALSE;                                    \
 525             newTab[i].nextFree = i-1+TAB_BASE_ADDR;                     \
 526          }                                                              \
 527          if (0 && debugStorageExtra)                                    \
 528             fprintf(stderr, "Expanding " #type_name                     \
 529                             "table to size %d\n", newSz );              \
 530          newTab[tab_size].nextFree = TAB_BASE_ADDR-1;                   \
 531          free_list = newSz-1+TAB_BASE_ADDR;                             \
 532          tab_size = newSz;                                              \
 533          temp = tab_name;                                               \
 534          tab_name = newTab;                                             \
 535          if (temp) free(temp);                                          \
 536          goto try_again;                                                \
 537                                                                         \
 538          cant_allocate:                                                 \
 539          ERRMSG(0) err_msg                                              \
 540          EEND;                                                          \
 541       }                                                                 \
 542
 543
 544
 545 EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName,
 546                         nameFL,tabName,tabNameSz,
 547                         "Name storage space exhausted",
 548                         NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR)
 549
 550
 551 EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon,
 552                         tyconFL,tabTycon,tabTyconSz,
 553                         "Type constructor storage space exhausted",
 554                         TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR)
 555
 556
 557 EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass,
 558                         classFL,tabClass,tabClassSz,
 559                         "Class storage space exhausted",
 560                         CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR)
 561
 562
 563 EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst,
 564                         instFL,tabInst,tabInstSz,
 565                         "Instance storage space exhausted",
 566                         INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR)
 567
 568
 569 EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule,
 570                         moduleFL,tabModule,tabModuleSz,
 571                         "Module storage space exhausted",
 572                         MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR)
 573
 574 #ifdef DEBUG_STORAGE
 575 struct strName* generate_name_ref ( Cell nm )
 576 {
 577    assert(isName(nm));
 578    nm -= NAME_BASE_ADDR;
 579    assert(tabName[nm].inUse);
 580    assert(isModule(tabName[nm].mod));
 581    return & tabName[nm];
 582 }
 583 struct strTycon* generate_tycon_ref ( Cell tc )
 584 {
 585    assert(isTycon(tc) || isTuple(tc));
 586    tc -= TYCON_BASE_ADDR;
 587    assert(tabTycon[tc].inUse);
 588    assert(isModule(tabTycon[tc].mod));
 589    return & tabTycon[tc];
 590 }
 591 struct strClass* generate_cclass_ref ( Cell cl )
 592 {
 593    assert(isClass(cl));
 594    cl -= CCLASS_BASE_ADDR;
 595    assert(tabClass[cl].inUse);
 596    assert(isModule(tabClass[cl].mod));
 597    return & tabClass[cl];
 598 }
 599 struct strInst* generate_inst_ref ( Cell in )
 600 {
 601    assert(isInst(in));
 602    in -= INST_BASE_ADDR;
 603    assert(tabInst[in].inUse);
 604    assert(isModule(tabInst[in].mod));
 605    return & tabInst[in];
 606 }
 607 struct strModule* generate_module_ref ( Cell mo )
 608 {
 609    assert(isModule(mo));
 610    mo -= MODULE_BASE_ADDR;
 611    assert(tabModule[mo].inUse);
 612    return & tabModule[mo];
 613 }
 614 #endif
 615
 616
 617 /* --------------------------------------------------------------------------
 618  * Tycon storage:
 619  *
 620  * A Tycon represents a user defined type constructor.  Tycons are indexed
 621  * by Text values ... a very simple hash function is used to improve lookup
 622  * times.  Tycon entries with the same hash code are chained together, with
 623  * the most recent entry at the front of the list.
 624  * ------------------------------------------------------------------------*/
 625
 626 #define TYCONHSZ 256                            /* Size of Tycon hash table*/
 627 static  Tycon    tyconHash[TYCONHSZ];           /* Hash table storage      */
 628
 629 static int tHash(Text x)
 630 {
 631    int r;
 632    assert(isText(x) || inventedText(x));
 633    x -= TEXT_BASE_ADDR;
 634    if (x < 0) x = -x;
 635    r= x%TYCONHSZ;
 636    assert(r>=0);
 637    assert(r<TYCONHSZ);
 638    return r;
 639 }
 640
 641 static int RC_T ( int x )
 642 {
 643    assert (x >= 0 && x < TYCONHSZ);
 644    return x;
 645 }
 646
 647 Tycon newTycon ( Text t )               /* add new tycon to tycon table    */
 648 {
 649     Int   h                      = tHash(t);
 650     Tycon tc                     = allocNewTycon();
 651     tabTycon
 652       [tc-TYCON_BASE_ADDR].tuple = -1;
 653     tabTycon
 654       [tc-TYCON_BASE_ADDR].mod   = currentModule;
 655     tycon(tc).text               = t;   /* clear new tycon record          */
 656     tycon(tc).kind               = NIL;
 657     tycon(tc).defn               = NIL;
 658     tycon(tc).what               = NIL;
 659     tycon(tc).conToTag           = NIL;
 660     tycon(tc).tagToCon           = NIL;
 661     tycon(tc).itbl               = NULL;
 662     tycon(tc).arity              = 0;
 663     tycon(tc).closure            = NIL;
 664     module(currentModule).tycons = cons(tc,module(currentModule).tycons);
 665     tycon(tc).nextTyconHash      = tyconHash[RC_T(h)];
 666     tyconHash[RC_T(h)]                 = tc;
 667     return tc;
 668 }
 669
 670 Tycon findTycon(t)                      /* locate Tycon in tycon table     */
 671 Text t; {
 672     Tycon tc = tyconHash[RC_T(tHash(t))];
 673     assert(isTycon(tc) || isTuple(tc) || isNull(tc));
 674     while (nonNull(tc) && tycon(tc).text!=t)
 675         tc = tycon(tc).nextTyconHash;
 676     return tc;
 677 }
 678
 679 Tycon addTycon(tc)  /* Insert Tycon in tycon table - if no clash is caused */
 680 Tycon tc; {
 681     Tycon oldtc;
 682     assert(isTycon(tc) || isTuple(tc));
 683     oldtc = findTycon(tycon(tc).text);
 684     if (isNull(oldtc)) {
 685         hashTycon(tc);
 686         module(currentModule).tycons=cons(tc,module(currentModule).tycons);
 687         return tc;
 688     } else
 689         return oldtc;
 690 }
 691
 692 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 693 Tycon tc; {
 694    Text t;
 695    Int  h;
 696    assert(isTycon(tc) || isTuple(tc));
 697    {int i; for (i = 0; i < TYCONHSZ; i++)
 698        assert (tyconHash[i] == 0
 699                || isTycon(tyconHash[i])
 700                || isTuple(tyconHash[i]));
 701    }
 702    t = tycon(tc).text;
 703    h = tHash(t);
 704    tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
 705    tyconHash[RC_T(h)]            = tc;
 706 }
 707
 708 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
 709 Cell id; {
 710     if (!isPair(id)) internal("findQualTycon");
 711     switch (fst(id)) {
 712         case CONIDCELL :
 713         case CONOPCELL :
 714             return findTycon(textOf(id));
 715         case QUALIDENT : {
 716             Text   t  = qtextOf(id);
 717             Module m  = findQualifier(qmodOf(id));
 718             List   es = NIL;
 719             if (isNull(m)) return NIL;
 720             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 721                 Cell e = hd(es);
 722                 if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
 723                     return fst(e);
 724             }
 725             return NIL;
 726         }
 727         default : internal("findQualTycon2");
 728     }
 729     return NIL; /* NOTREACHED */
 730 }
 731
 732 Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr   */
 733 Text t;
 734 Kind kind;
 735 Int  ar;
 736 Cell what;
 737 Cell defn; {
 738     Tycon tc        = newTycon(t);
 739     tycon(tc).line  = 0;
 740     tycon(tc).kind  = kind;
 741     tycon(tc).what  = what;
 742     tycon(tc).defn  = defn;
 743     tycon(tc).arity = ar;
 744     return tc;
 745 }
 746
 747 static List local insertTycon(tc,ts)    /* insert tycon tc into sorted list*/
 748 Tycon tc;                               /* ts                              */
 749 List  ts; {
 750     Cell   prev = NIL;
 751     Cell   curr = ts;
 752     String s    = textToStr(tycon(tc).text);
 753
 754     while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
 755         if (hd(curr)==tc)               /* just in case we get duplicates! */
 756             return ts;
 757         prev = curr;
 758         curr = tl(curr);
 759     }
 760     if (nonNull(prev)) {
 761         tl(prev) = cons(tc,curr);
 762         return ts;
 763     }
 764     else
 765         return cons(tc,curr);
 766 }
 767
 768 List addTyconsMatching(pat,ts)          /* Add tycons matching pattern pat */
 769 String pat;                             /* to list of Tycons ts            */
 770 List   ts; {                            /* Null pattern matches every tycon*/
 771     Tycon tc;                           /* (Tycons with NIL kind excluded) */
 772     for (tc = TYCON_BASE_ADDR;
 773          tc < TYCON_BASE_ADDR+tabTyconSz; ++tc)
 774         if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
 775            if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
 776                if (nonNull(tycon(tc).kind))
 777                   ts = insertTycon(tc,ts);
 778     return ts;
 779 }
 780
 781 Text ghcTupleText_n ( Int n )
 782 {
 783     Int i;
 784     Int x = 0;
 785     char buf[104];
 786     if (n < 0 || n >= 100) internal("ghcTupleText_n");
 787     if (n == 1) internal("ghcTupleText_n==1");
 788     buf[x++] = '(';
 789     for (i = 1; i <= n-1; i++) buf[x++] = ',';
 790     buf[x++] = ')';
 791     buf[x++] = 0;
 792     return findText(buf);
 793 }
 794
 795 Text ghcTupleText(tup)
 796 Tycon tup; {
 797     if (!isTuple(tup)) {
 798        assert(isTuple(tup));
 799     }
 800     return ghcTupleText_n ( tupleOf(tup) );
 801 }
 802
 803
 804 Tycon mkTuple ( Int n )
 805 {
 806    Int i;
 807    if (n >= NUM_TUPLES)
 808       internal("mkTuple: request for tuple of unsupported size");
 809    for (i = TYCON_BASE_ADDR;
 810         i < TYCON_BASE_ADDR+tabTyconSz; i++)
 811       if (tabTycon[i-TYCON_BASE_ADDR].inUse)
 812          if (tycon(i).tuple == n) return i;
 813    internal("mkTuple: request for non-existent tuple");
 814 }
 815
 816
 817 /* --------------------------------------------------------------------------
 818  * Name storage:
 819  *
 820  * A Name represents a top level binding of a value to an identifier.
 821  * Such values may be a constructor function, a member function in a
 822  * class, a user-defined or primitive value/function.
 823  *
 824  * Names are indexed by Text values ... a very simple hash functions speeds
 825  * access to the table of Names and Name entries with the same hash value
 826  * are chained together, with the most recent entry at the front of the
 827  * list.
 828  * ------------------------------------------------------------------------*/
 829
 830 #define NAMEHSZ  256                            /* Size of Name hash table */
 831 static  Name     nameHash[NAMEHSZ];             /* Hash table storage      */
 832
 833 static int nHash(Text x)
 834 {
 835    assert(isText(x) || inventedText(x));
 836    x -= TEXT_BASE_ADDR;
 837    if (x < 0) x = -x;
 838    return x%NAMEHSZ;
 839 }
 840
 841 int RC_N ( int x )
 842 {
 843    assert (x >= 0 && x < NAMEHSZ);
 844    return x;
 845 }
 846
 847 void hashSanity ( void )
 848 {
 849    Int i, j;
 850    for (i = 0; i < TYCONHSZ; i++) {
 851       j = tyconHash[i];
 852       while (nonNull(j)) {
 853          assert(isTycon(j) || isTuple(j));
 854          j = tycon(j).nextTyconHash;
 855       }
 856    }
 857    for (i = 0; i < NAMEHSZ; i++) {
 858       j = nameHash[i];
 859       while (nonNull(j)) {
 860          assert(isName(j));
 861          j = name(j).nextNameHash;
 862       }
 863    }
 864 }
 865
 866 Name newName ( Text t, Cell parent )    /* Add new name to name table      */
 867 {
 868     Int h = nHash(t);
 869     Name nm = allocNewName();
 870     tabName
 871        [nm-NAME_BASE_ADDR].mod  = currentModule;
 872     name(nm).text               = t;    /* clear new name record           */
 873     name(nm).line               = 0;
 874     name(nm).syntax             = NO_SYNTAX;
 875     name(nm).parent             = parent;
 876     name(nm).arity              = 0;
 877     name(nm).number             = EXECNAME;
 878     name(nm).defn               = NIL;
 879     name(nm).hasStrict          = FALSE;
 880     name(nm).callconv           = NIL;
 881     name(nm).type               = NIL;
 882     name(nm).primop             = NULL;
 883     name(nm).itbl               = NULL;
 884     name(nm).closure            = NIL;
 885     module(currentModule).names = cons(nm,module(currentModule).names);
 886     name(nm).nextNameHash       = nameHash[RC_N(h)];
 887     nameHash[RC_N(h)]           = nm;
 888     return nm;
 889 }
 890
 891 Name findName(t)                        /* Locate name in name table       */
 892 Text t; {
 893     Name n = nameHash[RC_N(nHash(t))];
 894     assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
 895     assert(isName(n) || isNull(n));
 896     while (nonNull(n) && name(n).text!=t)
 897         n = name(n).nextNameHash;
 898     return n;
 899 }
 900
 901 Name addName(nm)                        /* Insert Name in name table - if  */
 902 Name nm; {                              /* no clash is caused              */
 903     Name oldnm;
 904     assert(isName(nm));
 905     oldnm = findName(name(nm).text);
 906     if (isNull(oldnm)) {
 907         hashName(nm);
 908         module(currentModule).names=cons(nm,module(currentModule).names);
 909         return nm;
 910     } else
 911         return oldnm;
 912 }
 913
 914 static Void local hashName(nm)          /* Insert Name into hash table     */
 915 Name nm; {
 916     Text t;
 917     Int  h;
 918     assert(isName(nm));
 919     t = name(nm).text;
 920     h = nHash(t);
 921     name(nm).nextNameHash = nameHash[RC_N(h)];
 922     nameHash[RC_N(h)]           = nm;
 923 }
 924
 925 Name findQualName(id)              /* Locate (possibly qualified) name*/
 926 Cell id; {                         /* in name table                   */
 927     if (!isPair(id))
 928         internal("findQualName");
 929     switch (fst(id)) {
 930         case VARIDCELL :
 931         case VAROPCELL :
 932         case CONIDCELL :
 933         case CONOPCELL :
 934             return findName(textOf(id));
 935         case QUALIDENT : {
 936             Text   t  = qtextOf(id);
 937             Module m  = findQualifier(qmodOf(id));
 938             List   es = NIL;
 939             if (isNull(m)) return NIL;
 940             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 941                 Cell e = hd(es);
 942                 if (isName(e) && name(e).text==t)
 943                     return e;
 944                 else if (isPair(e) && DOTDOT==snd(e)) {
 945                     List subentities = NIL;
 946                     Cell c = fst(e);
 947                     if (isTycon(c)
 948                         && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
 949                         subentities = tycon(c).defn;
 950                     else if (isClass(c))
 951                         subentities = cclass(c).members;
 952                     for(; nonNull(subentities); subentities=tl(subentities)) {
 953                        if (!isName(hd(subentities)))
 954                             internal("findQualName3");
 955                         if (name(hd(subentities)).text == t)
 956                             return hd(subentities);
 957                     }
 958                 }
 959             }
 960             return NIL;
 961         }
 962         default : internal("findQualName2");
 963     }
 964     return 0; /* NOTREACHED */
 965 }
 966
 967
 968 void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s )
 969 {
 970    Text   t = findText(s);
 971    Name   n = NIL;
 972    for (n = NAME_BASE_ADDR;
 973         n < NAME_BASE_ADDR+tabNameSz; n++)
 974       if (tabName[n-NAME_BASE_ADDR].inUse && name(n).text == t)
 975          break;
 976    if (n == NAME_BASE_ADDR+tabNameSz) {
 977       fprintf ( stderr, "can't find `%s' in ...\n", s );
 978       internal("getHugs_BCO_cptr_for(1)");
 979    }
 980    if (!isCPtr(name(n).closure))
 981       internal("getHugs_BCO_cptr_for(2)");
 982    return cptrOf(name(n).closure);
 983 }
 984
 985 /* --------------------------------------------------------------------------
 986  * Primitive functions:
 987  * ------------------------------------------------------------------------*/
 988
 989 Module findFakeModule ( Text t )
 990 {
 991    Module m = findModule(t);
 992    if (nonNull(m)) {
 993       if (!module(m).fake) internal("findFakeModule");
 994    } else {
 995       m = newModule(t);
 996       module(m).fake = TRUE;
 997    }
 998    return m;
 999 }
1000
1001
1002 Name addWiredInBoxingTycon
1003         ( String modNm, String typeNm, String constrNm,
1004           Int rep, Kind kind )
1005 {
1006    Name   n;
1007    Tycon  t;
1008    Text   modT  = findText(modNm);
1009    Text   typeT = findText(typeNm);
1010    Text   conT  = findText(constrNm);
1011    Module m     = findFakeModule(modT);
1012    setCurrModule(m);
1013
1014    n = newName(conT,NIL);
1015    name(n).arity  = 1;
1016    name(n).number = cfunNo(0);
1017    name(n).type   = NIL;
1018    name(n).primop = (void*)rep;
1019
1020    t = newTycon(typeT);
1021    tycon(t).what = DATATYPE;
1022    tycon(t).kind = kind;
1023    return n;
1024 }
1025
1026
1027 Tycon addTupleTycon ( Int n )
1028 {
1029    Int    i;
1030    Kind   k;
1031    Tycon  t;
1032    Module m;
1033    Name   nm;
1034
1035    for (i = TYCON_BASE_ADDR;
1036         i < TYCON_BASE_ADDR+tabTyconSz; i++)
1037       if (tabTycon[i-TYCON_BASE_ADDR].inUse)
1038          if (tycon(i).tuple == n) return i;
1039
1040    if (combined)
1041       m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
1042       m = findModule(findText("PrelPrim"));
1043
1044    setCurrModule(m);
1045    k = STAR;
1046    for (i = 0; i < n; i++) k = ap(STAR,k);
1047    t = newTycon(ghcTupleText_n(n));
1048    tycon(t).kind  = k;
1049    tycon(t).tuple = n;
1050    tycon(t).what  = DATATYPE;
1051
1052    if (n == 0) {
1053       /* maybe we want to do this for all n ? */
1054       nm = newName(ghcTupleText_n(n), t);
1055       name(nm).type = t;   /* ummm ... for n > 0 */
1056    }
1057
1058    return t;
1059 }
1060
1061
1062 Tycon addWiredInEnumTycon ( String modNm, String typeNm,
1063                             List /*of Text*/ constrs )
1064 {
1065    Int    i;
1066    Tycon  t;
1067    Text   modT  = findText(modNm);
1068    Text   typeT = findText(typeNm);
1069    Module m     = findFakeModule(modT);
1070    setCurrModule(m);
1071
1072    t             = newTycon(typeT);
1073    tycon(t).kind = STAR;
1074    tycon(t).what = DATATYPE;
1075
1076    constrs = reverse(constrs);
1077    i       = length(constrs);
1078    for (; nonNull(constrs); constrs=tl(constrs),i--) {
1079       Text conT        = hd(constrs);
1080       Name con         = newName(conT,t);
1081       name(con).number = cfunNo(i);
1082       name(con).type   = t;
1083       name(con).parent = t;
1084       tycon(t).defn    = cons(con, tycon(t).defn);
1085    }
1086    return t;
1087 }
1088
1089
1090 Name addPrimCfunREP(t,arity,no,rep)     /* add primitive constructor func  */
1091 Text t;                                 /* sets rep, not type              */
1092 Int  arity;
1093 Int  no;
1094 Int  rep; { /* Really AsmRep */
1095     Name n          = newName(t,NIL);
1096     name(n).arity   = arity;
1097     name(n).number  = cfunNo(no);
1098     name(n).type    = NIL;
1099     name(n).primop  = (void*)rep;
1100     return n;
1101 }
1102
1103
1104 Name addPrimCfun(t,arity,no,type)       /* add primitive constructor func  */
1105 Text t;
1106 Int  arity;
1107 Int  no;
1108 Cell type; {
1109     Name n         = newName(t,NIL);
1110     name(n).arity  = arity;
1111     name(n).number = cfunNo(no);
1112     name(n).type   = type;
1113     return n;
1114 }
1115
1116
1117 Int sfunPos(s,c)                        /* Find position of field with     */
1118 Name s;                                 /* selector s in constructor c.    */
1119 Name c; {
1120     List cns;
1121     cns = name(s).defn;
1122     for (; nonNull(cns); cns=tl(cns))
1123         if (fst(hd(cns))==c)
1124             return intOf(snd(hd(cns)));
1125     internal("sfunPos");
1126     return 0;/* NOTREACHED */
1127 }
1128
1129 static List local insertName(nm,ns)     /* insert name nm into sorted list */
1130 Name nm;                                /* ns                              */
1131 List ns; {
1132     Cell   prev = NIL;
1133     Cell   curr = ns;
1134     String s    = textToStr(name(nm).text);
1135
1136     while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
1137         if (hd(curr)==nm)               /* just in case we get duplicates! */
1138             return ns;
1139         prev = curr;
1140         curr = tl(curr);
1141     }
1142     if (nonNull(prev)) {
1143         tl(prev) = cons(nm,curr);
1144         return ns;
1145     }
1146     else
1147         return cons(nm,curr);
1148 }
1149
1150 List addNamesMatching(pat,ns)           /* Add names matching pattern pat  */
1151 String pat;                             /* to list of names ns             */
1152 List   ns; {                            /* Null pattern matches every name */
1153     Name nm;                            /* (Names with NIL type, or hidden */
1154                                         /* or invented names are excluded) */
1155 #if 1
1156     for (nm = NAME_BASE_ADDR;
1157          nm < NAME_BASE_ADDR+tabNameSz; ++nm)
1158        if (tabName[nm-NAME_BASE_ADDR].inUse) {
1159           if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
1160              String str = textToStr(name(nm).text);
1161              if (str[0]!='_' && (!pat || stringMatch(pat,str)))
1162                  ns = insertName(nm,ns);
1163           }
1164        }
1165     return ns;
1166 #else
1167     List mns = module(currentModule).names;
1168     for(; nonNull(mns); mns=tl(mns)) {
1169         Name nm = hd(mns);
1170         if (!inventedText(name(nm).text)) {
1171             String str = textToStr(name(nm).text);
1172             if (str[0]!='_' && (!pat || stringMatch(pat,str)))
1173                 ns = insertName(nm,ns);
1174         }
1175     }
1176     return ns;
1177 #endif
1178 }
1179
1180 /* --------------------------------------------------------------------------
1181  * A simple string matching routine
1182  *     `*'    matches any sequence of zero or more characters
1183  *     `?'    matches any single character exactly
1184  *     `@str' matches the string str exactly (ignoring any special chars)
1185  *     `\c'   matches the character c only (ignoring special chars)
1186  *     c      matches the character c only
1187  * ------------------------------------------------------------------------*/
1188
1189 static Void local patternError(s)       /* report error in pattern         */
1190 String s; {
1191     ERRMSG(0) "%s in pattern", s
1192     EEND;
1193 }
1194
1195 static Bool local stringMatch(pat,str)  /* match string against pattern    */
1196 String pat;
1197 String str; {
1198
1199     for (;;)
1200         switch (*pat) {
1201             case '\0' : return (*str=='\0');
1202
1203             case '*'  : do {
1204                             if (stringMatch(pat+1,str))
1205                                 return TRUE;
1206                         } while (*str++);
1207                         return FALSE;
1208
1209             case '?'  : if (*str++=='\0')
1210                             return FALSE;
1211                         pat++;
1212                         break;
1213
1214             case '['  : {   Bool found = FALSE;
1215                             while (*++pat!='\0' && *pat!=']')
1216                                 if (!found && ( pat[0] == *str  ||
1217                                                (pat[1] == '-'   &&
1218                                                 pat[2] != ']'   &&
1219                                                 pat[2] != '\0'  &&
1220                                                 pat[0] <= *str  &&
1221                                                 pat[2] >= *str)))
1222
1223                                     found = TRUE;
1224                             if (*pat != ']')
1225                                 patternError("missing `]'");
1226                             if (!found)
1227                                 return FALSE;
1228                             pat++;
1229                             str++;
1230                         }
1231                         break;
1232
1233             case '\\' : if (*++pat == '\0')
1234                             patternError("extra trailing `\\'");
1235                         /*fallthru!*/
1236             default   : if (*pat++ != *str++)
1237                             return FALSE;
1238                         break;
1239         }
1240 }
1241
1242 /* --------------------------------------------------------------------------
1243  * Storage of type classes, instances etc...:
1244  * ------------------------------------------------------------------------*/
1245
1246 static List  classes;                  /* list of classes in current scope */
1247
1248 Class newClass ( Text t )              /* add new class to class table     */
1249 {
1250     Class cl                     = allocNewClass();
1251     tabClass
1252       [cl-CCLASS_BASE_ADDR].mod  = currentModule;
1253     cclass(cl).text              = t;
1254     cclass(cl).arity             = 0;
1255     cclass(cl).kinds             = NIL;
1256     cclass(cl).head              = NIL;
1257     cclass(cl).fds               = NIL;
1258     cclass(cl).xfds              = NIL;
1259     cclass(cl).dcon              = NIL;
1260     cclass(cl).supers            = NIL;
1261     cclass(cl).dsels             = NIL;
1262     cclass(cl).members           = NIL;
1263     cclass(cl).defaults          = NIL;
1264     cclass(cl).instances         = NIL;
1265     classes                      = cons(cl,classes);
1266     module(currentModule).classes
1267        = cons(cl,module(currentModule).classes);
1268     return cl;
1269 }
1270
1271 Class findClass(t)                     /* look for named class in table    */
1272 Text t; {
1273     Class cl;
1274     List cs;
1275     for (cs=classes; nonNull(cs); cs=tl(cs)) {
1276         cl=hd(cs);
1277         if (cclass(cl).text==t)
1278             return cl;
1279     }
1280     return NIL;
1281 }
1282
1283 Class addClass(c)                       /* Insert Class in class list      */
1284 Class c; {                              /*  - if no clash caused           */
1285     Class oldc;
1286     assert(whatIs(c)==CLASS);
1287     oldc = findClass(cclass(c).text);
1288     if (isNull(oldc)) {
1289         classes=cons(c,classes);
1290         module(currentModule).classes=cons(c,module(currentModule).classes);
1291         return c;
1292     }
1293     else
1294         return oldc;
1295 }
1296
1297 Class findQualClass(c)                  /* Look for (possibly qualified)   */
1298 Cell c; {                               /* class in class list             */
1299     if (!isQualIdent(c)) {
1300         return findClass(textOf(c));
1301     } else {
1302         Text   t  = qtextOf(c);
1303         Module m  = findQualifier(qmodOf(c));
1304         List   es = NIL;
1305         if (isNull(m))
1306             return NIL;
1307         for (es=module(m).exports; nonNull(es); es=tl(es)) {
1308             Cell e = hd(es);
1309             if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
1310                 return fst(e);
1311         }
1312     }
1313     return NIL;
1314 }
1315
1316 Inst newInst() {                       /* Add new instance to table        */
1317     Inst in                    = allocNewInst();
1318     tabInst
1319        [in-INST_BASE_ADDR].mod = currentModule;
1320     inst(in).kinds             = NIL;
1321     inst(in).head              = NIL;
1322     inst(in).specifics         = NIL;
1323     inst(in).numSpecifics      = 0;
1324     inst(in).implements        = NIL;
1325     inst(in).builder           = NIL;
1326     return in;
1327 }
1328
1329 #ifdef DEBUG_DICTS
1330 extern Void printInst ( Inst));
1331
1332 Void printInst(in)
1333 Inst in; {
1334     Class cl = inst(in).c;
1335     Printf("%s-", textToStr(cclass(cl).text));
1336     printType(stdout,inst(in).t);
1337 }
1338 #endif /* DEBUG_DICTS */
1339
1340 Inst findFirstInst(tc)                  /* look for 1st instance involving */
1341 Tycon tc; {                             /* the type constructor tc         */
1342     return findNextInst(tc,INST_BASE_ADDR-1);
1343 }
1344
1345 Inst findNextInst(tc,in)                /* look for next instance involving*/
1346 Tycon tc;                               /* the type constructor tc         */
1347 Inst  in; {                             /* starting after instance in      */
1348     Cell pi;
1349     while (++in < INST_BASE_ADDR+tabInstSz) {
1350         if (!tabInst[in-INST_BASE_ADDR].inUse) continue;
1351         assert(isModule(inst(in).mod));
1352         pi = inst(in).head;
1353         for (; isAp(pi); pi=fun(pi))
1354             if (typeInvolves(arg(pi),tc))
1355                 return in;
1356     }
1357     return NIL;
1358 }
1359
1360 static Bool local typeInvolves(ty,tc)   /* Test to see if type ty involves */
1361 Type ty;                                /* type constructor/tuple tc.      */
1362 Type tc; {
1363     return (ty==tc)
1364         || (isAp(ty) && (typeInvolves(fun(ty),tc)
1365                          || typeInvolves(arg(ty),tc)));
1366 }
1367
1368
1369 /* Needed by finishGHCInstance to find classes, before the
1370    export list has been built -- so we can't use
1371    findQualClass.
1372 */
1373 Class findQualClassWithoutConsultingExportList ( QualId q )
1374 {
1375    Class cl;
1376    Text t_mod;
1377    Text t_class;
1378
1379    assert(isQCon(q));
1380
1381    if (isCon(q)) {
1382       t_mod   = NIL;
1383       t_class = textOf(q);
1384    } else {
1385       t_mod   = qmodOf(q);
1386       t_class = qtextOf(q);
1387    }
1388
1389    for (cl = CCLASS_BASE_ADDR;
1390         cl < CCLASS_BASE_ADDR+tabClassSz; cl++) {
1391       if (tabClass[cl-CCLASS_BASE_ADDR].inUse)
1392          if (cclass(cl).text == t_class) {
1393             /* Class name is ok, but is this the right module? */
1394             if (isNull(t_mod)   /* no module name specified */
1395                 || (nonNull(t_mod)
1396                     && t_mod == module(cclass(cl).mod).text)
1397                )
1398                return cl;
1399          }
1400    }
1401    return NIL;
1402 }
1403
1404 /* Same deal, except for Tycons. */
1405 Tycon findQualTyconWithoutConsultingExportList ( QualId q )
1406 {
1407    Tycon tc;
1408    Text t_mod;
1409    Text t_tycon;
1410
1411    assert(isQCon(q));
1412
1413    if (isCon(q)) {
1414       t_mod   = NIL;
1415       t_tycon = textOf(q);
1416    } else {
1417       t_mod   = qmodOf(q);
1418       t_tycon = qtextOf(q);
1419    }
1420
1421    for (tc = TYCON_BASE_ADDR;
1422         tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
1423       if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
1424          if (tycon(tc).text == t_tycon) {
1425             /* Tycon name is ok, but is this the right module? */
1426             if (isNull(t_mod)   /* no module name specified */
1427                 || (nonNull(t_mod)
1428                     && t_mod == module(tycon(tc).mod).text)
1429                )
1430                return tc;
1431          }
1432    }
1433    return NIL;
1434 }
1435
1436 /* Same deal, except for Names. */
1437 Name findQualNameWithoutConsultingExportList ( QualId q )
1438 {
1439    Name nm;
1440    Text t_mod;
1441    Text t_name;
1442
1443    assert(isQVar(q) || isQCon(q));
1444
1445    if (isCon(q) || isVar(q)) {
1446       t_mod  = NIL;
1447       t_name = textOf(q);
1448    } else {
1449       t_mod  = qmodOf(q);
1450       t_name = qtextOf(q);
1451    }
1452
1453    for (nm = NAME_BASE_ADDR;
1454         nm < NAME_BASE_ADDR+tabNameSz; nm++) {
1455       if (tabName[nm-NAME_BASE_ADDR].inUse)
1456          if (name(nm).text == t_name) {
1457             /* Name is ok, but is this the right module? */
1458             if (isNull(t_mod)   /* no module name specified */
1459                 || (nonNull(t_mod)
1460                     && t_mod == module(name(nm).mod).text)
1461                )
1462                return nm;
1463          }
1464    }
1465    return NIL;
1466 }
1467
1468
1469 Tycon findTyconInAnyModule ( Text t )
1470 {
1471    Tycon tc;
1472    for (tc = TYCON_BASE_ADDR;
1473         tc < TYCON_BASE_ADDR+tabTyconSz; tc++)
1474       if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
1475          if (tycon(tc).text == t) return tc;
1476    return NIL;
1477 }
1478
1479 Class findClassInAnyModule ( Text t )
1480 {
1481    Class cc;
1482    for (cc = CCLASS_BASE_ADDR;
1483         cc < CCLASS_BASE_ADDR+tabClassSz; cc++)
1484       if (tabClass[cc-CCLASS_BASE_ADDR].inUse)
1485          if (cclass(cc).text == t) return cc;
1486    return NIL;
1487 }
1488
1489 Name findNameInAnyModule ( Text t )
1490 {
1491    Name nm;
1492    for (nm = NAME_BASE_ADDR;
1493         nm < NAME_BASE_ADDR+tabNameSz; nm++)
1494       if (tabName[nm-NAME_BASE_ADDR].inUse)
1495          if (name(nm).text == t) return nm;
1496    return NIL;
1497 }
1498
1499
1500 /* returns List of QualId */
1501 List getAllKnownTyconsAndClasses ( void )
1502 {
1503    Tycon tc;
1504    Class nw;
1505    List  xs = NIL;
1506    for (tc = TYCON_BASE_ADDR;
1507         tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
1508       if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
1509          /* almost certainly undue paranoia about duplicate avoidance */
1510          QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
1511          if (!qualidIsMember(q,xs))
1512             xs = cons ( q, xs );
1513       }
1514    }
1515    for (nw = CCLASS_BASE_ADDR;
1516         nw < CCLASS_BASE_ADDR+tabClassSz; nw++) {
1517       if (tabClass[nw-CCLASS_BASE_ADDR].inUse) {
1518          QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
1519          if (!qualidIsMember(q,xs))
1520             xs = cons ( q, xs );
1521       }
1522    }
1523    return xs;
1524 }
1525
1526 Int numQualifiers ( Type t )
1527 {
1528    if (isPolyType(t)) t = monotypeOf(t);
1529    if (isQualType(t))
1530        return length ( fst(snd(t)) ); else
1531        return 0;
1532 }
1533
1534
1535 /* Purely for debugging. */
1536 void locateSymbolByName ( Text t )
1537 {
1538    Int i;
1539    for (i = NAME_BASE_ADDR;
1540         i < NAME_BASE_ADDR+tabNameSz; i++)
1541       if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t)
1542          fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR);
1543    for (i = TYCON_BASE_ADDR;
1544         i < TYCON_BASE_ADDR+tabTyconSz; i++)
1545       if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t)
1546          fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR);
1547    for (i = CCLASS_BASE_ADDR;
1548         i < CCLASS_BASE_ADDR+tabClassSz; i++)
1549       if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t)
1550          fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR);
1551 }
1552
1553 /* --------------------------------------------------------------------------
1554  * Control stack:
1555  *
1556  * Various parts of the system use a stack of cells.  Most of the stack
1557  * operations are defined as macros, expanded inline.
1558  * ------------------------------------------------------------------------*/
1559
1560 Cell cellStack[NUM_STACK];          /* Storage for cells on stack          */
1561 StackPtr sp;                        /* stack pointer                       */
1562
1563 Void hugsStackOverflow() {          /* Report stack overflow               */
1564     ERRMSG(0) "Control stack overflow"
1565     EEND;
1566 }
1567
1568
1569 /* --------------------------------------------------------------------------
1570  * Module storage:
1571  *
1572  * A Module represents a user defined module.
1573  *
1574  * Note: there are now two lookup mechanisms in the system:
1575  *
1576  * 1) The exports from a module are stored in a big list.
1577  *    We resolve qualified names, and import lists by linearly scanning
1578  *    through this list.
1579  *
1580  * 2) Unqualified imports and local definitions for the current module
1581  *    are stored in hash tables (tyconHash and nameHash) or linear lists
1582  *    (classes).
1583  *
1584  * ------------------------------------------------------------------------*/
1585
1586 Module  currentModule;                  /* Module currently being processed*/
1587
1588 Bool isValidModule(m)                   /* is m a legitimate module id?    */
1589 Module m; {
1590     return isModule(m);
1591 }
1592
1593 Module newModule ( Text t )             /* add new module to module table  */
1594 {
1595     Module mod                   = allocNewModule();
1596     module(mod).text             = t;      /* clear new module record      */
1597
1598     module(mod).tycons           = NIL;
1599     module(mod).names            = NIL;
1600     module(mod).classes          = NIL;
1601     module(mod).exports          = NIL;
1602     module(mod).qualImports      = NIL;
1603     module(mod).codeList         = NIL;
1604     module(mod).fake             = FALSE;
1605
1606     module(mod).tree             = NIL;
1607     module(mod).completed        = FALSE;
1608     module(mod).lastStamp        = 0; /* ???? */
1609
1610     module(mod).mode             = NIL;
1611     module(mod).srcExt           = findText("");
1612     module(mod).uses             = NIL;
1613
1614     module(mod).objName          = findText("");
1615     module(mod).objSize          = 0;
1616
1617     module(mod).object           = NULL;
1618     module(mod).objectExtras     = NULL;
1619     module(mod).objectExtraNames = NIL;
1620     return mod;
1621 }
1622
1623
1624 Bool nukeModule_needs_major_gc = TRUE;
1625
1626 void nukeModule ( Module m )
1627 {
1628    ObjectCode* oc;
1629    ObjectCode* oc2;
1630    Int         i;
1631
1632    if (!isModule(m)) internal("nukeModule");
1633
1634    /* fprintf ( stderr, "NUKE MODULE %s\n", textToStr(module(m).text) ); */
1635
1636    /* see comment in compiler.c about this,
1637       and interaction with info tables */
1638    if (nukeModule_needs_major_gc) {
1639       /* fprintf ( stderr, "doing major GC in nukeModule\n"); */
1640       /* performMajorGC(); */
1641       nukeModule_needs_major_gc = FALSE;
1642    }
1643
1644    oc = module(m).object;
1645    while (oc) {
1646       oc2 = oc->next;
1647       ocFree(oc);
1648       oc = oc2;
1649    }
1650    oc = module(m).objectExtras;
1651    while (oc) {
1652       oc2 = oc->next;
1653       ocFree(oc);
1654       oc = oc2;
1655    }
1656
1657    for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++)
1658       if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) {
1659          if (name(i).itbl &&
1660              module(name(i).mod).mode == FM_SOURCE) {
1661             free(name(i).itbl);
1662          }
1663          name(i).itbl    = NULL;
1664          name(i).closure = NIL;
1665          freeName(i);
1666       }
1667
1668    for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++)
1669       if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) {
1670          if (tycon(i).itbl &&
1671              module(tycon(i).mod).mode == FM_SOURCE) {
1672             free(tycon(i).itbl);
1673          }
1674          tycon(i).itbl = NULL;
1675          freeTycon(i);
1676       }
1677
1678    for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++)
1679       if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
1680          if (cclass(i).mod == m) {
1681             freeClass(i);
1682          } else {
1683             List /* Inst */ ins;
1684             List /* Inst */ ins2 = NIL;
1685             for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins))
1686                if (inst(hd(ins)).mod != m)
1687                   ins2 = cons(hd(ins),ins2);
1688             cclass(i).instances = ins2;
1689          }
1690       }
1691
1692
1693    for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++)
1694       if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m)
1695          freeInst(i);
1696
1697    freeModule(m);
1698    //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0;
1699    //for (i = 0; i < NAMEHSZ; i++)  nameHash[i] = 0;
1700    //classes = NIL;
1701    //hashSanity();
1702 }
1703
1704 void ppModules ( void )
1705 {
1706    Int i;
1707    fflush(stderr); fflush(stdout);
1708    printf ( "begin MODULES\n" );
1709    for (i  = MODULE_BASE_ADDR+tabModuleSz-1;
1710         i >= MODULE_BASE_ADDR; i--)
1711       if (tabModule[i-MODULE_BASE_ADDR].inUse)
1712          printf ( " %2d: %16s\n",
1713                   i-MODULE_BASE_ADDR, textToStr(module(i).text)
1714                 );
1715    printf ( "end   MODULES\n" );
1716    fflush(stderr); fflush(stdout);
1717 }
1718
1719
1720 Module findModule(t)                    /* locate Module in module table  */
1721 Text t; {
1722     Module m;
1723     for(m = MODULE_BASE_ADDR;
1724         m < MODULE_BASE_ADDR+tabModuleSz; ++m) {
1725         if (tabModule[m-MODULE_BASE_ADDR].inUse)
1726             if (module(m).text==t)
1727                 return m;
1728     }
1729     return NIL;
1730 }
1731
1732 Module findModid(c)                    /* Find module by name or filename  */
1733 Cell c; {
1734     switch (whatIs(c)) {
1735         case STRCELL   : internal("findModid-STRCELL unimp");
1736         case CONIDCELL : return findModule(textOf(c));
1737         default        : internal("findModid");
1738     }
1739     return NIL;/*NOTUSED*/
1740 }
1741
1742 static local Module findQualifier(t)    /* locate Module in import list   */
1743 Text t; {
1744     Module ms;
1745     for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
1746         if (textOf(fst(hd(ms)))==t)
1747             return snd(hd(ms));
1748     }
1749     if (module(currentModule).text==t)
1750         return currentModule;
1751     return NIL;
1752 }
1753
1754 Void setCurrModule(m)              /* set lookup tables for current module */
1755 Module m; {
1756     Int i;
1757     assert(isModule(m));
1758     /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
1759     {List t;
1760      for (t = module(m).names; nonNull(t); t=tl(t))
1761         assert(isName(hd(t)));
1762      for (t = module(m).tycons; nonNull(t); t=tl(t))
1763         assert(isTycon(hd(t)) || isTuple(hd(t)));
1764      for (t = module(m).classes; nonNull(t); t=tl(t))
1765         assert(isClass(hd(t)));
1766     }
1767
1768     currentModule = m; /* This is the only assignment to currentModule */
1769     for (i=0; i<TYCONHSZ; ++i)
1770        tyconHash[RC_T(i)] = NIL;
1771     mapProc(hashTycon,module(m).tycons);
1772     for (i=0; i<NAMEHSZ; ++i)
1773        nameHash[RC_N(i)] = NIL;
1774     mapProc(hashName,module(m).names);
1775     classes = module(m).classes;
1776     hashSanity();
1777 }
1778
1779 void addToCodeList   ( Module m, Cell c )
1780 {
1781    assert(isName(c) || isTuple(c));
1782    if (nonNull(getNameOrTupleClosure(c)))
1783       module(m).codeList = cons ( c, module(m).codeList );
1784    /* fprintf ( stderr, "addToCodeList %s %s\n",
1785                 textToStr(module(m).text),
1786                 textToStr( isTuple(c) ? tycon(c).text : name(c).text ) );
1787    */
1788 }
1789
1790 Cell getNameOrTupleClosure ( Cell c )
1791 {
1792    if (isName(c)) return name(c).closure;
1793    else if (isTuple(c)) return tycon(c).closure;
1794    else internal("getNameOrTupleClosure");
1795 }
1796
1797 void setNameOrTupleClosure ( Cell c, Cell closure )
1798 {
1799    if (isName(c)) name(c).closure = closure;
1800    else if (isTuple(c)) tycon(c).closure = closure;
1801    else internal("setNameOrTupleClosure");
1802 }
1803
1804 /* This function is used in ghc/rts/Assembler.c. */
1805 void* /* StgClosure* */ getNameOrTupleClosureCPtr ( Cell c )
1806 {
1807    return cptrOf(getNameOrTupleClosure(c));
1808 }
1809
1810 /* used in codegen.c */
1811 void setNameOrTupleClosureCPtr ( Cell c, void* /* StgClosure* */ cptr )
1812 {
1813    if (isName(c)) name(c).closure = mkCPtr(cptr);
1814    else if (isTuple(c)) tycon(c).closure = mkCPtr(cptr);
1815    else internal("setNameOrTupleClosureCPtr");
1816 }
1817
1818
1819
1820 Name jrsFindQualName ( Text mn, Text sn )
1821 {
1822    Module m;
1823    List   ns;
1824
1825    for (m = MODULE_BASE_ADDR;
1826         m < MODULE_BASE_ADDR+tabModuleSz; m++)
1827       if (tabModule[m-MODULE_BASE_ADDR].inUse
1828           && module(m).text == mn) break;
1829
1830    if (m == MODULE_BASE_ADDR+tabModuleSz) return NIL;
1831
1832    for (ns = module(m).names; nonNull(ns); ns=tl(ns))
1833       if (name(hd(ns)).text == sn) return hd(ns);
1834
1835    return NIL;
1836 }
1837
1838
1839 char* nameFromOPtr ( void* p )
1840 {
1841    int i;
1842    Module m;
1843    for (m = MODULE_BASE_ADDR;
1844         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1845       if (tabModule[m-MODULE_BASE_ADDR].inUse && module(m).object) {
1846          char* nm = ocLookupAddr ( module(m).object, p );
1847          if (nm) return nm;
1848       }
1849    }
1850 #  if 0
1851    /* A kludge to assist Win32 debugging; not actually necessary. */
1852    { char* nm = nameFromStaticOPtr(p);
1853      if (nm) return nm;
1854    }
1855 #  endif
1856    return NULL;
1857 }
1858
1859
1860 void* lookupOTabName ( Module m, char* sym )
1861 {
1862    assert(isModule(m));
1863    if (module(m).object)
1864       return ocLookupSym ( module(m).object, sym );
1865    return NULL;
1866 }
1867
1868
1869 void* lookupOExtraTabName ( char* sym )
1870 {
1871    ObjectCode* oc;
1872    Module      m;
1873    for (m = MODULE_BASE_ADDR;
1874         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1875       if (tabModule[m-MODULE_BASE_ADDR].inUse)
1876          for (oc = module(m).objectExtras; oc; oc=oc->next) {
1877             void* ad = ocLookupSym ( oc, sym );
1878             if (ad) return ad;
1879          }
1880    }
1881    return NULL;
1882 }
1883
1884
1885 /* Only call this if in dire straits; searches every object symtab
1886    in the system -- so is therefore slow.
1887 */
1888 void* lookupOTabNameAbsolutelyEverywhere ( char* sym )
1889 {
1890    ObjectCode* oc;
1891    Module      m;
1892    void*       ad;
1893    for (m = MODULE_BASE_ADDR;
1894         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1895       if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1896          if (module(m).object) {
1897             ad = ocLookupSym ( module(m).object, sym );
1898             if (ad) return ad;
1899          }
1900          for (oc = module(m).objectExtras; oc; oc=oc->next) {
1901             ad = ocLookupSym ( oc, sym );
1902             if (ad) return ad;
1903          }
1904       }
1905    }
1906    return NULL;
1907 }
1908
1909
1910 OSectionKind lookupSection ( void* ad )
1911 {
1912    int          i;
1913    Module       m;
1914    ObjectCode*  oc;
1915    OSectionKind sect;
1916
1917    for (m = MODULE_BASE_ADDR;
1918         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1919       if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1920          if (module(m).object) {
1921             sect = ocLookupSection ( module(m).object, ad );
1922             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1923                return sect;
1924          }
1925          for (oc = module(m).objectExtras; oc; oc=oc->next) {
1926             sect = ocLookupSection ( oc, ad );
1927             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1928                return sect;
1929          }
1930       }
1931    }
1932    return HUGS_SECTIONKIND_OTHER;
1933 }
1934
1935
1936 /* Called by the evaluator's GC to tell Hugs to mark stuff in the
1937    run-time heap.
1938 */
1939 void markHugsObjects( void )
1940 {
1941     Name  nm;
1942     Tycon tc;
1943
1944     for ( nm = NAME_BASE_ADDR;
1945           nm < NAME_BASE_ADDR+tabNameSz; ++nm ) {
1946        if (tabName[nm-NAME_BASE_ADDR].inUse) {
1947            Cell cl = name(nm).closure;
1948            if (nonNull(cl)) {
1949               assert(isCPtr(cl));
1950               snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1951            }
1952        }
1953     }
1954
1955     for ( tc = TYCON_BASE_ADDR;
1956           tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) {
1957        if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
1958            Cell cl = tycon(tc).closure;
1959            if (nonNull(cl)) {
1960               assert(isCPtr(cl));
1961               snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1962            }
1963        }
1964     }
1965
1966 }
1967
1968
1969 /* --------------------------------------------------------------------------
1970  * Heap storage:
1971  *
1972  * Provides a garbage collectable heap for storage of expressions etc.
1973  *
1974  * Now incorporates a flat resource:  A two-space collected extension of
1975  * the heap that provides storage for contiguous arrays of Cell storage,
1976  * cooperating with the garbage collection mechanisms for the main heap.
1977  * ------------------------------------------------------------------------*/
1978
1979 Int     heapSize = DEFAULTHEAP;         /* number of cells in heap         */
1980 Heap    heapFst;                        /* array of fst component of pairs */
1981 Heap    heapSnd;                        /* array of snd component of pairs */
1982 Heap    heapTopFst;
1983 Heap    heapTopSnd;
1984 Bool    consGC = TRUE;                  /* Set to FALSE to turn off gc from*/
1985                                         /* C stack; use with extreme care! */
1986 Long    numCells;
1987 int     numEnters;
1988 Int     numGcs;                         /* number of garbage collections   */
1989 Int     cellsRecovered;                 /* number of cells recovered       */
1990
1991 static  Cell freeList;                  /* free list of unused cells       */
1992 static  Cell lsave, rsave;              /* save components of pair         */
1993
1994 #if GC_STATISTICS
1995
1996 static Int markCount, stackRoots;
1997
1998 #define initStackRoots() stackRoots = 0
1999 #define recordStackRoot() stackRoots++
2000
2001 #define startGC()       \
2002     if (gcMessages) {   \
2003         Printf("\n");   \
2004         fflush(stdout); \
2005     }
2006 #define endGC()         \
2007     if (gcMessages) {   \
2008         Printf("\n");   \
2009         fflush(stdout); \
2010     }
2011
2012 #define start()      markCount = 0
2013 #define end(thing,rs) \
2014     if (gcMessages) { \
2015         Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
2016         fflush(stdout); \
2017     }
2018 #define recordMark() markCount++
2019
2020 #else /* !GC_STATISTICS */
2021
2022 #define startGC()
2023 #define endGC()
2024
2025 #define initStackRoots()
2026 #define recordStackRoot()
2027
2028 #define start()
2029 #define end(thing,root)
2030 #define recordMark()
2031
2032 #endif /* !GC_STATISTICS */
2033
2034 Cell pair(l,r)                          /* Allocate pair (l, r) from       */
2035 Cell l, r; {                            /* heap, garbage collecting first  */
2036     Cell c = freeList;                  /* if necessary ...                */
2037     if (isNull(c)) {
2038         lsave = l;
2039         rsave = r;
2040         garbageCollect();
2041         l     = lsave;
2042         lsave = NIL;
2043         r     = rsave;
2044         rsave = NIL;
2045         c     = freeList;
2046     }
2047     freeList = snd(freeList);
2048     fst(c)   = l;
2049     snd(c)   = r;
2050     numCells++;
2051     return c;
2052 }
2053
2054 static Int *marks;
2055 static Int marksSize;
2056
2057 void mark ( Cell root )
2058 {
2059    Cell c;
2060    Cell mstack[NUM_MSTACK];
2061    Int  msp     = -1;
2062    Int  msp_max = -1;
2063
2064    mstack[++msp] = root;
2065
2066    while (msp >= 0) {
2067       if (msp > msp_max) msp_max = msp;
2068       c = mstack[msp--];
2069       if (!isGenPair(c)) continue;
2070       if (fst(c)==FREECELL) continue;
2071       {
2072          register int place = placeInSet(c);
2073          register int mask  = maskInSet(c);
2074          if (!(marks[place]&mask)) {
2075             marks[place] |= mask;
2076             if (msp >= NUM_MSTACK-5) {
2077                fprintf ( stderr,
2078                          "hugs: fatal stack overflow during GC.  "
2079                          "Increase NUM_MSTACK.\n" );
2080                exit(9);
2081             }
2082             mstack[++msp] = fst(c);
2083             mstack[++msp] = snd(c);
2084          }
2085       }
2086    }
2087    //   fprintf(stderr, "%d ",msp_max);
2088 }
2089
2090
2091 Void garbageCollect()     {             /* Run garbage collector ...       */
2092                                         /* disable break checking          */
2093     Int i,j;
2094     register Int mask;
2095     register Int place;
2096     Int      recovered;
2097     jmp_buf  regs;                      /* save registers on stack         */
2098     HugsBreakAction oldBrk
2099        = setBreakAction ( HugsIgnoreBreak );
2100
2101     setjmp(regs);
2102
2103     gcStarted();
2104
2105     for (i=0; i<marksSize; ++i)         /* initialise mark set to empty    */
2106         marks[i] = 0;
2107
2108     everybody(MARK);                    /* Mark all components of system   */
2109
2110     gcScanning();                       /* scan mark set                   */
2111     mask      = 1;
2112     place     = 0;
2113     recovered = 0;
2114     j         = 0;
2115
2116     freeList = NIL;
2117     for (i=1; i<=heapSize; i++) {
2118         if ((marks[place] & mask) == 0) {
2119             snd(-i)  = freeList;
2120             fst(-i)  = FREECELL;
2121             freeList = -i;
2122             recovered++;
2123         }
2124         mask <<= 1;
2125         if (++j == bitsPerWord) {
2126             place++;
2127             mask = 1;
2128             j    = 0;
2129         }
2130     }
2131
2132     gcRecovered(recovered);
2133     setBreakAction ( oldBrk );
2134
2135     everybody(GCDONE);
2136
2137 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
2138     /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
2139 #endif
2140
2141     /* can only return if freeList is nonempty on return. */
2142     if (recovered<minRecovery || isNull(freeList)) {
2143         ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
2144         EEND;
2145     }
2146     cellsRecovered = recovered;
2147 }
2148
2149 /* --------------------------------------------------------------------------
2150  * Code for saving last expression entered:
2151  *
2152  * This is a little tricky because some text values (e.g. strings or variable
2153  * names) may not be defined or have the same value when the expression is
2154  * recalled.  These text values are therefore saved in the top portion of
2155  * the text table.
2156  * ------------------------------------------------------------------------*/
2157
2158 static Cell lastExprSaved;              /* last expression to be saved     */
2159
2160 Void setLastExpr(e)                     /* save expression for later recall*/
2161 Cell e; {
2162     lastExprSaved = NIL;                /* in case attempt to save fails   */
2163     savedText     = TEXT_SIZE;
2164     lastExprSaved = lowLevelLastIn(e);
2165 }
2166
2167 static Cell local lowLevelLastIn(c)     /* Duplicate expression tree (i.e. */
2168 Cell c; {                               /* acyclic graph) for later recall */
2169     if (isPair(c)) {                    /* Duplicating any text strings    */
2170         if (isTagNonPtr(fst(c)))        /* in case these are lost at some  */
2171             switch (fst(c)) {           /* point before the expr is reused */
2172                 case VARIDCELL :
2173                 case VAROPCELL :
2174                 case DICTVAR   :
2175                 case CONIDCELL :
2176                 case CONOPCELL :
2177                 case STRCELL   : return pair(fst(c),saveText(textOf(c)));
2178                 default        : return pair(fst(c),snd(c));
2179             }
2180         else
2181             return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
2182     }
2183 #if TREX
2184     else if (isExt(c))
2185         return pair(EXTCOPY,saveText(extText(c)));
2186 #endif
2187     else
2188         return c;
2189 }
2190
2191 Cell getLastExpr() {                    /* recover previously saved expr   */
2192     return lowLevelLastOut(lastExprSaved);
2193 }
2194
2195 static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
2196 Cell c; {                               /* except that Cells refering to   */
2197     if (isPair(c)) {                    /* Text values are restored to     */
2198         if (isTagNonPtr(fst(c)))        /* appropriate values              */
2199             switch (fst(c)) {
2200                 case VARIDCELL :
2201                 case VAROPCELL :
2202                 case DICTVAR   :
2203                 case CONIDCELL :
2204                 case CONOPCELL :
2205                 case STRCELL   : return pair(fst(c),
2206                                              findText(text+intValOf(c)));
2207 #if TREX
2208                 case EXTCOPY   : return mkExt(findText(text+intValOf(c)));
2209 #endif
2210                 default        : return pair(fst(c),snd(c));
2211             }
2212         else
2213             return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
2214     }
2215     else
2216         return c;
2217 }
2218
2219 /* --------------------------------------------------------------------------
2220  * Miscellaneous operations on heap cells:
2221  * ------------------------------------------------------------------------*/
2222
2223 /* Reordered 2 May 00 to have most common options first. */
2224 Cell whatIs ( register Cell c )
2225 {
2226     if (isPair(c)) {
2227         register Cell fstc = fst(c);
2228         return isTag(fstc) ? fstc : AP;
2229     }
2230     if (isTycon(c))            return TYCON;
2231     if (isOffset(c))           return OFFSET;
2232     if (isName(c))             return NAME;
2233     if (isInt(c))              return INTCELL;
2234     if (isTuple(c))            return TUPLE;
2235     if (isSpec(c))             return c;
2236     if (isClass(c))            return CLASS;
2237     if (isChar(c))             return CHARCELL;
2238     if (isNull(c))             return c;
2239     if (isInst(c))             return INSTANCE;
2240     if (isModule(c))           return MODULE;
2241     if (isText(c))             return TEXTCELL;
2242     if (isInventedVar(c))      return INVAR;
2243     if (isInventedDictVar(c))  return INDVAR;
2244     fprintf ( stderr, "whatIs: unknown %d\n", c );
2245     internal("whatIs");
2246 }
2247
2248
2249
2250 /* A very, very simple printer.
2251  * Output is uglier than from printExp - but the printer is more
2252  * robust and can be used on any data structure irrespective of
2253  * its type.
2254  */
2255 Void print ( Cell c, Int depth )
2256 {
2257     if (0 == depth) {
2258         Printf("...");
2259     }
2260     else if (isNull(c)) {
2261        Printf("NIL");
2262     }
2263     else if (isTagPtr(c)) {
2264         Printf("TagP(%d)", c);
2265     }
2266     else if (isTagNonPtr(c)) {
2267         Printf("TagNP(%d)", c);
2268     }
2269     else if (isSpec(c) && c != STAR) {
2270         Printf("TagS(%d)", c);
2271     }
2272     else if (isText(c)) {
2273         Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c));
2274     }
2275     else if (isInventedVar(c)) {
2276         Printf("invented(%d)", c-INVAR_BASE_ADDR);
2277     }
2278     else if (isInventedDictVar(c)) {
2279         Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR);
2280     }
2281     else {
2282         Int tag = whatIs(c);
2283         switch (tag) {
2284         case AP:
2285                 Putchar('(');
2286                 print(fst(c), depth-1);
2287                 Putchar(',');
2288                 print(snd(c), depth-1);
2289                 Putchar(')');
2290                 break;
2291         case FREECELL:
2292                 Printf("free(%d)", c);
2293                 break;
2294         case INTCELL:
2295                 Printf("int(%d)", intOf(c));
2296                 break;
2297         case BIGCELL:
2298                 Printf("bignum(%s)", bignumToString(c));
2299                 break;
2300         case CHARCELL:
2301                 Printf("char('%c')", charOf(c));
2302                 break;
2303         case STRCELL:
2304                 Printf("strcell(\"%s\")",textToStr(snd(c)));
2305                 break;
2306         case MPTRCELL:
2307                 Printf("mptr(%p)",mptrOf(c));
2308                 break;
2309         case CPTRCELL:
2310                 Printf("cptr(%p)",cptrOf(c));
2311                 break;
2312         case ADDRCELL:
2313                 Printf("addr(%p)",addrOf(c));
2314                 break;
2315         case CLASS:
2316                 Printf("class(%d)", c-CCLASS_BASE_ADDR);
2317                 Printf("=\"%s\"", textToStr(cclass(c).text));
2318                 break;
2319         case INSTANCE:
2320                 Printf("instance(%d)", c - INST_BASE_ADDR);
2321                 break;
2322         case NAME:
2323                 Printf("name(%d)", c-NAME_BASE_ADDR);
2324                 Printf("=\"%s\"", textToStr(name(c).text));
2325                 break;
2326         case TYCON:
2327                 Printf("tycon(%d)", c-TYCON_BASE_ADDR);
2328                 Printf("=\"%s\"", textToStr(tycon(c).text));
2329                 break;
2330         case MODULE:
2331                 Printf("module(%d)", c - MODULE_BASE_ADDR);
2332                 Printf("=\"%s\"", textToStr(module(c).text));
2333                 break;
2334         case OFFSET:
2335                 Printf("Offset %d", offsetOf(c));
2336                 break;
2337         case TUPLE:
2338                 Printf("%s", textToStr(ghcTupleText(c)));
2339                 break;
2340         case POLYTYPE:
2341                 Printf("Polytype");
2342                 print(snd(c),depth-1);
2343                 break;
2344         case QUAL:
2345                 Printf("Qualtype");
2346                 print(snd(c),depth-1);
2347                 break;
2348         case RANK2:
2349                 Printf("Rank2(");
2350                 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
2351                     Printf("%d ", intOf(fst(snd(c))));
2352                     print(snd(snd(c)),depth-1);
2353                 } else {
2354                     print(snd(c),depth-1);
2355                 }
2356                 Printf(")");
2357                 break;
2358         case WILDCARD:
2359                 Printf("_");
2360                 break;
2361         case STAR:
2362                 Printf("STAR");
2363                 break;
2364         case DOTDOT:
2365                 Printf("DOTDOT");
2366                 break;
2367         case DICTVAR:
2368                 Printf("{dict %d}",textOf(c));
2369                 break;
2370         case VARIDCELL:
2371         case VAROPCELL:
2372         case CONIDCELL:
2373         case CONOPCELL:
2374                 Printf("{id %s}",textToStr(textOf(c)));
2375                 break;
2376 #if IPARAM
2377           case IPCELL :
2378               Printf("{ip %s}",textToStr(textOf(c)));
2379               break;
2380           case IPVAR :
2381               Printf("?%s",textToStr(textOf(c)));
2382               break;
2383 #endif
2384         case QUALIDENT:
2385                 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
2386                 break;
2387         case LETREC:
2388                 Printf("LetRec(");
2389                 print(fst(snd(c)),depth-1);
2390                 Putchar(',');
2391                 print(snd(snd(c)),depth-1);
2392                 Putchar(')');
2393                 break;
2394         case LAMBDA:
2395                 Printf("Lambda(");
2396                 print(snd(c),depth-1);
2397                 Putchar(')');
2398                 break;
2399         case FINLIST:
2400                 Printf("FinList(");
2401                 print(snd(c),depth-1);
2402                 Putchar(')');
2403                 break;
2404         case COMP:
2405                 Printf("Comp(");
2406                 print(fst(snd(c)),depth-1);
2407                 Putchar(',');
2408                 print(snd(snd(c)),depth-1);
2409                 Putchar(')');
2410                 break;
2411         case ASPAT:
2412                 Printf("AsPat(");
2413                 print(fst(snd(c)),depth-1);
2414                 Putchar(',');
2415                 print(snd(snd(c)),depth-1);
2416                 Putchar(')');
2417                 break;
2418         case FROMQUAL:
2419                 Printf("FromQual(");
2420                 print(fst(snd(c)),depth-1);
2421                 Putchar(',');
2422                 print(snd(snd(c)),depth-1);
2423                 Putchar(')');
2424                 break;
2425         case STGVAR:
2426                 Printf("StgVar%d=",-c);
2427                 print(snd(c), depth-1);
2428                 break;
2429         case STGAPP:
2430                 Printf("StgApp(");
2431                 print(fst(snd(c)),depth-1);
2432                 Putchar(',');
2433                 print(snd(snd(c)),depth-1);
2434                 Putchar(')');
2435                 break;
2436         case STGPRIM:
2437                 Printf("StgPrim(");
2438                 print(fst(snd(c)),depth-1);
2439                 Putchar(',');
2440                 print(snd(snd(c)),depth-1);
2441                 Putchar(')');
2442                 break;
2443         case STGCON:
2444                 Printf("StgCon(");
2445                 print(fst(snd(c)),depth-1);
2446                 Putchar(',');
2447                 print(snd(snd(c)),depth-1);
2448                 Putchar(')');
2449                 break;
2450         case PRIMCASE:
2451                 Printf("PrimCase(");
2452                 print(fst(snd(c)),depth-1);
2453                 Putchar(',');
2454                 print(snd(snd(c)),depth-1);
2455                 Putchar(')');
2456                 break;
2457         case DICTAP:
2458                 Printf("(DICTAP,");
2459                 print(snd(c),depth-1);
2460                 Putchar(')');
2461                 break;
2462         case UNBOXEDTUP:
2463                 Printf("(UNBOXEDTUP,");
2464                 print(snd(c),depth-1);
2465                 Putchar(')');
2466                 break;
2467         case ZTUP2:
2468                 Printf("<ZPair ");
2469                 print(zfst(c),depth-1);
2470                 Putchar(' ');
2471                 print(zsnd(c),depth-1);
2472                 Putchar('>');
2473                 break;
2474         case ZTUP3:
2475                 Printf("<ZTriple ");
2476                 print(zfst3(c),depth-1);
2477                 Putchar(' ');
2478                 print(zsnd3(c),depth-1);
2479                 Putchar(' ');
2480                 print(zthd3(c),depth-1);
2481                 Putchar('>');
2482                 break;
2483         case BANG:
2484                 Printf("(BANG,");
2485                 print(snd(c),depth-1);
2486                 Putchar(')');
2487                 break;
2488         default:
2489                 if (isTagNonPtr(tag)) {
2490                     Printf("(TagNP=%d,%d)", c, tag);
2491                 } else if (isTagPtr(tag)) {
2492                     Printf("(TagP=%d,",tag);
2493                     print(snd(c), depth-1);
2494                     Putchar(')');
2495                     break;
2496                 } else if (c == tag) {
2497                     Printf("Tag(%d)", c);
2498                 } else {
2499                     Printf("Tag(%d)=%d", c, tag);
2500                 }
2501                 break;
2502         }
2503     }
2504     FlushStdout();
2505 }
2506
2507
2508 Bool isVar(c)                           /* is cell a VARIDCELL/VAROPCELL ? */
2509 Cell c; {                               /* also recognises DICTVAR cells   */
2510     return isPair(c) &&
2511                (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
2512 }
2513
2514 Bool isCon(c)                          /* is cell a CONIDCELL/CONOPCELL ?  */
2515 Cell c; {
2516     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
2517 }
2518
2519 Bool isQVar(c)                        /* is cell a [un]qualified varop/id? */
2520 Cell c; {
2521     if (!isPair(c)) return FALSE;
2522     switch (fst(c)) {
2523         case VARIDCELL  :
2524         case VAROPCELL  : return TRUE;
2525
2526         case QUALIDENT  : return isVar(snd(snd(c)));
2527
2528         default         : return FALSE;
2529     }
2530 }
2531
2532 Bool isQCon(c)                         /*is cell a [un]qualified conop/id? */
2533 Cell c; {
2534     if (!isPair(c)) return FALSE;
2535     switch (fst(c)) {
2536         case CONIDCELL  :
2537         case CONOPCELL  : return TRUE;
2538
2539         case QUALIDENT  : return isCon(snd(snd(c)));
2540
2541         default         : return FALSE;
2542     }
2543 }
2544
2545 Bool isQualIdent(c)                    /* is cell a qualified identifier?  */
2546 Cell c; {
2547     return isPair(c) && (fst(c)==QUALIDENT);
2548 }
2549
2550 Bool eqQualIdent ( QualId c1, QualId c2 )
2551 {
2552    assert(isQualIdent(c1));
2553    if (!isQualIdent(c2)) {
2554    assert(isQualIdent(c2));
2555    }
2556    return qmodOf(c1)==qmodOf(c2) &&
2557           qtextOf(c1)==qtextOf(c2);
2558 }
2559
2560 Bool isIdent(c)                        /* is cell an identifier?           */
2561 Cell c; {
2562     if (!isPair(c)) return FALSE;
2563     switch (fst(c)) {
2564         case VARIDCELL  :
2565         case VAROPCELL  :
2566         case CONIDCELL  :
2567         case CONOPCELL  : return TRUE;
2568
2569         case QUALIDENT  : return TRUE;
2570
2571         default         : return FALSE;
2572     }
2573 }
2574
2575 Bool isInt(c)                          /* cell holds integer value?        */
2576 Cell c; {
2577     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
2578 }
2579
2580 Int intOf(c)                           /* find integer value of cell?      */
2581 Cell c; {
2582     assert(isInt(c));
2583     return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO);
2584 }
2585
2586 Cell mkInt(n)                          /* make cell representing integer   */
2587 Int n; {
2588     return (SMALL_INT_MIN    <= SMALL_INT_ZERO+n &&
2589             SMALL_INT_ZERO+n <= SMALL_INT_MAX)
2590            ? SMALL_INT_ZERO+n
2591            : pair(INTCELL,n);
2592 }
2593
2594 #if SIZEOF_VOID_P == SIZEOF_INT
2595
2596 typedef union {Int i; Ptr p;} IntOrPtr;
2597
2598 Cell mkAddr(p)
2599 Ptr p;
2600 {
2601     IntOrPtr x;
2602     x.p = p;
2603     return pair(ADDRCELL,x.i);
2604 }
2605
2606 Ptr addrOf(c)
2607 Cell c;
2608 {
2609     IntOrPtr x;
2610     assert(fst(c) == ADDRCELL);
2611     x.i = snd(c);
2612     return x.p;
2613 }
2614
2615 Cell mkMPtr(p)
2616 Ptr p;
2617 {
2618     IntOrPtr x;
2619     x.p = p;
2620     return pair(MPTRCELL,x.i);
2621 }
2622
2623 Ptr mptrOf(c)
2624 Cell c;
2625 {
2626     IntOrPtr x;
2627     assert(fst(c) == MPTRCELL);
2628     x.i = snd(c);
2629     return x.p;
2630 }
2631
2632 Cell mkCPtr(p)
2633 Ptr p;
2634 {
2635     IntOrPtr x;
2636     x.p = p;
2637     return pair(CPTRCELL,x.i);
2638 }
2639
2640 Ptr cptrOf(c)
2641 Cell c;
2642 {
2643     IntOrPtr x;
2644     assert(fst(c) == CPTRCELL);
2645     x.i = snd(c);
2646     return x.p;
2647 }
2648
2649 #elif SIZEOF_VOID_P == 2*SIZEOF_INT
2650
2651 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2652
2653 Cell mkPtr(p)
2654 Ptr p;
2655 {
2656     IntOrPtr x;
2657     x.p = p;
2658     return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2659 }
2660
2661 Ptr ptrOf(c)
2662 Cell c;
2663 {
2664     IntOrPtr x;
2665     assert(fst(c) == PTRCELL);
2666     x.i.i1 = intOf(fst(snd(c)));
2667     x.i.i2 = intOf(snd(snd(c)));
2668     return x.p;
2669 }
2670
2671 Cell mkCPtr(p)
2672 Ptr p;
2673 {
2674     IntOrPtr x;
2675     x.p = p;
2676     return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2677 }
2678
2679 Ptr cptrOf(c)
2680 Cell c;
2681 {
2682     IntOrPtr x;
2683     assert(fst(c) == CPTRCELL);
2684     x.i.i1 = intOf(fst(snd(c)));
2685     x.i.i2 = intOf(snd(snd(c)));
2686     return x.p;
2687 }
2688
2689 #else
2690
2691 #error "Can't implement mkPtr/ptrOf on this architecture."
2692
2693 #endif
2694
2695
2696 String stringNegate( s )
2697 String s;
2698 {
2699     if (s[0] == '-') {
2700         return &s[1];
2701     } else {
2702         static char t[100];
2703         t[0] = '-';
2704         strcpy(&t[1],s);  /* ToDo: use strncpy instead */
2705         return t;
2706     }
2707 }
2708
2709 /* --------------------------------------------------------------------------
2710  * List operations:
2711  * ------------------------------------------------------------------------*/
2712
2713 Int length(xs)                         /* calculate length of list xs      */
2714 List xs; {
2715     Int n = 0;
2716     for (; nonNull(xs); ++n)
2717         xs = tl(xs);
2718     return n;
2719 }
2720
2721 List appendOnto(xs,ys)                 /* Destructively prepend xs onto    */
2722 List xs, ys; {                         /* ys by modifying xs ...           */
2723     if (isNull(xs))
2724         return ys;
2725     else {
2726         List zs = xs;
2727         while (nonNull(tl(zs)))
2728             zs = tl(zs);
2729         tl(zs) = ys;
2730         return xs;
2731     }
2732 }
2733
2734 List dupOnto(xs,ys)      /* non-destructively prepend xs backwards onto ys */
2735 List xs;
2736 List ys; {
2737     for (; nonNull(xs); xs=tl(xs))
2738         ys = cons(hd(xs),ys);
2739     return ys;
2740 }
2741
2742 List dupListOnto(xs,ys)              /* Duplicate spine of list xs onto ys */
2743 List xs;
2744 List ys; {
2745     return revOnto(dupOnto(xs,NIL),ys);
2746 }
2747
2748 List dupList(xs)                       /* Duplicate spine of list xs       */
2749 List xs; {
2750     List ys = NIL;
2751     for (; nonNull(xs); xs=tl(xs))
2752         ys = cons(hd(xs),ys);
2753     return rev(ys);
2754 }
2755
2756 List revOnto(xs,ys)                    /* Destructively reverse elements of*/
2757 List xs, ys; {                         /* list xs onto list ys...          */
2758     Cell zs;
2759
2760     while (nonNull(xs)) {
2761         zs     = tl(xs);
2762         tl(xs) = ys;
2763         ys     = xs;
2764         xs     = zs;
2765     }
2766     return ys;
2767 }
2768
2769 QualId qualidIsMember ( QualId q, List xs )
2770 {
2771    for (; nonNull(xs); xs=tl(xs)) {
2772       if (eqQualIdent(q, hd(xs)))
2773          return hd(xs);
2774    }
2775    return NIL;
2776 }
2777
2778 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
2779 Text t;                                /* given list of variables          */
2780 List xs; {
2781     assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
2782     for (; nonNull(xs); xs=tl(xs))
2783         if (t==textOf(hd(xs)))
2784             return hd(xs);
2785     return NIL;
2786 }
2787
2788 Name nameIsMember(t,ns)                 /* Test if name with text t is a   */
2789 Text t;                                 /* member of list of names xs      */
2790 List ns; {
2791     for (; nonNull(ns); ns=tl(ns))
2792         if (t==name(hd(ns)).text)
2793             return hd(ns);
2794     return NIL;
2795 }
2796
2797 Cell intIsMember(n,xs)                 /* Test if integer n is member of   */
2798 Int  n;                                /* given list of integers           */
2799 List xs; {
2800     for (; nonNull(xs); xs=tl(xs))
2801         if (n==intOf(hd(xs)))
2802             return hd(xs);
2803     return NIL;
2804 }
2805
2806 Cell cellIsMember(x,xs)                /* Test for membership of specific  */
2807 Cell x;                                /* cell x in list xs                */
2808 List xs; {
2809     for (; nonNull(xs); xs=tl(xs))
2810         if (x==hd(xs))
2811             return hd(xs);
2812     return NIL;
2813 }
2814
2815 Cell cellAssoc(c,xs)                   /* Lookup cell in association list  */
2816 Cell c;
2817 List xs; {
2818     for (; nonNull(xs); xs=tl(xs))
2819         if (c==fst(hd(xs)))
2820             return hd(xs);
2821     return NIL;
2822 }
2823
2824 Cell cellRevAssoc(c,xs)                /* Lookup cell in range of          */
2825 Cell c;                                /* association lists                */
2826 List xs; {
2827     for (; nonNull(xs); xs=tl(xs))
2828         if (c==snd(hd(xs)))
2829             return hd(xs);
2830     return NIL;
2831 }
2832
2833 List replicate(n,x)                     /* create list of n copies of x    */
2834 Int n;
2835 Cell x; {
2836     List xs=NIL;
2837     while (0<n--)
2838         xs = cons(x,xs);
2839     return xs;
2840 }
2841
2842 List diffList(from,take)               /* list difference: from\take       */
2843 List from, take; {                     /* result contains all elements of  */
2844     List result = NIL;                 /* `from' not appearing in `take'   */
2845
2846     while (nonNull(from)) {
2847         List next = tl(from);
2848         if (!cellIsMember(hd(from),take)) {
2849             tl(from) = result;
2850             result   = from;
2851         }
2852         from = next;
2853     }
2854     return rev(result);
2855 }
2856
2857 List deleteCell(xs, y)                  /* copy xs deleting pointers to y  */
2858 List xs;
2859 Cell y; {
2860     List result = NIL;
2861     for(;nonNull(xs);xs=tl(xs)) {
2862         Cell x = hd(xs);
2863         if (x != y) {
2864             result=cons(x,result);
2865         }
2866     }
2867     return rev(result);
2868 }
2869
2870 List take(n,xs)                         /* destructively truncate list to  */
2871 Int  n;                                 /* specified length                */
2872 List xs; {
2873     List ys = xs;
2874
2875     if (n==0)
2876         return NIL;
2877     while (1<n-- && nonNull(xs))
2878         xs = tl(xs);
2879     if (nonNull(xs))
2880         tl(xs) = NIL;
2881     return ys;
2882 }
2883
2884 List splitAt(n,xs)                      /* drop n things from front of list*/
2885 Int  n;
2886 List xs; {
2887     for(; n>0; --n) {
2888         xs = tl(xs);
2889     }
2890     return xs;
2891 }
2892
2893 Cell nth(n,xs)                          /* extract n'th element of list    */
2894 Int  n;
2895 List xs; {
2896     for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2897     }
2898     if (isNull(xs))
2899         internal("nth");
2900     return hd(xs);
2901 }
2902
2903 List removeCell(x,xs)                   /* destructively remove cell from  */
2904 Cell x;                                 /* list                            */
2905 List xs; {
2906     if (nonNull(xs)) {
2907         if (hd(xs)==x)
2908             return tl(xs);              /* element at front of list        */
2909         else {
2910             List prev = xs;
2911             List curr = tl(xs);
2912             for (; nonNull(curr); prev=curr, curr=tl(prev))
2913                 if (hd(curr)==x) {
2914                     tl(prev) = tl(curr);
2915                     return xs;          /* element in middle of list       */
2916                 }
2917         }
2918     }
2919     return xs;                          /* here if element not found       */
2920 }
2921
2922 List nubList(xs)                        /* nuke dups in list               */
2923 List xs; {                              /* non destructive                 */
2924    List outs = NIL;
2925    for (; nonNull(xs); xs=tl(xs))
2926       if (isNull(cellIsMember(hd(xs),outs)))
2927          outs = cons(hd(xs),outs);
2928    outs = rev(outs);
2929    return outs;
2930 }
2931
2932
2933 /* --------------------------------------------------------------------------
2934  * Tagged tuples (experimental)
2935  * ------------------------------------------------------------------------*/
2936
2937 static void z_tag_check ( Cell x, int tag, char* caller )
2938 {
2939    char buf[100];
2940    if (isNull(x)) {
2941       sprintf(buf,"z_tag_check(%s): null\n", caller);
2942       internal(buf);
2943    }
2944    if (whatIs(x) != tag) {
2945       sprintf(buf,
2946           "z_tag_check(%s): tag was %d, expected %d\n",
2947           caller, whatIs(x), tag );
2948       internal(buf);
2949    }
2950 }
2951
2952 Cell zpair ( Cell x1, Cell x2 )
2953 { return ap(ZTUP2,ap(x1,x2)); }
2954 Cell zfst ( Cell zpair )
2955 { z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
2956 Cell zsnd ( Cell zpair )
2957 { z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
2958
2959 Cell ztriple ( Cell x1, Cell x2, Cell x3 )
2960 { return ap(ZTUP3,ap(x1,ap(x2,x3))); }
2961 Cell zfst3 ( Cell zpair )
2962 { z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
2963 Cell zsnd3 ( Cell zpair )
2964 { z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
2965 Cell zthd3 ( Cell zpair )
2966 { z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
2967
2968 Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
2969 { return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
2970 Cell zsel14 ( Cell zpair )
2971 { z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
2972 Cell zsel24 ( Cell zpair )
2973 { z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
2974 Cell zsel34 ( Cell zpair )
2975 { z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
2976 Cell zsel44 ( Cell zpair )
2977 { z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
2978
2979 Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
2980 { return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
2981 Cell zsel15 ( Cell zpair )
2982 { z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
2983 Cell zsel25 ( Cell zpair )
2984 { z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
2985 Cell zsel35 ( Cell zpair )
2986 { z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
2987 Cell zsel45 ( Cell zpair )
2988 { z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
2989 Cell zsel55 ( Cell zpair )
2990 { z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
2991
2992
2993 Cell unap ( int tag, Cell c )
2994 {
2995    char buf[100];
2996    if (whatIs(c) != tag) {
2997       sprintf(buf, "unap: specified %d, actual %d\n",
2998                    tag, whatIs(c) );
2999       internal(buf);
3000    }
3001    return snd(c);
3002 }
3003
3004 /* --------------------------------------------------------------------------
3005  * Operations on applications:
3006  * ------------------------------------------------------------------------*/
3007
3008 Int argCount;                          /* number of args in application    */
3009
3010 Cell getHead(e)                        /* get head cell of application     */
3011 Cell e; {                              /* set number of args in argCount   */
3012     for (argCount=0; isAp(e); e=fun(e))
3013         argCount++;
3014     return e;
3015 }
3016
3017 List getArgs(e)                        /* get list of arguments in function*/
3018 Cell e; {                              /* application:                     */
3019     List as;                           /* getArgs(f e1 .. en) = [e1,..,en] */
3020
3021     for (as=NIL; isAp(e); e=fun(e))
3022         as = cons(arg(e),as);
3023     return as;
3024 }
3025
3026 Cell nthArg(n,e)                       /* return nth arg in application    */
3027 Int  n;                                /* of function to m args (m>=n)     */
3028 Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
3029     for (n=numArgs(e)-n-1; n>0; n--)
3030         e = fun(e);
3031     return arg(e);
3032 }
3033
3034 Int numArgs(e)                         /* find number of arguments to expr */
3035 Cell e; {
3036     Int n;
3037     for (n=0; isAp(e); e=fun(e))
3038         n++;
3039     return n;
3040 }
3041
3042 Cell applyToArgs(f,args)               /* destructively apply list of args */
3043 Cell f;                                /* to function f                    */
3044 List args; {
3045     while (nonNull(args)) {
3046         Cell temp = tl(args);
3047         tl(args)  = hd(args);
3048         hd(args)  = f;
3049         f         = args;
3050         args      = temp;
3051     }
3052     return f;
3053 }
3054
3055 /* --------------------------------------------------------------------------
3056  * debugging support
3057  * ------------------------------------------------------------------------*/
3058
3059 /* Given the address of an info table, find the constructor/tuple
3060    that it belongs to, and return the name.  Only needed for debugging.
3061 */
3062 char* lookupHugsItblName ( void* v )
3063 {
3064    int i;
3065    for (i = TYCON_BASE_ADDR;
3066         i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3067       if (tabTycon[i-TYCON_BASE_ADDR].inUse
3068           && tycon(i).itbl == v)
3069          return textToStr(tycon(i).text);
3070    }
3071    for (i = NAME_BASE_ADDR;
3072         i < NAME_BASE_ADDR+tabNameSz; ++i) {
3073       if (tabName[i-NAME_BASE_ADDR].inUse
3074           && name(i).itbl == v)
3075          return textToStr(name(i).text);
3076    }
3077    return NULL;
3078 }
3079
3080 static String maybeModuleStr ( Module m )
3081 {
3082    if (isModule(m)) return textToStr(module(m).text); else return "??";
3083 }
3084
3085 static String maybeNameStr ( Name n )
3086 {
3087    if (isName(n)) return textToStr(name(n).text); else return "??";
3088 }
3089
3090 static String maybeTyconStr ( Tycon t )
3091 {
3092    if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
3093 }
3094
3095 static String maybeClassStr ( Class c )
3096 {
3097    if (isClass(c)) return textToStr(cclass(c).text); else return "??";
3098 }
3099
3100 static String maybeText ( Text t )
3101 {
3102    if (isNull(t)) return "(nil)";
3103    return textToStr(t);
3104 }
3105
3106 static void print100 ( Int x )
3107 {
3108    print ( x, 100); printf("\n");
3109 }
3110
3111 void dumpTycon ( Int t )
3112 {
3113    if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR;
3114    if (!isTycon(t)) {
3115       printf ( "dumpTycon %d: not a tycon\n", t);
3116       return;
3117    }
3118    printf ( "{\n" );
3119    printf ( "    text: %s\n",     textToStr(tycon(t).text) );
3120    printf ( "    line: %d\n",     tycon(t).line );
3121    printf ( "     mod: %s\n",     maybeModuleStr(tycon(t).mod));
3122    printf ( "   tuple: %d\n",     tycon(t).tuple);
3123    printf ( "   arity: %d\n",     tycon(t).arity);
3124    printf ( "    kind: ");        print100(tycon(t).kind);
3125    printf ( "    what: %d\n",     tycon(t).what);
3126    printf ( "    defn: ");        print100(tycon(t).defn);
3127    printf ( "    cToT: %d %s\n",  tycon(t).conToTag,
3128                                   maybeNameStr(tycon(t).conToTag));
3129    printf ( "    tToC: %d %s\n",  tycon(t).tagToCon,
3130                                   maybeNameStr(tycon(t).tagToCon));
3131    printf ( "    itbl: %p\n",     tycon(t).itbl);
3132    printf ( "  nextTH: %d %s\n",  tycon(t).nextTyconHash,
3133                                   maybeTyconStr(tycon(t).nextTyconHash));
3134    printf ( "}\n" );
3135 }
3136
3137 void dumpName ( Int n )
3138 {
3139    if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR;
3140    if (!isName(n)) {
3141       printf ( "dumpName %d: not a name\n", n);
3142       return;
3143    }
3144    printf ( "{\n" );
3145    printf ( "    text: %s\n",     textToStr(name(n).text) );
3146    printf ( "    line: %d\n",     name(n).line );
3147    printf ( "     mod: %s\n",     maybeModuleStr(name(n).mod));
3148    printf ( "  syntax: %d\n",     name(n).syntax );
3149    printf ( "  parent: %d\n",     name(n).parent );
3150    printf ( "   arity: %d\n",     name(n).arity );
3151    printf ( "  number: %d\n",     name(n).number );
3152    printf ( "    type: ");        print100(name(n).type);
3153    printf ( "    defn: %d\n",     name(n).defn );
3154    printf ( "   cconv: %d\n",     name(n).callconv );
3155    printf ( "  primop: %p\n",     name(n).primop );
3156    printf ( "    itbl: %p\n",     name(n).itbl );
3157    printf ( " closure: %d\n",     name(n).closure );
3158    printf ( "  nextNH: %d\n",     name(n).nextNameHash );
3159    printf ( "}\n" );
3160 }
3161
3162
3163 void dumpClass ( Int c )
3164 {
3165    if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR;
3166    if (!isClass(c)) {
3167       printf ( "dumpClass %d: not a class\n", c);
3168       return;
3169    }
3170    printf ( "{\n" );
3171    printf ( "    text: %s\n",     textToStr(cclass(c).text) );
3172    printf ( "    line: %d\n",     cclass(c).line );
3173    printf ( "     mod: %s\n",     maybeModuleStr(cclass(c).mod));
3174    printf ( "   arity: %d\n",     cclass(c).arity );
3175    printf ( "   level: %d\n",     cclass(c).level );
3176    printf ( "   kinds: ");        print100( cclass(c).kinds );
3177    printf ( "     fds: %d\n",     cclass(c).fds );
3178    printf ( "    xfds: %d\n",     cclass(c).xfds );
3179    printf ( "    head: ");        print100( cclass(c).head );
3180    printf ( "    dcon: ");        print100( cclass(c).dcon );
3181    printf ( "  supers: ");        print100( cclass(c).supers );
3182    printf ( " #supers: %d\n",     cclass(c).numSupers );
3183    printf ( "   dsels: ");        print100( cclass(c).dsels );
3184    printf ( " members: ");        print100( cclass(c).members );
3185    printf ( "#members: %d\n",     cclass(c).numMembers );
3186    printf ( "defaults: ");        print100( cclass(c).defaults );
3187    printf ( "   insts: ");        print100( cclass(c).instances );
3188    printf ( "}\n" );
3189 }
3190
3191
3192 void dumpInst ( Int i )
3193 {
3194    if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR;
3195    if (!isInst(i)) {
3196       printf ( "dumpInst %d: not an instance\n", i);
3197       return;
3198    }
3199    printf ( "{\n" );
3200    printf ( "   class: %s\n",     maybeClassStr(inst(i).c) );
3201    printf ( "    line: %d\n",     inst(i).line );
3202    printf ( "     mod: %s\n",     maybeModuleStr(inst(i).mod));
3203    printf ( "   kinds: ");        print100( inst(i).kinds );
3204    printf ( "    head: ");        print100( inst(i).head );
3205    printf ( "   specs: ");        print100( inst(i).specifics );
3206    printf ( "  #specs: %d\n",     inst(i).numSpecifics );
3207    printf ( "   impls: ");        print100( inst(i).implements );
3208    printf ( " builder: %s\n",     maybeNameStr( inst(i).builder ) );
3209    printf ( "}\n" );
3210 }
3211
3212
3213 /* --------------------------------------------------------------------------
3214  * storage control:
3215  * ------------------------------------------------------------------------*/
3216
3217 Void storage(what)
3218 Int what; {
3219     Int i;
3220
3221     switch (what) {
3222         case POSTPREL: break;
3223
3224         case RESET   : clearStack();
3225
3226                        /* the next 2 statements are particularly important
3227                         * if you are using GLOBALfst or GLOBALsnd since the
3228                         * corresponding registers may be reset to their
3229                         * uninitialised initial values by a longjump.
3230                         */
3231                        heapTopFst = heapFst + heapSize;
3232                        heapTopSnd = heapSnd + heapSize;
3233                        consGC = TRUE;
3234                        lsave  = NIL;
3235                        rsave  = NIL;
3236                        if (isNull(lastExprSaved))
3237                            savedText = TEXT_SIZE;
3238                        break;
3239
3240         case MARK    :
3241                        start();
3242                        for (i = NAME_BASE_ADDR;
3243                             i < NAME_BASE_ADDR+tabNameSz; ++i) {
3244                           if (tabName[i-NAME_BASE_ADDR].inUse) {
3245                              mark(name(i).parent);
3246                              mark(name(i).type);
3247                              mark(name(i).defn);
3248                              mark(name(i).closure);
3249                           }
3250                        }
3251                        end("Names", nameHw-NAMEMIN);
3252
3253                        start();
3254                        for (i = MODULE_BASE_ADDR;
3255                             i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
3256                           if (tabModule[i-MODULE_BASE_ADDR].inUse) {
3257                              mark(module(i).tycons);
3258                              mark(module(i).names);
3259                              mark(module(i).classes);
3260                              mark(module(i).exports);
3261                              mark(module(i).qualImports);
3262                              mark(module(i).codeList);
3263                              mark(module(i).tree);
3264                              mark(module(i).uses);
3265                              mark(module(i).objectExtraNames);
3266                           }
3267                        }
3268                        mark(moduleGraph);
3269                        mark(prelModules);
3270                        mark(targetModules);
3271                        end("Modules", moduleHw-MODMIN);
3272
3273                        start();
3274                        for (i = TYCON_BASE_ADDR;
3275                             i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3276                           if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
3277                              mark(tycon(i).kind);
3278                              mark(tycon(i).what);
3279                              mark(tycon(i).defn);
3280                              mark(tycon(i).closure);
3281                           }
3282                        }
3283                        end("Type constructors", tyconHw-TYCMIN);
3284
3285                        start();
3286                        for (i = CCLASS_BASE_ADDR;
3287                             i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
3288                           if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
3289                              mark(cclass(i).kinds);
3290                              mark(cclass(i).fds);
3291                              mark(cclass(i).xfds);
3292                              mark(cclass(i).head);
3293                              mark(cclass(i).supers);
3294                              mark(cclass(i).dsels);
3295                              mark(cclass(i).members);
3296                              mark(cclass(i).defaults);
3297                              mark(cclass(i).instances);
3298                           }
3299                        }
3300                        mark(classes);
3301                        end("Classes", classHw-CLASSMIN);
3302
3303                        start();
3304                        for (i = INST_BASE_ADDR;
3305                             i < INST_BASE_ADDR+tabInstSz; ++i) {
3306                           if (tabInst[i-INST_BASE_ADDR].inUse) {
3307                              mark(inst(i).kinds);
3308                              mark(inst(i).head);
3309                              mark(inst(i).specifics);
3310                              mark(inst(i).implements);
3311                           }
3312                        }
3313                        end("Instances", instHw-INSTMIN);
3314
3315                        start();
3316                        for (i=0; i<=sp; ++i)
3317                            mark(stack(i));
3318                        end("Stack", sp+1);
3319
3320                        start();
3321                        mark(lastExprSaved);
3322                        mark(lsave);
3323                        mark(rsave);
3324                        end("Last expression", 3);
3325
3326                        if (consGC) {
3327                            start();
3328                            gcCStack();
3329                            end("C stack", stackRoots);
3330                        }
3331
3332                        break;
3333
3334         case PREPREL : heapFst = heapAlloc(heapSize);
3335                        heapSnd = heapAlloc(heapSize);
3336
3337                        if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
3338                            ERRMSG(0) "Cannot allocate heap storage (%d cells)",
3339                                      heapSize
3340                            EEND;
3341                        }
3342
3343                        heapTopFst = heapFst + heapSize;
3344                        heapTopSnd = heapSnd + heapSize;
3345                        for (i=1; i<heapSize; ++i) {
3346                            fst(-i) = FREECELL;
3347                            snd(-i) = -(i+1);
3348                        }
3349                        snd(-heapSize) = NIL;
3350                        freeList  = -1;
3351                        numGcs    = 0;
3352                        consGC    = TRUE;
3353                        lsave     = NIL;
3354                        rsave     = NIL;
3355
3356                        marksSize  = bitArraySize(heapSize);
3357                        if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
3358                            ERRMSG(0) "Unable to allocate gc markspace"
3359                            EEND;
3360                        }
3361
3362                        clearStack();
3363
3364                        textHw        = 0;
3365                        nextNewText   = INVAR_BASE_ADDR;
3366                        nextNewDText  = INDVAR_BASE_ADDR;
3367                        lastExprSaved = NIL;
3368                        savedText     = TEXT_SIZE;
3369
3370                        for (i=0; i<TEXTHSZ;  ++i) textHash[i][0] = NOTEXT;
3371                        for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
3372                        for (i=0; i<NAMEHSZ;  ++i) nameHash[RC_N(i)] = NIL;
3373
3374                        break;
3375     }
3376 }
3377
3378 /*-------------------------------------------------------------------------*/