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.78 $
  13  * $Date: 2000/06/23 13:13:10 $
  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 (!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    /* speedup hack */
1925    if (!combined) return HUGS_SECTIONKIND_OTHER;
1926
1927    for (m = MODULE_BASE_ADDR;
1928         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1929       if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1930          if (tabModule[m-MODULE_BASE_ADDR].object) {
1931             sect = ocLookupSection ( tabModule[m-MODULE_BASE_ADDR].object, ad );
1932             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1933                return sect;
1934          }
1935          for (oc = tabModule[m-MODULE_BASE_ADDR].objectExtras; oc; oc=oc->next) {
1936             sect = ocLookupSection ( oc, ad );
1937             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1938                return sect;
1939          }
1940       }
1941    }
1942    return HUGS_SECTIONKIND_OTHER;
1943 }
1944
1945
1946 /* Called by the evaluator's GC to tell Hugs to mark stuff in the
1947    run-time heap.
1948 */
1949 void markHugsObjects( void )
1950 {
1951     Name  nm;
1952     Tycon tc;
1953
1954     for ( nm = NAME_BASE_ADDR;
1955           nm < NAME_BASE_ADDR+tabNameSz; ++nm ) {
1956        if (tabName[nm-NAME_BASE_ADDR].inUse) {
1957            Cell cl = tabName[nm-NAME_BASE_ADDR].closure;
1958            if (nonNull(cl)) {
1959               assert(isCPtr(cl));
1960               snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1961            }
1962        }
1963     }
1964
1965     for ( tc = TYCON_BASE_ADDR;
1966           tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) {
1967        if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
1968            Cell cl = tabTycon[tc-TYCON_BASE_ADDR].closure;
1969            if (nonNull(cl)) {
1970               assert(isCPtr(cl));
1971               snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1972            }
1973        }
1974     }
1975 }
1976
1977
1978 /* --------------------------------------------------------------------------
1979  * Heap storage:
1980  *
1981  * Provides a garbage collectable heap for storage of expressions etc.
1982  *
1983  * Now incorporates a flat resource:  A two-space collected extension of
1984  * the heap that provides storage for contiguous arrays of Cell storage,
1985  * cooperating with the garbage collection mechanisms for the main heap.
1986  * ------------------------------------------------------------------------*/
1987
1988 Int     heapSize = DEFAULTHEAP;         /* number of cells in heap         */
1989 Heap    heapFst;                        /* array of fst component of pairs */
1990 Heap    heapSnd;                        /* array of snd component of pairs */
1991 Heap    heapTopFst;
1992 Heap    heapTopSnd;
1993 Bool    consGC = TRUE;                  /* Set to FALSE to turn off gc from*/
1994                                         /* C stack; use with extreme care! */
1995 Long    numCells;
1996 int     numEnters;
1997 Int     numGcs;                         /* number of garbage collections   */
1998 Int     cellsRecovered;                 /* number of cells recovered       */
1999
2000 static  Cell freeList;                  /* free list of unused cells       */
2001 static  Cell lsave, rsave;              /* save components of pair         */
2002
2003 #if GC_STATISTICS
2004
2005 static Int markCount, stackRoots;
2006
2007 #define initStackRoots() stackRoots = 0
2008 #define recordStackRoot() stackRoots++
2009
2010 #define startGC()       \
2011     if (gcMessages) {   \
2012         Printf("\n");   \
2013         fflush(stdout); \
2014     }
2015 #define endGC()         \
2016     if (gcMessages) {   \
2017         Printf("\n");   \
2018         fflush(stdout); \
2019     }
2020
2021 #define start()      markCount = 0
2022 #define end(thing,rs) \
2023     if (gcMessages) { \
2024         Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
2025         fflush(stdout); \
2026     }
2027 #define recordMark() markCount++
2028
2029 #else /* !GC_STATISTICS */
2030
2031 #define startGC()
2032 #define endGC()
2033
2034 #define initStackRoots()
2035 #define recordStackRoot()
2036
2037 #define start()
2038 #define end(thing,root)
2039 #define recordMark()
2040
2041 #endif /* !GC_STATISTICS */
2042
2043 Cell pair(l,r)                          /* Allocate pair (l, r) from       */
2044 Cell l, r; {                            /* heap, garbage collecting first  */
2045     Cell c = freeList;                  /* if necessary ...                */
2046     if (isNull(c)) {
2047         lsave = l;
2048         rsave = r;
2049         garbageCollect();
2050         l     = lsave;
2051         lsave = NIL;
2052         r     = rsave;
2053         rsave = NIL;
2054         c     = freeList;
2055     }
2056     freeList = snd(freeList);
2057     fst(c)   = l;
2058     snd(c)   = r;
2059     numCells++;
2060     return c;
2061 }
2062
2063 static Int *marks;
2064 static Int marksSize;
2065
2066 void mark ( Cell root )
2067 {
2068    Cell c;
2069    Cell mstack[NUM_MSTACK];
2070    Int  msp     = -1;
2071    Int  msp_max = -1;
2072
2073    mstack[++msp] = root;
2074
2075    while (msp >= 0) {
2076       if (msp > msp_max) msp_max = msp;
2077       c = mstack[msp--];
2078       if (!isGenPair(c)) continue;
2079       if (fst(c)==FREECELL) continue;
2080       {
2081          register int place = placeInSet(c);
2082          register int mask  = maskInSet(c);
2083          if (!(marks[place]&mask)) {
2084             marks[place] |= mask;
2085             if (msp >= NUM_MSTACK-5) {
2086                fprintf ( stderr,
2087                          "hugs: fatal stack overflow during GC.  "
2088                          "Increase NUM_MSTACK.\n" );
2089                exit(9);
2090             }
2091             mstack[++msp] = fst(c);
2092             mstack[++msp] = snd(c);
2093          }
2094       }
2095    }
2096    //   fprintf(stderr, "%d ",msp_max);
2097 }
2098
2099
2100 Void garbageCollect()     {             /* Run garbage collector ...       */
2101                                         /* disable break checking          */
2102     Int i,j;
2103     register Int mask;
2104     register Int place;
2105     Int      recovered;
2106     jmp_buf  regs;                      /* save registers on stack         */
2107     HugsBreakAction oldBrk
2108        = setBreakAction ( HugsIgnoreBreak );
2109
2110     setjmp(regs);
2111
2112     gcStarted();
2113
2114     for (i=0; i<marksSize; ++i)         /* initialise mark set to empty    */
2115         marks[i] = 0;
2116
2117     everybody(MARK);                    /* Mark all components of system   */
2118
2119     gcScanning();                       /* scan mark set                   */
2120     mask      = 1;
2121     place     = 0;
2122     recovered = 0;
2123     j         = 0;
2124
2125     freeList = NIL;
2126     for (i=1; i<=heapSize; i++) {
2127         if ((marks[place] & mask) == 0) {
2128             snd(-i)  = freeList;
2129             fst(-i)  = FREECELL;
2130             freeList = -i;
2131             recovered++;
2132         }
2133         mask <<= 1;
2134         if (++j == bitsPerWord) {
2135             place++;
2136             mask = 1;
2137             j    = 0;
2138         }
2139     }
2140
2141     gcRecovered(recovered);
2142     setBreakAction ( oldBrk );
2143
2144     everybody(GCDONE);
2145
2146 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
2147     /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
2148 #endif
2149
2150     /* can only return if freeList is nonempty on return. */
2151     if (recovered<minRecovery || isNull(freeList)) {
2152         ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
2153         EEND;
2154     }
2155     cellsRecovered = recovered;
2156 }
2157
2158 /* --------------------------------------------------------------------------
2159  * Code for saving last expression entered:
2160  *
2161  * This is a little tricky because some text values (e.g. strings or variable
2162  * names) may not be defined or have the same value when the expression is
2163  * recalled.  These text values are therefore saved in the top portion of
2164  * the text table.
2165  * ------------------------------------------------------------------------*/
2166
2167 static Cell lastExprSaved;              /* last expression to be saved     */
2168
2169 Void setLastExpr(e)                     /* save expression for later recall*/
2170 Cell e; {
2171     lastExprSaved = NIL;                /* in case attempt to save fails   */
2172     savedText     = TEXT_SIZE;
2173     lastExprSaved = lowLevelLastIn(e);
2174 }
2175
2176 static Cell local lowLevelLastIn(c)     /* Duplicate expression tree (i.e. */
2177 Cell c; {                               /* acyclic graph) for later recall */
2178     if (isPair(c)) {                    /* Duplicating any text strings    */
2179         if (isTagNonPtr(fst(c)))        /* in case these are lost at some  */
2180             switch (fst(c)) {           /* point before the expr is reused */
2181                 case VARIDCELL :
2182                 case VAROPCELL :
2183                 case DICTVAR   :
2184                 case CONIDCELL :
2185                 case CONOPCELL :
2186                 case STRCELL   : return pair(fst(c),saveText(textOf(c)));
2187                 default        : return pair(fst(c),snd(c));
2188             }
2189         else
2190             return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
2191     }
2192 #if TREX
2193     else if (isExt(c))
2194         return pair(EXTCOPY,saveText(extText(c)));
2195 #endif
2196     else
2197         return c;
2198 }
2199
2200 Cell getLastExpr() {                    /* recover previously saved expr   */
2201     return lowLevelLastOut(lastExprSaved);
2202 }
2203
2204 static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
2205 Cell c; {                               /* except that Cells refering to   */
2206     if (isPair(c)) {                    /* Text values are restored to     */
2207         if (isTagNonPtr(fst(c)))        /* appropriate values              */
2208             switch (fst(c)) {
2209                 case VARIDCELL :
2210                 case VAROPCELL :
2211                 case DICTVAR   :
2212                 case CONIDCELL :
2213                 case CONOPCELL :
2214                 case STRCELL   : return pair(fst(c),
2215                                              findText(text+intValOf(c)));
2216 #if TREX
2217                 case EXTCOPY   : return mkExt(findText(text+intValOf(c)));
2218 #endif
2219                 default        : return pair(fst(c),snd(c));
2220             }
2221         else
2222             return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
2223     }
2224     else
2225         return c;
2226 }
2227
2228 /* --------------------------------------------------------------------------
2229  * Miscellaneous operations on heap cells:
2230  * ------------------------------------------------------------------------*/
2231
2232 /* Reordered 2 May 00 to have most common options first. */
2233 Cell whatIs ( register Cell c )
2234 {
2235     if (isPair(c)) {
2236         register Cell fstc = fst(c);
2237         return isTag(fstc) ? fstc : AP;
2238     }
2239     if (isTycon(c))            return TYCON;
2240     if (isOffset(c))           return OFFSET;
2241     if (isName(c))             return NAME;
2242     if (isInt(c))              return INTCELL;
2243     if (isTuple(c))            return TUPLE;
2244     if (isSpec(c))             return c;
2245     if (isClass(c))            return CLASS;
2246     if (isChar(c))             return CHARCELL;
2247     if (isNull(c))             return c;
2248     if (isInst(c))             return INSTANCE;
2249     if (isModule(c))           return MODULE;
2250     if (isText(c))             return TEXTCELL;
2251     if (isInventedVar(c))      return INVAR;
2252     if (isInventedDictVar(c))  return INDVAR;
2253     fprintf ( stderr, "whatIs: unknown %d\n", c );
2254     internal("whatIs");
2255 }
2256
2257
2258
2259 /* A very, very simple printer.
2260  * Output is uglier than from printExp - but the printer is more
2261  * robust and can be used on any data structure irrespective of
2262  * its type.
2263  */
2264 Void print ( Cell c, Int depth )
2265 {
2266     if (0 == depth) {
2267         Printf("...");
2268     }
2269     else if (isNull(c)) {
2270        Printf("NIL");
2271     }
2272     else if (isTagPtr(c)) {
2273         Printf("TagP(%d)", c);
2274     }
2275     else if (isTagNonPtr(c)) {
2276         Printf("TagNP(%d)", c);
2277     }
2278     else if (isSpec(c) && c != STAR) {
2279         Printf("TagS(%d)", c);
2280     }
2281     else if (isText(c)) {
2282         Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c));
2283     }
2284     else if (isInventedVar(c)) {
2285         Printf("invented(%d)", c-INVAR_BASE_ADDR);
2286     }
2287     else if (isInventedDictVar(c)) {
2288         Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR);
2289     }
2290     else {
2291         Int tag = whatIs(c);
2292         switch (tag) {
2293         case AP:
2294                 Putchar('(');
2295                 print(fst(c), depth-1);
2296                 Putchar(',');
2297                 print(snd(c), depth-1);
2298                 Putchar(')');
2299                 break;
2300         case FREECELL:
2301                 Printf("free(%d)", c);
2302                 break;
2303         case INTCELL:
2304                 Printf("int(%d)", intOf(c));
2305                 break;
2306         case BIGCELL:
2307                 Printf("bignum(%s)", bignumToString(c));
2308                 break;
2309         case CHARCELL:
2310                 Printf("char('%c')", charOf(c));
2311                 break;
2312         case STRCELL:
2313                 Printf("strcell(\"%s\")",textToStr(snd(c)));
2314                 break;
2315         case MPTRCELL:
2316                 Printf("mptr(%p)",mptrOf(c));
2317                 break;
2318         case CPTRCELL:
2319                 Printf("cptr(%p)",cptrOf(c));
2320                 break;
2321         case ADDRCELL:
2322                 Printf("addr(%p)",addrOf(c));
2323                 break;
2324         case CLASS:
2325                 Printf("class(%d)", c-CCLASS_BASE_ADDR);
2326                 Printf("=\"%s\"", textToStr(cclass(c).text));
2327                 break;
2328         case INSTANCE:
2329                 Printf("instance(%d)", c - INST_BASE_ADDR);
2330                 break;
2331         case NAME:
2332                 Printf("name(%d)", c-NAME_BASE_ADDR);
2333                 Printf("=\"%s\"", textToStr(name(c).text));
2334                 break;
2335         case TYCON:
2336                 Printf("tycon(%d)", c-TYCON_BASE_ADDR);
2337                 Printf("=\"%s\"", textToStr(tycon(c).text));
2338                 break;
2339         case MODULE:
2340                 Printf("module(%d)", c - MODULE_BASE_ADDR);
2341                 Printf("=\"%s\"", textToStr(module(c).text));
2342                 break;
2343         case OFFSET:
2344                 Printf("Offset %d", offsetOf(c));
2345                 break;
2346         case TUPLE:
2347                 Printf("%s", textToStr(ghcTupleText(c)));
2348                 break;
2349         case POLYTYPE:
2350                 Printf("Polytype");
2351                 print(snd(c),depth-1);
2352                 break;
2353         case QUAL:
2354                 Printf("Qualtype");
2355                 print(snd(c),depth-1);
2356                 break;
2357         case RANK2:
2358                 Printf("Rank2(");
2359                 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
2360                     Printf("%d ", intOf(fst(snd(c))));
2361                     print(snd(snd(c)),depth-1);
2362                 } else {
2363                     print(snd(c),depth-1);
2364                 }
2365                 Printf(")");
2366                 break;
2367         case WILDCARD:
2368                 Printf("_");
2369                 break;
2370         case STAR:
2371                 Printf("STAR");
2372                 break;
2373         case DOTDOT:
2374                 Printf("DOTDOT");
2375                 break;
2376         case DICTVAR:
2377                 Printf("{dict %d}",textOf(c));
2378                 break;
2379         case VARIDCELL:
2380         case VAROPCELL:
2381         case CONIDCELL:
2382         case CONOPCELL:
2383                 Printf("{id %s}",textToStr(textOf(c)));
2384                 break;
2385 #if IPARAM
2386           case IPCELL :
2387               Printf("{ip %s}",textToStr(textOf(c)));
2388               break;
2389           case IPVAR :
2390               Printf("?%s",textToStr(textOf(c)));
2391               break;
2392 #endif
2393         case QUALIDENT:
2394                 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
2395                 break;
2396         case LETREC:
2397                 Printf("LetRec(");
2398                 print(fst(snd(c)),depth-1);
2399                 Putchar(',');
2400                 print(snd(snd(c)),depth-1);
2401                 Putchar(')');
2402                 break;
2403         case LAMBDA:
2404                 Printf("Lambda(");
2405                 print(snd(c),depth-1);
2406                 Putchar(')');
2407                 break;
2408         case FINLIST:
2409                 Printf("FinList(");
2410                 print(snd(c),depth-1);
2411                 Putchar(')');
2412                 break;
2413         case COMP:
2414                 Printf("Comp(");
2415                 print(fst(snd(c)),depth-1);
2416                 Putchar(',');
2417                 print(snd(snd(c)),depth-1);
2418                 Putchar(')');
2419                 break;
2420         case ASPAT:
2421                 Printf("AsPat(");
2422                 print(fst(snd(c)),depth-1);
2423                 Putchar(',');
2424                 print(snd(snd(c)),depth-1);
2425                 Putchar(')');
2426                 break;
2427         case FROMQUAL:
2428                 Printf("FromQual(");
2429                 print(fst(snd(c)),depth-1);
2430                 Putchar(',');
2431                 print(snd(snd(c)),depth-1);
2432                 Putchar(')');
2433                 break;
2434         case STGVAR:
2435                 Printf("StgVar%d=",-c);
2436                 print(snd(c), depth-1);
2437                 break;
2438         case STGAPP:
2439                 Printf("StgApp(");
2440                 print(fst(snd(c)),depth-1);
2441                 Putchar(',');
2442                 print(snd(snd(c)),depth-1);
2443                 Putchar(')');
2444                 break;
2445         case STGPRIM:
2446                 Printf("StgPrim(");
2447                 print(fst(snd(c)),depth-1);
2448                 Putchar(',');
2449                 print(snd(snd(c)),depth-1);
2450                 Putchar(')');
2451                 break;
2452         case STGCON:
2453                 Printf("StgCon(");
2454                 print(fst(snd(c)),depth-1);
2455                 Putchar(',');
2456                 print(snd(snd(c)),depth-1);
2457                 Putchar(')');
2458                 break;
2459         case PRIMCASE:
2460                 Printf("PrimCase(");
2461                 print(fst(snd(c)),depth-1);
2462                 Putchar(',');
2463                 print(snd(snd(c)),depth-1);
2464                 Putchar(')');
2465                 break;
2466         case DICTAP:
2467                 Printf("(DICTAP,");
2468                 print(snd(c),depth-1);
2469                 Putchar(')');
2470                 break;
2471         case UNBOXEDTUP:
2472                 Printf("(UNBOXEDTUP,");
2473                 print(snd(c),depth-1);
2474                 Putchar(')');
2475                 break;
2476         case ZTUP2:
2477                 Printf("<ZPair ");
2478                 print(zfst(c),depth-1);
2479                 Putchar(' ');
2480                 print(zsnd(c),depth-1);
2481                 Putchar('>');
2482                 break;
2483         case ZTUP3:
2484                 Printf("<ZTriple ");
2485                 print(zfst3(c),depth-1);
2486                 Putchar(' ');
2487                 print(zsnd3(c),depth-1);
2488                 Putchar(' ');
2489                 print(zthd3(c),depth-1);
2490                 Putchar('>');
2491                 break;
2492         case BANG:
2493                 Printf("(BANG,");
2494                 print(snd(c),depth-1);
2495                 Putchar(')');
2496                 break;
2497         default:
2498                 if (isTagNonPtr(tag)) {
2499                     Printf("(TagNP=%d,%d)", c, tag);
2500                 } else if (isTagPtr(tag)) {
2501                     Printf("(TagP=%d,",tag);
2502                     print(snd(c), depth-1);
2503                     Putchar(')');
2504                     break;
2505                 } else if (c == tag) {
2506                     Printf("Tag(%d)", c);
2507                 } else {
2508                     Printf("Tag(%d)=%d", c, tag);
2509                 }
2510                 break;
2511         }
2512     }
2513     FlushStdout();
2514 }
2515
2516
2517 Bool isVar(c)                           /* is cell a VARIDCELL/VAROPCELL ? */
2518 Cell c; {                               /* also recognises DICTVAR cells   */
2519     return isPair(c) &&
2520                (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
2521 }
2522
2523 Bool isCon(c)                          /* is cell a CONIDCELL/CONOPCELL ?  */
2524 Cell c; {
2525     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
2526 }
2527
2528 Bool isQVar(c)                        /* is cell a [un]qualified varop/id? */
2529 Cell c; {
2530     if (!isPair(c)) return FALSE;
2531     switch (fst(c)) {
2532         case VARIDCELL  :
2533         case VAROPCELL  : return TRUE;
2534
2535         case QUALIDENT  : return isVar(snd(snd(c)));
2536
2537         default         : return FALSE;
2538     }
2539 }
2540
2541 Bool isQCon(c)                         /*is cell a [un]qualified conop/id? */
2542 Cell c; {
2543     if (!isPair(c)) return FALSE;
2544     switch (fst(c)) {
2545         case CONIDCELL  :
2546         case CONOPCELL  : return TRUE;
2547
2548         case QUALIDENT  : return isCon(snd(snd(c)));
2549
2550         default         : return FALSE;
2551     }
2552 }
2553
2554 Bool isQualIdent(c)                    /* is cell a qualified identifier?  */
2555 Cell c; {
2556     return isPair(c) && (fst(c)==QUALIDENT);
2557 }
2558
2559 Bool eqQualIdent ( QualId c1, QualId c2 )
2560 {
2561    assert(isQualIdent(c1));
2562    if (!isQualIdent(c2)) {
2563    assert(isQualIdent(c2));
2564    }
2565    return qmodOf(c1)==qmodOf(c2) &&
2566           qtextOf(c1)==qtextOf(c2);
2567 }
2568
2569 Bool isIdent(c)                        /* is cell an identifier?           */
2570 Cell c; {
2571     if (!isPair(c)) return FALSE;
2572     switch (fst(c)) {
2573         case VARIDCELL  :
2574         case VAROPCELL  :
2575         case CONIDCELL  :
2576         case CONOPCELL  : return TRUE;
2577
2578         case QUALIDENT  : return TRUE;
2579
2580         default         : return FALSE;
2581     }
2582 }
2583
2584 Bool isInt(c)                          /* cell holds integer value?        */
2585 Cell c; {
2586     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
2587 }
2588
2589 Int intOf(c)                           /* find integer value of cell?      */
2590 Cell c; {
2591     assert(isInt(c));
2592     return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO);
2593 }
2594
2595 Cell mkInt(n)                          /* make cell representing integer   */
2596 Int n; {
2597     return (SMALL_INT_MIN    <= SMALL_INT_ZERO+n &&
2598             SMALL_INT_ZERO+n <= SMALL_INT_MAX)
2599            ? SMALL_INT_ZERO+n
2600            : pair(INTCELL,n);
2601 }
2602
2603 #if SIZEOF_VOID_P == SIZEOF_INT
2604
2605 typedef union {Int i; Ptr p;} IntOrPtr;
2606
2607 Cell mkAddr(p)
2608 Ptr p;
2609 {
2610     IntOrPtr x;
2611     x.p = p;
2612     return pair(ADDRCELL,x.i);
2613 }
2614
2615 Ptr addrOf(c)
2616 Cell c;
2617 {
2618     IntOrPtr x;
2619     assert(fst(c) == ADDRCELL);
2620     x.i = snd(c);
2621     return x.p;
2622 }
2623
2624 Cell mkMPtr(p)
2625 Ptr p;
2626 {
2627     IntOrPtr x;
2628     x.p = p;
2629     return pair(MPTRCELL,x.i);
2630 }
2631
2632 Ptr mptrOf(c)
2633 Cell c;
2634 {
2635     IntOrPtr x;
2636     assert(fst(c) == MPTRCELL);
2637     x.i = snd(c);
2638     return x.p;
2639 }
2640
2641 Cell mkCPtr(p)
2642 Ptr p;
2643 {
2644     IntOrPtr x;
2645     x.p = p;
2646     return pair(CPTRCELL,x.i);
2647 }
2648
2649 Ptr cptrOf(c)
2650 Cell c;
2651 {
2652     IntOrPtr x;
2653     assert(fst(c) == CPTRCELL);
2654     x.i = snd(c);
2655     return x.p;
2656 }
2657
2658 #elif SIZEOF_VOID_P == 2*SIZEOF_INT
2659
2660 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2661
2662 Cell mkPtr(p)
2663 Ptr p;
2664 {
2665     IntOrPtr x;
2666     x.p = p;
2667     return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2668 }
2669
2670 Ptr ptrOf(c)
2671 Cell c;
2672 {
2673     IntOrPtr x;
2674     assert(fst(c) == PTRCELL);
2675     x.i.i1 = intOf(fst(snd(c)));
2676     x.i.i2 = intOf(snd(snd(c)));
2677     return x.p;
2678 }
2679
2680 Cell mkCPtr(p)
2681 Ptr p;
2682 {
2683     IntOrPtr x;
2684     x.p = p;
2685     return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2686 }
2687
2688 Ptr cptrOf(c)
2689 Cell c;
2690 {
2691     IntOrPtr x;
2692     assert(fst(c) == CPTRCELL);
2693     x.i.i1 = intOf(fst(snd(c)));
2694     x.i.i2 = intOf(snd(snd(c)));
2695     return x.p;
2696 }
2697
2698 #else
2699
2700 #error "Can't implement mkPtr/ptrOf on this architecture."
2701
2702 #endif
2703
2704
2705 String stringNegate( s )
2706 String s;
2707 {
2708     if (s[0] == '-') {
2709         return &s[1];
2710     } else {
2711         static char t[100];
2712         t[0] = '-';
2713         strcpy(&t[1],s);  /* ToDo: use strncpy instead */
2714         return t;
2715     }
2716 }
2717
2718 /* --------------------------------------------------------------------------
2719  * List operations:
2720  * ------------------------------------------------------------------------*/
2721
2722 Int length(xs)                         /* calculate length of list xs      */
2723 List xs; {
2724     Int n = 0;
2725     for (; nonNull(xs); ++n)
2726         xs = tl(xs);
2727     return n;
2728 }
2729
2730 List appendOnto(xs,ys)                 /* Destructively prepend xs onto    */
2731 List xs, ys; {                         /* ys by modifying xs ...           */
2732     if (isNull(xs))
2733         return ys;
2734     else {
2735         List zs = xs;
2736         while (nonNull(tl(zs)))
2737             zs = tl(zs);
2738         tl(zs) = ys;
2739         return xs;
2740     }
2741 }
2742
2743 List dupOnto(xs,ys)      /* non-destructively prepend xs backwards onto ys */
2744 List xs;
2745 List ys; {
2746     for (; nonNull(xs); xs=tl(xs))
2747         ys = cons(hd(xs),ys);
2748     return ys;
2749 }
2750
2751 List dupListOnto(xs,ys)              /* Duplicate spine of list xs onto ys */
2752 List xs;
2753 List ys; {
2754     return revOnto(dupOnto(xs,NIL),ys);
2755 }
2756
2757 List dupList(xs)                       /* Duplicate spine of list xs       */
2758 List xs; {
2759     List ys = NIL;
2760     for (; nonNull(xs); xs=tl(xs))
2761         ys = cons(hd(xs),ys);
2762     return rev(ys);
2763 }
2764
2765 List revOnto(xs,ys)                    /* Destructively reverse elements of*/
2766 List xs, ys; {                         /* list xs onto list ys...          */
2767     Cell zs;
2768
2769     while (nonNull(xs)) {
2770         zs     = tl(xs);
2771         tl(xs) = ys;
2772         ys     = xs;
2773         xs     = zs;
2774     }
2775     return ys;
2776 }
2777
2778 QualId qualidIsMember ( QualId q, List xs )
2779 {
2780    for (; nonNull(xs); xs=tl(xs)) {
2781       if (eqQualIdent(q, hd(xs)))
2782          return hd(xs);
2783    }
2784    return NIL;
2785 }
2786
2787 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
2788 Text t;                                /* given list of variables          */
2789 List xs; {
2790     assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
2791     for (; nonNull(xs); xs=tl(xs))
2792         if (t==textOf(hd(xs)))
2793             return hd(xs);
2794     return NIL;
2795 }
2796
2797 Name nameIsMember(t,ns)                 /* Test if name with text t is a   */
2798 Text t;                                 /* member of list of names xs      */
2799 List ns; {
2800     for (; nonNull(ns); ns=tl(ns))
2801         if (t==name(hd(ns)).text)
2802             return hd(ns);
2803     return NIL;
2804 }
2805
2806 Cell intIsMember(n,xs)                 /* Test if integer n is member of   */
2807 Int  n;                                /* given list of integers           */
2808 List xs; {
2809     for (; nonNull(xs); xs=tl(xs))
2810         if (n==intOf(hd(xs)))
2811             return hd(xs);
2812     return NIL;
2813 }
2814
2815 Cell cellIsMember(x,xs)                /* Test for membership of specific  */
2816 Cell x;                                /* cell x in list xs                */
2817 List xs; {
2818     for (; nonNull(xs); xs=tl(xs))
2819         if (x==hd(xs))
2820             return hd(xs);
2821     return NIL;
2822 }
2823
2824 Cell cellAssoc(c,xs)                   /* Lookup cell in association list  */
2825 Cell c;
2826 List xs; {
2827     for (; nonNull(xs); xs=tl(xs))
2828         if (c==fst(hd(xs)))
2829             return hd(xs);
2830     return NIL;
2831 }
2832
2833 Cell cellRevAssoc(c,xs)                /* Lookup cell in range of          */
2834 Cell c;                                /* association lists                */
2835 List xs; {
2836     for (; nonNull(xs); xs=tl(xs))
2837         if (c==snd(hd(xs)))
2838             return hd(xs);
2839     return NIL;
2840 }
2841
2842 List replicate(n,x)                     /* create list of n copies of x    */
2843 Int n;
2844 Cell x; {
2845     List xs=NIL;
2846     while (0<n--)
2847         xs = cons(x,xs);
2848     return xs;
2849 }
2850
2851 List diffList(from,take)               /* list difference: from\take       */
2852 List from, take; {                     /* result contains all elements of  */
2853     List result = NIL;                 /* `from' not appearing in `take'   */
2854
2855     while (nonNull(from)) {
2856         List next = tl(from);
2857         if (!cellIsMember(hd(from),take)) {
2858             tl(from) = result;
2859             result   = from;
2860         }
2861         from = next;
2862     }
2863     return rev(result);
2864 }
2865
2866 List deleteCell(xs, y)                  /* copy xs deleting pointers to y  */
2867 List xs;
2868 Cell y; {
2869     List result = NIL;
2870     for(;nonNull(xs);xs=tl(xs)) {
2871         Cell x = hd(xs);
2872         if (x != y) {
2873             result=cons(x,result);
2874         }
2875     }
2876     return rev(result);
2877 }
2878
2879 List take(n,xs)                         /* destructively truncate list to  */
2880 Int  n;                                 /* specified length                */
2881 List xs; {
2882     List ys = xs;
2883
2884     if (n==0)
2885         return NIL;
2886     while (1<n-- && nonNull(xs))
2887         xs = tl(xs);
2888     if (nonNull(xs))
2889         tl(xs) = NIL;
2890     return ys;
2891 }
2892
2893 List splitAt(n,xs)                      /* drop n things from front of list*/
2894 Int  n;
2895 List xs; {
2896     for(; n>0; --n) {
2897         xs = tl(xs);
2898     }
2899     return xs;
2900 }
2901
2902 Cell nth(n,xs)                          /* extract n'th element of list    */
2903 Int  n;
2904 List xs; {
2905     for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2906     }
2907     if (isNull(xs))
2908         internal("nth");
2909     return hd(xs);
2910 }
2911
2912 List removeCell(x,xs)                   /* destructively remove cell from  */
2913 Cell x;                                 /* list                            */
2914 List xs; {
2915     if (nonNull(xs)) {
2916         if (hd(xs)==x)
2917             return tl(xs);              /* element at front of list        */
2918         else {
2919             List prev = xs;
2920             List curr = tl(xs);
2921             for (; nonNull(curr); prev=curr, curr=tl(prev))
2922                 if (hd(curr)==x) {
2923                     tl(prev) = tl(curr);
2924                     return xs;          /* element in middle of list       */
2925                 }
2926         }
2927     }
2928     return xs;                          /* here if element not found       */
2929 }
2930
2931 List nubList(xs)                        /* nuke dups in list               */
2932 List xs; {                              /* non destructive                 */
2933    List outs = NIL;
2934    for (; nonNull(xs); xs=tl(xs))
2935       if (isNull(cellIsMember(hd(xs),outs)))
2936          outs = cons(hd(xs),outs);
2937    outs = rev(outs);
2938    return outs;
2939 }
2940
2941
2942 /* --------------------------------------------------------------------------
2943  * Tagged tuples (experimental)
2944  * ------------------------------------------------------------------------*/
2945
2946 static void z_tag_check ( Cell x, int tag, char* caller )
2947 {
2948    char buf[100];
2949    if (isNull(x)) {
2950       sprintf(buf,"z_tag_check(%s): null\n", caller);
2951       internal(buf);
2952    }
2953    if (whatIs(x) != tag) {
2954       sprintf(buf,
2955           "z_tag_check(%s): tag was %d, expected %d\n",
2956           caller, whatIs(x), tag );
2957       internal(buf);
2958    }
2959 }
2960
2961 Cell zpair ( Cell x1, Cell x2 )
2962 { return ap(ZTUP2,ap(x1,x2)); }
2963 Cell zfst ( Cell zpair )
2964 { z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
2965 Cell zsnd ( Cell zpair )
2966 { z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
2967
2968 Cell ztriple ( Cell x1, Cell x2, Cell x3 )
2969 { return ap(ZTUP3,ap(x1,ap(x2,x3))); }
2970 Cell zfst3 ( Cell zpair )
2971 { z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
2972 Cell zsnd3 ( Cell zpair )
2973 { z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
2974 Cell zthd3 ( Cell zpair )
2975 { z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
2976
2977 Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
2978 { return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
2979 Cell zsel14 ( Cell zpair )
2980 { z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
2981 Cell zsel24 ( Cell zpair )
2982 { z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
2983 Cell zsel34 ( Cell zpair )
2984 { z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
2985 Cell zsel44 ( Cell zpair )
2986 { z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
2987
2988 Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
2989 { return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
2990 Cell zsel15 ( Cell zpair )
2991 { z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
2992 Cell zsel25 ( Cell zpair )
2993 { z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
2994 Cell zsel35 ( Cell zpair )
2995 { z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
2996 Cell zsel45 ( Cell zpair )
2997 { z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
2998 Cell zsel55 ( Cell zpair )
2999 { z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
3000
3001
3002 Cell unap ( int tag, Cell c )
3003 {
3004    char buf[100];
3005    if (whatIs(c) != tag) {
3006       sprintf(buf, "unap: specified %d, actual %d\n",
3007                    tag, whatIs(c) );
3008       internal(buf);
3009    }
3010    return snd(c);
3011 }
3012
3013 /* --------------------------------------------------------------------------
3014  * Operations on applications:
3015  * ------------------------------------------------------------------------*/
3016
3017 Int argCount;                          /* number of args in application    */
3018
3019 Cell getHead(e)                        /* get head cell of application     */
3020 Cell e; {                              /* set number of args in argCount   */
3021     for (argCount=0; isAp(e); e=fun(e))
3022         argCount++;
3023     return e;
3024 }
3025
3026 List getArgs(e)                        /* get list of arguments in function*/
3027 Cell e; {                              /* application:                     */
3028     List as;                           /* getArgs(f e1 .. en) = [e1,..,en] */
3029
3030     for (as=NIL; isAp(e); e=fun(e))
3031         as = cons(arg(e),as);
3032     return as;
3033 }
3034
3035 Cell nthArg(n,e)                       /* return nth arg in application    */
3036 Int  n;                                /* of function to m args (m>=n)     */
3037 Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
3038     for (n=numArgs(e)-n-1; n>0; n--)
3039         e = fun(e);
3040     return arg(e);
3041 }
3042
3043 Int numArgs(e)                         /* find number of arguments to expr */
3044 Cell e; {
3045     Int n;
3046     for (n=0; isAp(e); e=fun(e))
3047         n++;
3048     return n;
3049 }
3050
3051 Cell applyToArgs(f,args)               /* destructively apply list of args */
3052 Cell f;                                /* to function f                    */
3053 List args; {
3054     while (nonNull(args)) {
3055         Cell temp = tl(args);
3056         tl(args)  = hd(args);
3057         hd(args)  = f;
3058         f         = args;
3059         args      = temp;
3060     }
3061     return f;
3062 }
3063
3064 /* --------------------------------------------------------------------------
3065  * debugging support
3066  * ------------------------------------------------------------------------*/
3067
3068 /* Given the address of an info table, find the constructor/tuple
3069    that it belongs to, and return the name.  Only needed for debugging.
3070 */
3071 char* lookupHugsItblName ( void* v )
3072 {
3073    int i;
3074    for (i = TYCON_BASE_ADDR;
3075         i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3076       if (tabTycon[i-TYCON_BASE_ADDR].inUse
3077           && tycon(i).itbl == v)
3078          return textToStr(tycon(i).text);
3079    }
3080    for (i = NAME_BASE_ADDR;
3081         i < NAME_BASE_ADDR+tabNameSz; ++i) {
3082       if (tabName[i-NAME_BASE_ADDR].inUse
3083           && name(i).itbl == v)
3084          return textToStr(name(i).text);
3085    }
3086    return NULL;
3087 }
3088
3089 static String maybeModuleStr ( Module m )
3090 {
3091    if (isModule(m)) return textToStr(module(m).text); else return "??";
3092 }
3093
3094 static String maybeNameStr ( Name n )
3095 {
3096    if (isName(n)) return textToStr(name(n).text); else return "??";
3097 }
3098
3099 static String maybeTyconStr ( Tycon t )
3100 {
3101    if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
3102 }
3103
3104 static String maybeClassStr ( Class c )
3105 {
3106    if (isClass(c)) return textToStr(cclass(c).text); else return "??";
3107 }
3108
3109 static String maybeText ( Text t )
3110 {
3111    if (isNull(t)) return "(nil)";
3112    return textToStr(t);
3113 }
3114
3115 static void print100 ( Int x )
3116 {
3117    print ( x, 100); printf("\n");
3118 }
3119
3120 void dumpTycon ( Int t )
3121 {
3122    if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR;
3123    if (!isTycon(t)) {
3124       printf ( "dumpTycon %d: not a tycon\n", t);
3125       return;
3126    }
3127    printf ( "{\n" );
3128    printf ( "    text: %s\n",     textToStr(tycon(t).text) );
3129    printf ( "    line: %d\n",     tycon(t).line );
3130    printf ( "     mod: %s\n",     maybeModuleStr(tycon(t).mod));
3131    printf ( "   tuple: %d\n",     tycon(t).tuple);
3132    printf ( "   arity: %d\n",     tycon(t).arity);
3133    printf ( "    kind: ");        print100(tycon(t).kind);
3134    printf ( "    what: %d\n",     tycon(t).what);
3135    printf ( "    defn: ");        print100(tycon(t).defn);
3136    printf ( "    cToT: %d %s\n",  tycon(t).conToTag,
3137                                   maybeNameStr(tycon(t).conToTag));
3138    printf ( "    tToC: %d %s\n",  tycon(t).tagToCon,
3139                                   maybeNameStr(tycon(t).tagToCon));
3140    printf ( "    itbl: %p\n",     tycon(t).itbl);
3141    printf ( "  nextTH: %d %s\n",  tycon(t).nextTyconHash,
3142                                   maybeTyconStr(tycon(t).nextTyconHash));
3143    printf ( "}\n" );
3144 }
3145
3146 void dumpName ( Int n )
3147 {
3148    if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR;
3149    if (!isName(n)) {
3150       printf ( "dumpName %d: not a name\n", n);
3151       return;
3152    }
3153    printf ( "{\n" );
3154    printf ( "    text: %s\n",     textToStr(name(n).text) );
3155    printf ( "    line: %d\n",     name(n).line );
3156    printf ( "     mod: %s\n",     maybeModuleStr(name(n).mod));
3157    printf ( "  syntax: %d\n",     name(n).syntax );
3158    printf ( "  parent: %d\n",     name(n).parent );
3159    printf ( "   arity: %d\n",     name(n).arity );
3160    printf ( "  number: %d\n",     name(n).number );
3161    printf ( "    type: ");        print100(name(n).type);
3162    printf ( "    defn: %d\n",     name(n).defn );
3163    printf ( "   cconv: %d\n",     name(n).callconv );
3164    printf ( "  primop: %p\n",     name(n).primop );
3165    printf ( "    itbl: %p\n",     name(n).itbl );
3166    printf ( " closure: %d\n",     name(n).closure );
3167    printf ( "  nextNH: %d\n",     name(n).nextNameHash );
3168    printf ( "}\n" );
3169 }
3170
3171
3172 void dumpClass ( Int c )
3173 {
3174    if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR;
3175    if (!isClass(c)) {
3176       printf ( "dumpClass %d: not a class\n", c);
3177       return;
3178    }
3179    printf ( "{\n" );
3180    printf ( "    text: %s\n",     textToStr(cclass(c).text) );
3181    printf ( "    line: %d\n",     cclass(c).line );
3182    printf ( "     mod: %s\n",     maybeModuleStr(cclass(c).mod));
3183    printf ( "   arity: %d\n",     cclass(c).arity );
3184    printf ( "   level: %d\n",     cclass(c).level );
3185    printf ( "   kinds: ");        print100( cclass(c).kinds );
3186    printf ( "     fds: %d\n",     cclass(c).fds );
3187    printf ( "    xfds: %d\n",     cclass(c).xfds );
3188    printf ( "    head: ");        print100( cclass(c).head );
3189    printf ( "    dcon: ");        print100( cclass(c).dcon );
3190    printf ( "  supers: ");        print100( cclass(c).supers );
3191    printf ( " #supers: %d\n",     cclass(c).numSupers );
3192    printf ( "   dsels: ");        print100( cclass(c).dsels );
3193    printf ( " members: ");        print100( cclass(c).members );
3194    printf ( "#members: %d\n",     cclass(c).numMembers );
3195    printf ( "defaults: ");        print100( cclass(c).defaults );
3196    printf ( "   insts: ");        print100( cclass(c).instances );
3197    printf ( "}\n" );
3198 }
3199
3200
3201 void dumpInst ( Int i )
3202 {
3203    if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR;
3204    if (!isInst(i)) {
3205       printf ( "dumpInst %d: not an instance\n", i);
3206       return;
3207    }
3208    printf ( "{\n" );
3209    printf ( "   class: %s\n",     maybeClassStr(inst(i).c) );
3210    printf ( "    line: %d\n",     inst(i).line );
3211    printf ( "     mod: %s\n",     maybeModuleStr(inst(i).mod));
3212    printf ( "   kinds: ");        print100( inst(i).kinds );
3213    printf ( "    head: ");        print100( inst(i).head );
3214    printf ( "   specs: ");        print100( inst(i).specifics );
3215    printf ( "  #specs: %d\n",     inst(i).numSpecifics );
3216    printf ( "   impls: ");        print100( inst(i).implements );
3217    printf ( " builder: %s\n",     maybeNameStr( inst(i).builder ) );
3218    printf ( "}\n" );
3219 }
3220
3221
3222 /* --------------------------------------------------------------------------
3223  * storage control:
3224  * ------------------------------------------------------------------------*/
3225
3226 Void storage(what)
3227 Int what; {
3228     Int i;
3229
3230     switch (what) {
3231         case POSTPREL: break;
3232
3233         case RESET   : clearStack();
3234
3235                        /* the next 2 statements are particularly important
3236                         * if you are using GLOBALfst or GLOBALsnd since the
3237                         * corresponding registers may be reset to their
3238                         * uninitialised initial values by a longjump.
3239                         */
3240                        heapTopFst = heapFst + heapSize;
3241                        heapTopSnd = heapSnd + heapSize;
3242                        consGC = TRUE;
3243                        lsave  = NIL;
3244                        rsave  = NIL;
3245                        if (isNull(lastExprSaved))
3246                            savedText = TEXT_SIZE;
3247                        break;
3248
3249         case MARK    :
3250                        start();
3251                        for (i = NAME_BASE_ADDR;
3252                             i < NAME_BASE_ADDR+tabNameSz; ++i) {
3253                           if (tabName[i-NAME_BASE_ADDR].inUse) {
3254                              mark(name(i).parent);
3255                              mark(name(i).type);
3256                              mark(name(i).defn);
3257                              mark(name(i).closure);
3258                           }
3259                        }
3260                        end("Names", nameHw-NAMEMIN);
3261
3262                        start();
3263                        for (i = MODULE_BASE_ADDR;
3264                             i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
3265                           if (tabModule[i-MODULE_BASE_ADDR].inUse) {
3266                              mark(module(i).tycons);
3267                              mark(module(i).names);
3268                              mark(module(i).classes);
3269                              mark(module(i).exports);
3270                              mark(module(i).qualImports);
3271                              mark(module(i).codeList);
3272                              mark(module(i).tree);
3273                              mark(module(i).uses);
3274                              mark(module(i).objectExtraNames);
3275                           }
3276                        }
3277                        mark(moduleGraph);
3278                        mark(prelModules);
3279                        mark(targetModules);
3280                        end("Modules", moduleHw-MODMIN);
3281
3282                        start();
3283                        for (i = TYCON_BASE_ADDR;
3284                             i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3285                           if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
3286                              mark(tycon(i).kind);
3287                              mark(tycon(i).what);
3288                              mark(tycon(i).defn);
3289                              mark(tycon(i).closure);
3290                           }
3291                        }
3292                        end("Type constructors", tyconHw-TYCMIN);
3293
3294                        start();
3295                        for (i = CCLASS_BASE_ADDR;
3296                             i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
3297                           if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
3298                              mark(cclass(i).kinds);
3299                              mark(cclass(i).fds);
3300                              mark(cclass(i).xfds);
3301                              mark(cclass(i).head);
3302                              mark(cclass(i).supers);
3303                              mark(cclass(i).dsels);
3304                              mark(cclass(i).members);
3305                              mark(cclass(i).defaults);
3306                              mark(cclass(i).instances);
3307                           }
3308                        }
3309                        mark(classes);
3310                        end("Classes", classHw-CLASSMIN);
3311
3312                        start();
3313                        for (i = INST_BASE_ADDR;
3314                             i < INST_BASE_ADDR+tabInstSz; ++i) {
3315                           if (tabInst[i-INST_BASE_ADDR].inUse) {
3316                              mark(inst(i).kinds);
3317                              mark(inst(i).head);
3318                              mark(inst(i).specifics);
3319                              mark(inst(i).implements);
3320                           }
3321                        }
3322                        end("Instances", instHw-INSTMIN);
3323
3324                        start();
3325                        for (i=0; i<=sp; ++i)
3326                            mark(stack(i));
3327                        end("Stack", sp+1);
3328
3329                        start();
3330                        mark(lastExprSaved);
3331                        mark(lsave);
3332                        mark(rsave);
3333                        end("Last expression", 3);
3334
3335                        if (consGC) {
3336                            start();
3337                            gcCStack();
3338                            end("C stack", stackRoots);
3339                        }
3340
3341                        break;
3342
3343         case PREPREL : heapFst = heapAlloc(heapSize);
3344                        heapSnd = heapAlloc(heapSize);
3345
3346                        if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
3347                            ERRMSG(0) "Cannot allocate heap storage (%d cells)",
3348                                      heapSize
3349                            EEND;
3350                        }
3351
3352                        heapTopFst = heapFst + heapSize;
3353                        heapTopSnd = heapSnd + heapSize;
3354                        for (i=1; i<heapSize; ++i) {
3355                            fst(-i) = FREECELL;
3356                            snd(-i) = -(i+1);
3357                        }
3358                        snd(-heapSize) = NIL;
3359                        freeList  = -1;
3360                        numGcs    = 0;
3361                        consGC    = TRUE;
3362                        lsave     = NIL;
3363                        rsave     = NIL;
3364
3365                        marksSize  = bitArraySize(heapSize);
3366                        if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
3367                            ERRMSG(0) "Unable to allocate gc markspace"
3368                            EEND;
3369                        }
3370
3371                        clearStack();
3372
3373                        textHw        = 0;
3374                        nextNewText   = INVAR_BASE_ADDR;
3375                        nextNewDText  = INDVAR_BASE_ADDR;
3376                        lastExprSaved = NIL;
3377                        savedText     = TEXT_SIZE;
3378
3379                        for (i=0; i<TEXTHSZ;  ++i) textHash[i][0] = NOTEXT;
3380                        for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
3381                        for (i=0; i<NAMEHSZ;  ++i) nameHash[RC_N(i)] = NIL;
3382
3383                        break;
3384     }
3385 }
3386
3387 /*-------------------------------------------------------------------------*/