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