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