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