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.63 $
  13  * $Date: 2000/04/05 16:57:18 $
  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 (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("PrimPrel"));
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 /* Purely for debugging. */
1536 void locateSymbolByName ( Text t )
1537 {
1538    Int i;
1539    for (i = NAME_BASE_ADDR;
1540         i < NAME_BASE_ADDR+tabNameSz; i++)
1541       if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t)
1542          fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR);
1543    for (i = TYCON_BASE_ADDR;
1544         i < TYCON_BASE_ADDR+tabTyconSz; i++)
1545       if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t)
1546          fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR);
1547    for (i = CCLASS_BASE_ADDR;
1548         i < CCLASS_BASE_ADDR+tabClassSz; i++)
1549       if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t)
1550          fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR);
1551 }
1552
1553 /* --------------------------------------------------------------------------
1554  * Control stack:
1555  *
1556  * Various parts of the system use a stack of cells.  Most of the stack
1557  * operations are defined as macros, expanded inline.
1558  * ------------------------------------------------------------------------*/
1559
1560 Cell cellStack[NUM_STACK];          /* Storage for cells on stack          */
1561 StackPtr sp;                        /* stack pointer                       */
1562
1563 Void hugsStackOverflow() {          /* Report stack overflow               */
1564     ERRMSG(0) "Control stack overflow"
1565     EEND;
1566 }
1567
1568
1569 /* --------------------------------------------------------------------------
1570  * Module storage:
1571  *
1572  * A Module represents a user defined module.
1573  *
1574  * Note: there are now two lookup mechanisms in the system:
1575  *
1576  * 1) The exports from a module are stored in a big list.
1577  *    We resolve qualified names, and import lists by linearly scanning
1578  *    through this list.
1579  *
1580  * 2) Unqualified imports and local definitions for the current module
1581  *    are stored in hash tables (tyconHash and nameHash) or linear lists
1582  *    (classes).
1583  *
1584  * ------------------------------------------------------------------------*/
1585
1586 Module  currentModule;                  /* Module currently being processed*/
1587
1588 Bool isValidModule(m)                   /* is m a legitimate module id?    */
1589 Module m; {
1590     return isModule(m);
1591 }
1592
1593 Module newModule ( Text t )             /* add new module to module table  */
1594 {
1595     Module mod                   = allocNewModule();
1596     module(mod).text             = t;      /* clear new module record      */
1597
1598     module(mod).tycons           = NIL;
1599     module(mod).names            = NIL;
1600     module(mod).classes          = NIL;
1601     module(mod).exports          = NIL;
1602     module(mod).qualImports      = NIL;
1603     module(mod).fake             = FALSE;
1604
1605     module(mod).tree             = NIL;
1606     module(mod).completed        = FALSE;
1607     module(mod).lastStamp        = 0; /* ???? */
1608
1609     module(mod).mode             = NIL;
1610     module(mod).srcExt           = findText("");
1611     module(mod).uses             = NIL;
1612
1613     module(mod).objName          = findText("");
1614     module(mod).objSize          = 0;
1615
1616     module(mod).object           = NULL;
1617     module(mod).objectExtras     = NULL;
1618     module(mod).objectExtraNames = NIL;
1619     return mod;
1620 }
1621
1622 void nukeModule ( Module m )
1623 {
1624    ObjectCode* oc;
1625    ObjectCode* oc2;
1626    Int         i;
1627 assert(isModule(m));
1628 /*fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); */
1629    oc = module(m).object;
1630    while (oc) {
1631       oc2 = oc->next;
1632       ocFree(oc);
1633       oc = oc2;
1634    }
1635    oc = module(m).objectExtras;
1636    while (oc) {
1637       oc2 = oc->next;
1638       ocFree(oc);
1639       oc = oc2;
1640    }
1641
1642    for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++)
1643       if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) {
1644          if (name(i).itbl) free(name(i).itbl);
1645          name(i).itbl = NULL;
1646          freeName(i);
1647       }
1648
1649    for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++)
1650       if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) {
1651          if (tycon(i).itbl) free(tycon(i).itbl);
1652          tycon(i).itbl = NULL;
1653          freeTycon(i);
1654       }
1655
1656    for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++)
1657       if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
1658          if (cclass(i).mod == m) {
1659             freeClass(i);
1660          } else {
1661             List /* Inst */ ins;
1662             List /* Inst */ ins2 = NIL;
1663             for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins))
1664                if (inst(hd(ins)).mod != m)
1665                   ins2 = cons(hd(ins),ins2);
1666             cclass(i).instances = ins2;
1667          }
1668       }
1669
1670
1671    for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++)
1672       if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m)
1673          freeInst(i);
1674
1675    freeModule(m);
1676    //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0;
1677    //for (i = 0; i < NAMEHSZ; i++)  nameHash[i] = 0;
1678    //classes = NIL;
1679    //hashSanity();
1680 }
1681
1682 void ppModules ( void )
1683 {
1684    Int i;
1685    fflush(stderr); fflush(stdout);
1686    printf ( "begin MODULES\n" );
1687    for (i  = MODULE_BASE_ADDR+tabModuleSz-1;
1688         i >= MODULE_BASE_ADDR; i--)
1689       if (tabModule[i-MODULE_BASE_ADDR].inUse)
1690          printf ( " %2d: %16s\n",
1691                   i-MODULE_BASE_ADDR, textToStr(module(i).text)
1692                 );
1693    printf ( "end   MODULES\n" );
1694    fflush(stderr); fflush(stdout);
1695 }
1696
1697
1698 Module findModule(t)                    /* locate Module in module table  */
1699 Text t; {
1700     Module m;
1701     for(m = MODULE_BASE_ADDR;
1702         m < MODULE_BASE_ADDR+tabModuleSz; ++m) {
1703         if (tabModule[m-MODULE_BASE_ADDR].inUse)
1704             if (module(m).text==t)
1705                 return m;
1706     }
1707     return NIL;
1708 }
1709
1710 Module findModid(c)                    /* Find module by name or filename  */
1711 Cell c; {
1712     switch (whatIs(c)) {
1713         case STRCELL   : internal("findModid-STRCELL unimp");
1714         case CONIDCELL : return findModule(textOf(c));
1715         default        : internal("findModid");
1716     }
1717     return NIL;/*NOTUSED*/
1718 }
1719
1720 static local Module findQualifier(t)    /* locate Module in import list   */
1721 Text t; {
1722     Module ms;
1723     for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
1724         if (textOf(fst(hd(ms)))==t)
1725             return snd(hd(ms));
1726     }
1727     if (module(currentModule).text==t)
1728         return currentModule;
1729     return NIL;
1730 }
1731
1732 Void setCurrModule(m)              /* set lookup tables for current module */
1733 Module m; {
1734     Int i;
1735     assert(isModule(m));
1736     /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
1737     {List t;
1738      for (t = module(m).names; nonNull(t); t=tl(t))
1739         assert(isName(hd(t)));
1740      for (t = module(m).tycons; nonNull(t); t=tl(t))
1741         assert(isTycon(hd(t)) || isTuple(hd(t)));
1742      for (t = module(m).classes; nonNull(t); t=tl(t))
1743         assert(isClass(hd(t)));
1744     }
1745
1746     currentModule = m; /* This is the only assignment to currentModule */
1747     for (i=0; i<TYCONHSZ; ++i)
1748        tyconHash[RC_T(i)] = NIL;
1749     mapProc(hashTycon,module(m).tycons);
1750     for (i=0; i<NAMEHSZ; ++i)
1751        nameHash[RC_N(i)] = NIL;
1752     mapProc(hashName,module(m).names);
1753     classes = module(m).classes;
1754     hashSanity();
1755 }
1756
1757 Name jrsFindQualName ( Text mn, Text sn )
1758 {
1759    Module m;
1760    List   ns;
1761
1762    for (m = MODULE_BASE_ADDR;
1763         m < MODULE_BASE_ADDR+tabModuleSz; m++)
1764       if (tabModule[m-MODULE_BASE_ADDR].inUse
1765           && module(m).text == mn) break;
1766
1767    if (m == MODULE_BASE_ADDR+tabModuleSz) return NIL;
1768
1769    for (ns = module(m).names; nonNull(ns); ns=tl(ns))
1770       if (name(hd(ns)).text == sn) return hd(ns);
1771
1772    return NIL;
1773 }
1774
1775
1776 char* nameFromOPtr ( void* p )
1777 {
1778    int i;
1779    Module m;
1780    for (m = MODULE_BASE_ADDR;
1781         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1782       if (tabModule[m-MODULE_BASE_ADDR].inUse && module(m).object) {
1783          char* nm = ocLookupAddr ( module(m).object, p );
1784          if (nm) return nm;
1785       }
1786    }
1787 #  if 0
1788    /* A kludge to assist Win32 debugging; not actually necessary. */
1789    { char* nm = nameFromStaticOPtr(p);
1790      if (nm) return nm;
1791    }
1792 #  endif
1793    return NULL;
1794 }
1795
1796
1797 void* lookupOTabName ( Module m, char* sym )
1798 {
1799    assert(isModule(m));
1800    if (module(m).object)
1801       return ocLookupSym ( module(m).object, sym );
1802    return NULL;
1803 }
1804
1805
1806 void* lookupOExtraTabName ( char* sym )
1807 {
1808    ObjectCode* oc;
1809    Module      m;
1810    for (m = MODULE_BASE_ADDR;
1811         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1812       if (tabModule[m-MODULE_BASE_ADDR].inUse)
1813          for (oc = module(m).objectExtras; oc; oc=oc->next) {
1814             void* ad = ocLookupSym ( oc, sym );
1815             if (ad) return ad;
1816          }
1817    }
1818    return NULL;
1819 }
1820
1821
1822 OSectionKind lookupSection ( void* ad )
1823 {
1824    int          i;
1825    Module       m;
1826    ObjectCode*  oc;
1827    OSectionKind sect;
1828
1829    for (m = MODULE_BASE_ADDR;
1830         m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1831       if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1832          if (module(m).object) {
1833             sect = ocLookupSection ( module(m).object, ad );
1834             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1835                return sect;
1836          }
1837          for (oc = module(m).objectExtras; oc; oc=oc->next) {
1838             sect = ocLookupSection ( oc, ad );
1839             if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1840                return sect;
1841          }
1842       }
1843    }
1844    return HUGS_SECTIONKIND_OTHER;
1845 }
1846
1847
1848 /* --------------------------------------------------------------------------
1849  * Heap storage:
1850  *
1851  * Provides a garbage collectable heap for storage of expressions etc.
1852  *
1853  * Now incorporates a flat resource:  A two-space collected extension of
1854  * the heap that provides storage for contiguous arrays of Cell storage,
1855  * cooperating with the garbage collection mechanisms for the main heap.
1856  * ------------------------------------------------------------------------*/
1857
1858 Int     heapSize = DEFAULTHEAP;         /* number of cells in heap         */
1859 Heap    heapFst;                        /* array of fst component of pairs */
1860 Heap    heapSnd;                        /* array of snd component of pairs */
1861 Heap    heapTopFst;
1862 Heap    heapTopSnd;
1863 Bool    consGC = TRUE;                  /* Set to FALSE to turn off gc from*/
1864                                         /* C stack; use with extreme care! */
1865 Long    numCells;
1866 Int     numGcs;                         /* number of garbage collections   */
1867 Int     cellsRecovered;                 /* number of cells recovered       */
1868
1869 static  Cell freeList;                  /* free list of unused cells       */
1870 static  Cell lsave, rsave;              /* save components of pair         */
1871
1872 #if GC_STATISTICS
1873
1874 static Int markCount, stackRoots;
1875
1876 #define initStackRoots() stackRoots = 0
1877 #define recordStackRoot() stackRoots++
1878
1879 #define startGC()       \
1880     if (gcMessages) {   \
1881         Printf("\n");   \
1882         fflush(stdout); \
1883     }
1884 #define endGC()         \
1885     if (gcMessages) {   \
1886         Printf("\n");   \
1887         fflush(stdout); \
1888     }
1889
1890 #define start()      markCount = 0
1891 #define end(thing,rs) \
1892     if (gcMessages) { \
1893         Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
1894         fflush(stdout); \
1895     }
1896 #define recordMark() markCount++
1897
1898 #else /* !GC_STATISTICS */
1899
1900 #define startGC()
1901 #define endGC()
1902
1903 #define initStackRoots()
1904 #define recordStackRoot()
1905
1906 #define start()
1907 #define end(thing,root)
1908 #define recordMark()
1909
1910 #endif /* !GC_STATISTICS */
1911
1912 Cell pair(l,r)                          /* Allocate pair (l, r) from       */
1913 Cell l, r; {                            /* heap, garbage collecting first  */
1914     Cell c = freeList;                  /* if necessary ...                */
1915     if (isNull(c)) {
1916         lsave = l;
1917         rsave = r;
1918         garbageCollect();
1919         l     = lsave;
1920         lsave = NIL;
1921         r     = rsave;
1922         rsave = NIL;
1923         c     = freeList;
1924     }
1925     freeList = snd(freeList);
1926     fst(c)   = l;
1927     snd(c)   = r;
1928     numCells++;
1929     return c;
1930 }
1931
1932 static Int *marks;
1933 static Int marksSize;
1934
1935 void mark ( Cell root )
1936 {
1937    Cell c;
1938    Cell mstack[NUM_MSTACK];
1939    Int  msp     = -1;
1940    Int  msp_max = -1;
1941
1942    mstack[++msp] = root;
1943
1944    while (msp >= 0) {
1945       if (msp > msp_max) msp_max = msp;
1946       c = mstack[msp--];
1947       if (!isGenPair(c)) continue;
1948       if (fst(c)==FREECELL) continue;
1949       {
1950          register int place = placeInSet(c);
1951          register int mask  = maskInSet(c);
1952          if (!(marks[place]&mask)) {
1953             marks[place] |= mask;
1954             if (msp >= NUM_MSTACK-5) {
1955                fprintf ( stderr,
1956                          "hugs: fatal stack overflow during GC.  "
1957                          "Increase NUM_MSTACK.\n" );
1958                exit(9);
1959             }
1960             mstack[++msp] = fst(c);
1961             mstack[++msp] = snd(c);
1962          }
1963       }
1964    }
1965    //   fprintf(stderr, "%d ",msp_max);
1966 }
1967
1968
1969 Void garbageCollect()     {             /* Run garbage collector ...       */
1970                                         /* disable break checking          */
1971     Int i,j;
1972     register Int mask;
1973     register Int place;
1974     Int      recovered;
1975     jmp_buf  regs;                      /* save registers on stack         */
1976     HugsBreakAction oldBrk
1977        = setBreakAction ( HugsIgnoreBreak );
1978
1979     setjmp(regs);
1980
1981     gcStarted();
1982
1983     for (i=0; i<marksSize; ++i)         /* initialise mark set to empty    */
1984         marks[i] = 0;
1985
1986     everybody(MARK);                    /* Mark all components of system   */
1987
1988     gcScanning();                       /* scan mark set                   */
1989     mask      = 1;
1990     place     = 0;
1991     recovered = 0;
1992     j         = 0;
1993
1994     freeList = NIL;
1995     for (i=1; i<=heapSize; i++) {
1996         if ((marks[place] & mask) == 0) {
1997             snd(-i)  = freeList;
1998             fst(-i)  = FREECELL;
1999             freeList = -i;
2000             recovered++;
2001         }
2002         mask <<= 1;
2003         if (++j == bitsPerWord) {
2004             place++;
2005             mask = 1;
2006             j    = 0;
2007         }
2008     }
2009
2010     gcRecovered(recovered);
2011     setBreakAction ( oldBrk );
2012
2013     everybody(GCDONE);
2014
2015 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
2016     fprintf(stderr, "\n--- GC recovered %d\n",recovered );
2017 #endif
2018
2019     /* can only return if freeList is nonempty on return. */
2020     if (recovered<minRecovery || isNull(freeList)) {
2021         ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
2022         EEND;
2023     }
2024     cellsRecovered = recovered;
2025 }
2026
2027 /* --------------------------------------------------------------------------
2028  * Code for saving last expression entered:
2029  *
2030  * This is a little tricky because some text values (e.g. strings or variable
2031  * names) may not be defined or have the same value when the expression is
2032  * recalled.  These text values are therefore saved in the top portion of
2033  * the text table.
2034  * ------------------------------------------------------------------------*/
2035
2036 static Cell lastExprSaved;              /* last expression to be saved     */
2037
2038 Void setLastExpr(e)                     /* save expression for later recall*/
2039 Cell e; {
2040     lastExprSaved = NIL;                /* in case attempt to save fails   */
2041     savedText     = TEXT_SIZE;
2042     lastExprSaved = lowLevelLastIn(e);
2043 }
2044
2045 static Cell local lowLevelLastIn(c)     /* Duplicate expression tree (i.e. */
2046 Cell c; {                               /* acyclic graph) for later recall */
2047     if (isPair(c)) {                    /* Duplicating any text strings    */
2048         if (isTagNonPtr(fst(c)))        /* in case these are lost at some  */
2049             switch (fst(c)) {           /* point before the expr is reused */
2050                 case VARIDCELL :
2051                 case VAROPCELL :
2052                 case DICTVAR   :
2053                 case CONIDCELL :
2054                 case CONOPCELL :
2055                 case STRCELL   : return pair(fst(c),saveText(textOf(c)));
2056                 default        : return pair(fst(c),snd(c));
2057             }
2058         else
2059             return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
2060     }
2061 #if TREX
2062     else if (isExt(c))
2063         return pair(EXTCOPY,saveText(extText(c)));
2064 #endif
2065     else
2066         return c;
2067 }
2068
2069 Cell getLastExpr() {                    /* recover previously saved expr   */
2070     return lowLevelLastOut(lastExprSaved);
2071 }
2072
2073 static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
2074 Cell c; {                               /* except that Cells refering to   */
2075     if (isPair(c)) {                    /* Text values are restored to     */
2076         if (isTagNonPtr(fst(c)))        /* appropriate values              */
2077             switch (fst(c)) {
2078                 case VARIDCELL :
2079                 case VAROPCELL :
2080                 case DICTVAR   :
2081                 case CONIDCELL :
2082                 case CONOPCELL :
2083                 case STRCELL   : return pair(fst(c),
2084                                              findText(text+intValOf(c)));
2085 #if TREX
2086                 case EXTCOPY   : return mkExt(findText(text+intValOf(c)));
2087 #endif
2088                 default        : return pair(fst(c),snd(c));
2089             }
2090         else
2091             return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
2092     }
2093     else
2094         return c;
2095 }
2096
2097 /* --------------------------------------------------------------------------
2098  * Miscellaneous operations on heap cells:
2099  * ------------------------------------------------------------------------*/
2100
2101 Cell whatIs ( register Cell c )
2102 {
2103     if (isPair(c)) {
2104         register Cell fstc = fst(c);
2105         return isTag(fstc) ? fstc : AP;
2106     }
2107     if (isOffset(c))           return OFFSET;
2108     if (isChar(c))             return CHARCELL;
2109     if (isInt(c))              return INTCELL;
2110     if (isName(c))             return NAME;
2111     if (isTycon(c))            return TYCON;
2112     if (isTuple(c))            return TUPLE;
2113     if (isClass(c))            return CLASS;
2114     if (isInst(c))             return INSTANCE;
2115     if (isModule(c))           return MODULE;
2116     if (isText(c))             return TEXTCELL;
2117     if (isInventedVar(c))      return INVAR;
2118     if (isInventedDictVar(c))  return INDVAR;
2119     if (isSpec(c))             return c;
2120     if (isNull(c))             return c;
2121     fprintf ( stderr, "whatIs: unknown %d\n", c );
2122     internal("whatIs");
2123 }
2124
2125
2126 #if 0
2127 Cell whatIs(c)                         /* identify type of cell            */
2128 register Cell c; {
2129     if (isPair(c)) {
2130         register Cell fstc = fst(c);
2131         return isTag(fstc) ? fstc : AP;
2132     }
2133     if (c<OFFMIN)    return c;
2134 #if TREX
2135     if (isExt(c))    return EXT;
2136 #endif
2137     if (c>=INTMIN)   return INTCELL;
2138
2139     if (c>=NAMEMIN){if (c>=CLASSMIN)   {if (c>=CHARMIN) return CHARCELL;
2140                                         else            return CLASS;}
2141                     else                if (c>=INSTMIN) return INSTANCE;
2142                                         else            return NAME;}
2143     else            if (c>=MODMIN)     {if (c>=TYCMIN)  return isTuple(c) ? TUPLE : TYCON;
2144                                         else            return MODULE;}
2145                     else                if (c>=OFFMIN)  return OFFSET;
2146 #if TREX
2147                                         else            return (c>=EXTMIN) ?
2148                                                                 EXT : TUPLE;
2149 #else
2150                                         else            return TUPLE;
2151 #endif
2152
2153
2154 /*  if (isPair(c)) {
2155         register Cell fstc = fst(c);
2156         return isTag(fstc) ? fstc : AP;
2157     }
2158     if (c>=INTMIN)   return INTCELL;
2159     if (c>=CHARMIN)  return CHARCELL;
2160     if (c>=CLASSMIN) return CLASS;
2161     if (c>=INSTMIN)  return INSTANCE;
2162     if (c>=NAMEMIN)  return NAME;
2163     if (c>=TYCMIN)   return TYCON;
2164     if (c>=MODMIN)   return MODULE;
2165     if (c>=OFFMIN)   return OFFSET;
2166 #if TREX
2167     if (c>=EXTMIN)   return EXT;
2168 #endif
2169     if (c>=TUPMIN)   return TUPLE;
2170     return c;*/
2171 }
2172 #endif
2173
2174
2175 /* A very, very simple printer.
2176  * Output is uglier than from printExp - but the printer is more
2177  * robust and can be used on any data structure irrespective of
2178  * its type.
2179  */
2180 Void print ( Cell c, Int depth )
2181 {
2182     if (0 == depth) {
2183         Printf("...");
2184     }
2185     else if (isNull(c)) {
2186        Printf("NIL");
2187     }
2188     else if (isTagPtr(c)) {
2189         Printf("TagP(%d)", c);
2190     }
2191     else if (isTagNonPtr(c)) {
2192         Printf("TagNP(%d)", c);
2193     }
2194     else if (isSpec(c)) {
2195         Printf("TagS(%d)", c);
2196     }
2197     else if (isText(c)) {
2198         Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c));
2199     }
2200     else if (isInventedVar(c)) {
2201         Printf("invented(%d)", c-INVAR_BASE_ADDR);
2202     }
2203     else if (isInventedDictVar(c)) {
2204         Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR);
2205     }
2206     else {
2207         Int tag = whatIs(c);
2208         switch (tag) {
2209         case AP:
2210                 Putchar('(');
2211                 print(fst(c), depth-1);
2212                 Putchar(',');
2213                 print(snd(c), depth-1);
2214                 Putchar(')');
2215                 break;
2216         case FREECELL:
2217                 Printf("free(%d)", c);
2218                 break;
2219         case INTCELL:
2220                 Printf("int(%d)", intOf(c));
2221                 break;
2222         case BIGCELL:
2223                 Printf("bignum(%s)", bignumToString(c));
2224                 break;
2225         case CHARCELL:
2226                 Printf("char('%c')", charOf(c));
2227                 break;
2228         case PTRCELL:
2229                 Printf("ptr(%p)",ptrOf(c));
2230                 break;
2231         case CLASS:
2232                 Printf("class(%d)", c-CCLASS_BASE_ADDR);
2233                 Printf("=\"%s\"", textToStr(cclass(c).text));
2234                 break;
2235         case INSTANCE:
2236                 Printf("instance(%d)", c - INST_BASE_ADDR);
2237                 break;
2238         case NAME:
2239                 Printf("name(%d)", c-NAME_BASE_ADDR);
2240                 Printf("=\"%s\"", textToStr(name(c).text));
2241                 break;
2242         case TYCON:
2243                 Printf("tycon(%d)", c-TYCON_BASE_ADDR);
2244                 Printf("=\"%s\"", textToStr(tycon(c).text));
2245                 break;
2246         case MODULE:
2247                 Printf("module(%d)", c - MODULE_BASE_ADDR);
2248                 Printf("=\"%s\"", textToStr(module(c).text));
2249                 break;
2250         case OFFSET:
2251                 Printf("Offset %d", offsetOf(c));
2252                 break;
2253         case TUPLE:
2254                 Printf("%s", textToStr(ghcTupleText(c)));
2255                 break;
2256         case POLYTYPE:
2257                 Printf("Polytype");
2258                 print(snd(c),depth-1);
2259                 break;
2260         case QUAL:
2261                 Printf("Qualtype");
2262                 print(snd(c),depth-1);
2263                 break;
2264         case RANK2:
2265                 Printf("Rank2(");
2266                 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
2267                     Printf("%d ", intOf(fst(snd(c))));
2268                     print(snd(snd(c)),depth-1);
2269                 } else {
2270                     print(snd(c),depth-1);
2271                 }
2272                 Printf(")");
2273                 break;
2274         case WILDCARD:
2275                 Printf("_");
2276                 break;
2277         case STAR:
2278                 Printf("STAR");
2279                 break;
2280         case DOTDOT:
2281                 Printf("DOTDOT");
2282                 break;
2283         case DICTVAR:
2284                 Printf("{dict %d}",textOf(c));
2285                 break;
2286         case VARIDCELL:
2287         case VAROPCELL:
2288         case CONIDCELL:
2289         case CONOPCELL:
2290                 Printf("{id %s}",textToStr(textOf(c)));
2291                 break;
2292 #if IPARAM
2293           case IPCELL :
2294               Printf("{ip %s}",textToStr(textOf(c)));
2295               break;
2296           case IPVAR :
2297               Printf("?%s",textToStr(textOf(c)));
2298               break;
2299 #endif
2300         case QUALIDENT:
2301                 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
2302                 break;
2303         case LETREC:
2304                 Printf("LetRec(");
2305                 print(fst(snd(c)),depth-1);
2306                 Putchar(',');
2307                 print(snd(snd(c)),depth-1);
2308                 Putchar(')');
2309                 break;
2310         case LAMBDA:
2311                 Printf("Lambda(");
2312                 print(snd(c),depth-1);
2313                 Putchar(')');
2314                 break;
2315         case FINLIST:
2316                 Printf("FinList(");
2317                 print(snd(c),depth-1);
2318                 Putchar(')');
2319                 break;
2320         case COMP:
2321                 Printf("Comp(");
2322                 print(fst(snd(c)),depth-1);
2323                 Putchar(',');
2324                 print(snd(snd(c)),depth-1);
2325                 Putchar(')');
2326                 break;
2327         case ASPAT:
2328                 Printf("AsPat(");
2329                 print(fst(snd(c)),depth-1);
2330                 Putchar(',');
2331                 print(snd(snd(c)),depth-1);
2332                 Putchar(')');
2333                 break;
2334         case FROMQUAL:
2335                 Printf("FromQual(");
2336                 print(fst(snd(c)),depth-1);
2337                 Putchar(',');
2338                 print(snd(snd(c)),depth-1);
2339                 Putchar(')');
2340                 break;
2341         case STGVAR:
2342                 Printf("StgVar%d=",-c);
2343                 print(snd(c), depth-1);
2344                 break;
2345         case STGAPP:
2346                 Printf("StgApp(");
2347                 print(fst(snd(c)),depth-1);
2348                 Putchar(',');
2349                 print(snd(snd(c)),depth-1);
2350                 Putchar(')');
2351                 break;
2352         case STGPRIM:
2353                 Printf("StgPrim(");
2354                 print(fst(snd(c)),depth-1);
2355                 Putchar(',');
2356                 print(snd(snd(c)),depth-1);
2357                 Putchar(')');
2358                 break;
2359         case STGCON:
2360                 Printf("StgCon(");
2361                 print(fst(snd(c)),depth-1);
2362                 Putchar(',');
2363                 print(snd(snd(c)),depth-1);
2364                 Putchar(')');
2365                 break;
2366         case PRIMCASE:
2367                 Printf("PrimCase(");
2368                 print(fst(snd(c)),depth-1);
2369                 Putchar(',');
2370                 print(snd(snd(c)),depth-1);
2371                 Putchar(')');
2372                 break;
2373         case DICTAP:
2374                 Printf("(DICTAP,");
2375                 print(snd(c),depth-1);
2376                 Putchar(')');
2377                 break;
2378         case UNBOXEDTUP:
2379                 Printf("(UNBOXEDTUP,");
2380                 print(snd(c),depth-1);
2381                 Putchar(')');
2382                 break;
2383         case ZTUP2:
2384                 Printf("<ZPair ");
2385                 print(zfst(c),depth-1);
2386                 Putchar(' ');
2387                 print(zsnd(c),depth-1);
2388                 Putchar('>');
2389                 break;
2390         case ZTUP3:
2391                 Printf("<ZTriple ");
2392                 print(zfst3(c),depth-1);
2393                 Putchar(' ');
2394                 print(zsnd3(c),depth-1);
2395                 Putchar(' ');
2396                 print(zthd3(c),depth-1);
2397                 Putchar('>');
2398                 break;
2399         case BANG:
2400                 Printf("(BANG,");
2401                 print(snd(c),depth-1);
2402                 Putchar(')');
2403                 break;
2404         default:
2405                 if (isTagNonPtr(tag)) {
2406                     Printf("(TagNP=%d,%d)", c, tag);
2407                 } else if (isTagPtr(tag)) {
2408                     Printf("(TagP=%d,",tag);
2409                     print(snd(c), depth-1);
2410                     Putchar(')');
2411                     break;
2412                 } else if (c == tag) {
2413                     Printf("Tag(%d)", c);
2414                 } else {
2415                     Printf("Tag(%d)=%d", c, tag);
2416                 }
2417                 break;
2418         }
2419     }
2420     FlushStdout();
2421 }
2422
2423
2424 Bool isVar(c)                           /* is cell a VARIDCELL/VAROPCELL ? */
2425 Cell c; {                               /* also recognises DICTVAR cells   */
2426     return isPair(c) &&
2427                (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
2428 }
2429
2430 Bool isCon(c)                          /* is cell a CONIDCELL/CONOPCELL ?  */
2431 Cell c; {
2432     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
2433 }
2434
2435 Bool isQVar(c)                        /* is cell a [un]qualified varop/id? */
2436 Cell c; {
2437     if (!isPair(c)) return FALSE;
2438     switch (fst(c)) {
2439         case VARIDCELL  :
2440         case VAROPCELL  : return TRUE;
2441
2442         case QUALIDENT  : return isVar(snd(snd(c)));
2443
2444         default         : return FALSE;
2445     }
2446 }
2447
2448 Bool isQCon(c)                         /*is cell a [un]qualified conop/id? */
2449 Cell c; {
2450     if (!isPair(c)) return FALSE;
2451     switch (fst(c)) {
2452         case CONIDCELL  :
2453         case CONOPCELL  : return TRUE;
2454
2455         case QUALIDENT  : return isCon(snd(snd(c)));
2456
2457         default         : return FALSE;
2458     }
2459 }
2460
2461 Bool isQualIdent(c)                    /* is cell a qualified identifier?  */
2462 Cell c; {
2463     return isPair(c) && (fst(c)==QUALIDENT);
2464 }
2465
2466 Bool eqQualIdent ( QualId c1, QualId c2 )
2467 {
2468    assert(isQualIdent(c1));
2469    if (!isQualIdent(c2)) {
2470    assert(isQualIdent(c2));
2471    }
2472    return qmodOf(c1)==qmodOf(c2) &&
2473           qtextOf(c1)==qtextOf(c2);
2474 }
2475
2476 Bool isIdent(c)                        /* is cell an identifier?           */
2477 Cell c; {
2478     if (!isPair(c)) return FALSE;
2479     switch (fst(c)) {
2480         case VARIDCELL  :
2481         case VAROPCELL  :
2482         case CONIDCELL  :
2483         case CONOPCELL  : return TRUE;
2484
2485         case QUALIDENT  : return TRUE;
2486
2487         default         : return FALSE;
2488     }
2489 }
2490
2491 Bool isInt(c)                          /* cell holds integer value?        */
2492 Cell c; {
2493     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
2494 }
2495
2496 Int intOf(c)                           /* find integer value of cell?      */
2497 Cell c; {
2498     assert(isInt(c));
2499     return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO);
2500 }
2501
2502 Cell mkInt(n)                          /* make cell representing integer   */
2503 Int n; {
2504     return (SMALL_INT_MIN    <= SMALL_INT_ZERO+n &&
2505             SMALL_INT_ZERO+n <= SMALL_INT_MAX)
2506            ? SMALL_INT_ZERO+n
2507            : pair(INTCELL,n);
2508 }
2509
2510 #if SIZEOF_VOID_P == SIZEOF_INT
2511
2512 typedef union {Int i; Ptr p;} IntOrPtr;
2513
2514 Cell mkPtr(p)
2515 Ptr p;
2516 {
2517     IntOrPtr x;
2518     x.p = p;
2519     return pair(PTRCELL,x.i);
2520 }
2521
2522 Ptr ptrOf(c)
2523 Cell c;
2524 {
2525     IntOrPtr x;
2526     assert(fst(c) == PTRCELL);
2527     x.i = snd(c);
2528     return x.p;
2529 }
2530
2531 Cell mkCPtr(p)
2532 Ptr p;
2533 {
2534     IntOrPtr x;
2535     x.p = p;
2536     return pair(CPTRCELL,x.i);
2537 }
2538
2539 Ptr cptrOf(c)
2540 Cell c;
2541 {
2542     IntOrPtr x;
2543     assert(fst(c) == CPTRCELL);
2544     x.i = snd(c);
2545     return x.p;
2546 }
2547
2548 #elif SIZEOF_VOID_P == 2*SIZEOF_INT
2549
2550 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2551
2552 Cell mkPtr(p)
2553 Ptr p;
2554 {
2555     IntOrPtr x;
2556     x.p = p;
2557     return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2558 }
2559
2560 Ptr ptrOf(c)
2561 Cell c;
2562 {
2563     IntOrPtr x;
2564     assert(fst(c) == PTRCELL);
2565     x.i.i1 = intOf(fst(snd(c)));
2566     x.i.i2 = intOf(snd(snd(c)));
2567     return x.p;
2568 }
2569
2570 Cell mkCPtr(p)
2571 Ptr p;
2572 {
2573     IntOrPtr x;
2574     x.p = p;
2575     return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2576 }
2577
2578 Ptr cptrOf(c)
2579 Cell c;
2580 {
2581     IntOrPtr x;
2582     assert(fst(c) == CPTRCELL);
2583     x.i.i1 = intOf(fst(snd(c)));
2584     x.i.i2 = intOf(snd(snd(c)));
2585     return x.p;
2586 }
2587
2588 #else
2589
2590 #error "Can't implement mkPtr/ptrOf on this architecture."
2591
2592 #endif
2593
2594
2595 String stringNegate( s )
2596 String s;
2597 {
2598     if (s[0] == '-') {
2599         return &s[1];
2600     } else {
2601         static char t[100];
2602         t[0] = '-';
2603         strcpy(&t[1],s);  /* ToDo: use strncpy instead */
2604         return t;
2605     }
2606 }
2607
2608 /* --------------------------------------------------------------------------
2609  * List operations:
2610  * ------------------------------------------------------------------------*/
2611
2612 Int length(xs)                         /* calculate length of list xs      */
2613 List xs; {
2614     Int n = 0;
2615     for (; nonNull(xs); ++n)
2616         xs = tl(xs);
2617     return n;
2618 }
2619
2620 List appendOnto(xs,ys)                 /* Destructively prepend xs onto    */
2621 List xs, ys; {                         /* ys by modifying xs ...           */
2622     if (isNull(xs))
2623         return ys;
2624     else {
2625         List zs = xs;
2626         while (nonNull(tl(zs)))
2627             zs = tl(zs);
2628         tl(zs) = ys;
2629         return xs;
2630     }
2631 }
2632
2633 List dupOnto(xs,ys)      /* non-destructively prepend xs backwards onto ys */
2634 List xs;
2635 List ys; {
2636     for (; nonNull(xs); xs=tl(xs))
2637         ys = cons(hd(xs),ys);
2638     return ys;
2639 }
2640
2641 List dupListOnto(xs,ys)              /* Duplicate spine of list xs onto ys */
2642 List xs;
2643 List ys; {
2644     return revOnto(dupOnto(xs,NIL),ys);
2645 }
2646
2647 List dupList(xs)                       /* Duplicate spine of list xs       */
2648 List xs; {
2649     List ys = NIL;
2650     for (; nonNull(xs); xs=tl(xs))
2651         ys = cons(hd(xs),ys);
2652     return rev(ys);
2653 }
2654
2655 List revOnto(xs,ys)                    /* Destructively reverse elements of*/
2656 List xs, ys; {                         /* list xs onto list ys...          */
2657     Cell zs;
2658
2659     while (nonNull(xs)) {
2660         zs     = tl(xs);
2661         tl(xs) = ys;
2662         ys     = xs;
2663         xs     = zs;
2664     }
2665     return ys;
2666 }
2667
2668 QualId qualidIsMember ( QualId q, List xs )
2669 {
2670    for (; nonNull(xs); xs=tl(xs)) {
2671       if (eqQualIdent(q, hd(xs)))
2672          return hd(xs);
2673    }
2674    return NIL;
2675 }
2676
2677 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
2678 Text t;                                /* given list of variables          */
2679 List xs; {
2680     for (; nonNull(xs); xs=tl(xs))
2681         if (t==textOf(hd(xs)))
2682             return hd(xs);
2683     return NIL;
2684 }
2685
2686 Name nameIsMember(t,ns)                 /* Test if name with text t is a   */
2687 Text t;                                 /* member of list of names xs      */
2688 List ns; {
2689     for (; nonNull(ns); ns=tl(ns))
2690         if (t==name(hd(ns)).text)
2691             return hd(ns);
2692     return NIL;
2693 }
2694
2695 Cell intIsMember(n,xs)                 /* Test if integer n is member of   */
2696 Int  n;                                /* given list of integers           */
2697 List xs; {
2698     for (; nonNull(xs); xs=tl(xs))
2699         if (n==intOf(hd(xs)))
2700             return hd(xs);
2701     return NIL;
2702 }
2703
2704 Cell cellIsMember(x,xs)                /* Test for membership of specific  */
2705 Cell x;                                /* cell x in list xs                */
2706 List xs; {
2707     for (; nonNull(xs); xs=tl(xs))
2708         if (x==hd(xs))
2709             return hd(xs);
2710     return NIL;
2711 }
2712
2713 Cell cellAssoc(c,xs)                   /* Lookup cell in association list  */
2714 Cell c;
2715 List xs; {
2716     for (; nonNull(xs); xs=tl(xs))
2717         if (c==fst(hd(xs)))
2718             return hd(xs);
2719     return NIL;
2720 }
2721
2722 Cell cellRevAssoc(c,xs)                /* Lookup cell in range of          */
2723 Cell c;                                /* association lists                */
2724 List xs; {
2725     for (; nonNull(xs); xs=tl(xs))
2726         if (c==snd(hd(xs)))
2727             return hd(xs);
2728     return NIL;
2729 }
2730
2731 List replicate(n,x)                     /* create list of n copies of x    */
2732 Int n;
2733 Cell x; {
2734     List xs=NIL;
2735     while (0<n--)
2736         xs = cons(x,xs);
2737     return xs;
2738 }
2739
2740 List diffList(from,take)               /* list difference: from\take       */
2741 List from, take; {                     /* result contains all elements of  */
2742     List result = NIL;                 /* `from' not appearing in `take'   */
2743
2744     while (nonNull(from)) {
2745         List next = tl(from);
2746         if (!cellIsMember(hd(from),take)) {
2747             tl(from) = result;
2748             result   = from;
2749         }
2750         from = next;
2751     }
2752     return rev(result);
2753 }
2754
2755 List deleteCell(xs, y)                  /* copy xs deleting pointers to y  */
2756 List xs;
2757 Cell y; {
2758     List result = NIL;
2759     for(;nonNull(xs);xs=tl(xs)) {
2760         Cell x = hd(xs);
2761         if (x != y) {
2762             result=cons(x,result);
2763         }
2764     }
2765     return rev(result);
2766 }
2767
2768 List take(n,xs)                         /* destructively truncate list to  */
2769 Int  n;                                 /* specified length                */
2770 List xs; {
2771     List ys = xs;
2772
2773     if (n==0)
2774         return NIL;
2775     while (1<n-- && nonNull(xs))
2776         xs = tl(xs);
2777     if (nonNull(xs))
2778         tl(xs) = NIL;
2779     return ys;
2780 }
2781
2782 List splitAt(n,xs)                      /* drop n things from front of list*/
2783 Int  n;
2784 List xs; {
2785     for(; n>0; --n) {
2786         xs = tl(xs);
2787     }
2788     return xs;
2789 }
2790
2791 Cell nth(n,xs)                          /* extract n'th element of list    */
2792 Int  n;
2793 List xs; {
2794     for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2795     }
2796     if (isNull(xs))
2797         internal("nth");
2798     return hd(xs);
2799 }
2800
2801 List removeCell(x,xs)                   /* destructively remove cell from  */
2802 Cell x;                                 /* list                            */
2803 List xs; {
2804     if (nonNull(xs)) {
2805         if (hd(xs)==x)
2806             return tl(xs);              /* element at front of list        */
2807         else {
2808             List prev = xs;
2809             List curr = tl(xs);
2810             for (; nonNull(curr); prev=curr, curr=tl(prev))
2811                 if (hd(curr)==x) {
2812                     tl(prev) = tl(curr);
2813                     return xs;          /* element in middle of list       */
2814                 }
2815         }
2816     }
2817     return xs;                          /* here if element not found       */
2818 }
2819
2820 List nubList(xs)                        /* nuke dups in list               */
2821 List xs; {                              /* non destructive                 */
2822    List outs = NIL;
2823    for (; nonNull(xs); xs=tl(xs))
2824       if (isNull(cellIsMember(hd(xs),outs)))
2825          outs = cons(hd(xs),outs);
2826    outs = rev(outs);
2827    return outs;
2828 }
2829
2830
2831 /* --------------------------------------------------------------------------
2832  * Tagged tuples (experimental)
2833  * ------------------------------------------------------------------------*/
2834
2835 static void z_tag_check ( Cell x, int tag, char* caller )
2836 {
2837    char buf[100];
2838    if (isNull(x)) {
2839       sprintf(buf,"z_tag_check(%s): null\n", caller);
2840       internal(buf);
2841    }
2842    if (whatIs(x) != tag) {
2843       sprintf(buf,
2844           "z_tag_check(%s): tag was %d, expected %d\n",
2845           caller, whatIs(x), tag );
2846       internal(buf);
2847    }
2848 }
2849
2850 Cell zpair ( Cell x1, Cell x2 )
2851 { return ap(ZTUP2,ap(x1,x2)); }
2852 Cell zfst ( Cell zpair )
2853 { z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
2854 Cell zsnd ( Cell zpair )
2855 { z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
2856
2857 Cell ztriple ( Cell x1, Cell x2, Cell x3 )
2858 { return ap(ZTUP3,ap(x1,ap(x2,x3))); }
2859 Cell zfst3 ( Cell zpair )
2860 { z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
2861 Cell zsnd3 ( Cell zpair )
2862 { z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
2863 Cell zthd3 ( Cell zpair )
2864 { z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
2865
2866 Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
2867 { return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
2868 Cell zsel14 ( Cell zpair )
2869 { z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
2870 Cell zsel24 ( Cell zpair )
2871 { z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
2872 Cell zsel34 ( Cell zpair )
2873 { z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
2874 Cell zsel44 ( Cell zpair )
2875 { z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
2876
2877 Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
2878 { return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
2879 Cell zsel15 ( Cell zpair )
2880 { z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
2881 Cell zsel25 ( Cell zpair )
2882 { z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
2883 Cell zsel35 ( Cell zpair )
2884 { z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
2885 Cell zsel45 ( Cell zpair )
2886 { z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
2887 Cell zsel55 ( Cell zpair )
2888 { z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
2889
2890
2891 Cell unap ( int tag, Cell c )
2892 {
2893    char buf[100];
2894    if (whatIs(c) != tag) {
2895       sprintf(buf, "unap: specified %d, actual %d\n",
2896                    tag, whatIs(c) );
2897       internal(buf);
2898    }
2899    return snd(c);
2900 }
2901
2902 /* --------------------------------------------------------------------------
2903  * Operations on applications:
2904  * ------------------------------------------------------------------------*/
2905
2906 Int argCount;                          /* number of args in application    */
2907
2908 Cell getHead(e)                        /* get head cell of application     */
2909 Cell e; {                              /* set number of args in argCount   */
2910     for (argCount=0; isAp(e); e=fun(e))
2911         argCount++;
2912     return e;
2913 }
2914
2915 List getArgs(e)                        /* get list of arguments in function*/
2916 Cell e; {                              /* application:                     */
2917     List as;                           /* getArgs(f e1 .. en) = [e1,..,en] */
2918
2919     for (as=NIL; isAp(e); e=fun(e))
2920         as = cons(arg(e),as);
2921     return as;
2922 }
2923
2924 Cell nthArg(n,e)                       /* return nth arg in application    */
2925 Int  n;                                /* of function to m args (m>=n)     */
2926 Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
2927     for (n=numArgs(e)-n-1; n>0; n--)
2928         e = fun(e);
2929     return arg(e);
2930 }
2931
2932 Int numArgs(e)                         /* find number of arguments to expr */
2933 Cell e; {
2934     Int n;
2935     for (n=0; isAp(e); e=fun(e))
2936         n++;
2937     return n;
2938 }
2939
2940 Cell applyToArgs(f,args)               /* destructively apply list of args */
2941 Cell f;                                /* to function f                    */
2942 List args; {
2943     while (nonNull(args)) {
2944         Cell temp = tl(args);
2945         tl(args)  = hd(args);
2946         hd(args)  = f;
2947         f         = args;
2948         args      = temp;
2949     }
2950     return f;
2951 }
2952
2953 /* --------------------------------------------------------------------------
2954  * debugging support
2955  * ------------------------------------------------------------------------*/
2956
2957 static String maybeModuleStr ( Module m )
2958 {
2959    if (isModule(m)) return textToStr(module(m).text); else return "??";
2960 }
2961
2962 static String maybeNameStr ( Name n )
2963 {
2964    if (isName(n)) return textToStr(name(n).text); else return "??";
2965 }
2966
2967 static String maybeTyconStr ( Tycon t )
2968 {
2969    if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
2970 }
2971
2972 static String maybeClassStr ( Class c )
2973 {
2974    if (isClass(c)) return textToStr(cclass(c).text); else return "??";
2975 }
2976
2977 static String maybeText ( Text t )
2978 {
2979    if (isNull(t)) return "(nil)";
2980    return textToStr(t);
2981 }
2982
2983 static void print100 ( Int x )
2984 {
2985    print ( x, 100); printf("\n");
2986 }
2987
2988 void dumpTycon ( Int t )
2989 {
2990    if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR;
2991    if (!isTycon(t)) {
2992       printf ( "dumpTycon %d: not a tycon\n", t);
2993       return;
2994    }
2995    printf ( "{\n" );
2996    printf ( "    text: %s\n",     textToStr(tycon(t).text) );
2997    printf ( "    line: %d\n",     tycon(t).line );
2998    printf ( "     mod: %s\n",     maybeModuleStr(tycon(t).mod));
2999    printf ( "   tuple: %d\n",     tycon(t).tuple);
3000    printf ( "   arity: %d\n",     tycon(t).arity);
3001    printf ( "    kind: ");        print100(tycon(t).kind);
3002    printf ( "    what: %d\n",     tycon(t).what);
3003    printf ( "    defn: ");        print100(tycon(t).defn);
3004    printf ( "    cToT: %d %s\n",  tycon(t).conToTag,
3005                                   maybeNameStr(tycon(t).conToTag));
3006    printf ( "    tToC: %d %s\n",  tycon(t).tagToCon,
3007                                   maybeNameStr(tycon(t).tagToCon));
3008    printf ( "    itbl: %p\n",     tycon(t).itbl);
3009    printf ( "  nextTH: %d %s\n",  tycon(t).nextTyconHash,
3010                                   maybeTyconStr(tycon(t).nextTyconHash));
3011    printf ( "}\n" );
3012 }
3013
3014 void dumpName ( Int n )
3015 {
3016    if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR;
3017    if (!isName(n)) {
3018       printf ( "dumpName %d: not a name\n", n);
3019       return;
3020    }
3021    printf ( "{\n" );
3022    printf ( "    text: %s\n",     textToStr(name(n).text) );
3023    printf ( "    line: %d\n",     name(n).line );
3024    printf ( "     mod: %s\n",     maybeModuleStr(name(n).mod));
3025    printf ( "  syntax: %d\n",     name(n).syntax );
3026    printf ( "  parent: %d\n",     name(n).parent );
3027    printf ( "   arity: %d\n",     name(n).arity );
3028    printf ( "  number: %d\n",     name(n).number );
3029    printf ( "    type: ");        print100(name(n).type);
3030    printf ( "    defn: %d\n",     name(n).defn );
3031    printf ( "  stgVar: ");        print100(name(n).stgVar);
3032    printf ( "   cconv: %d\n",     name(n).callconv );
3033    printf ( "  primop: %p\n",     name(n).primop );
3034    printf ( "    itbl: %p\n",     name(n).itbl );
3035    printf ( "  nextNH: %d\n",     name(n).nextNameHash );
3036    printf ( "}\n" );
3037 }
3038
3039
3040 void dumpClass ( Int c )
3041 {
3042    if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR;
3043    if (!isClass(c)) {
3044       printf ( "dumpClass %d: not a class\n", c);
3045       return;
3046    }
3047    printf ( "{\n" );
3048    printf ( "    text: %s\n",     textToStr(cclass(c).text) );
3049    printf ( "    line: %d\n",     cclass(c).line );
3050    printf ( "     mod: %s\n",     maybeModuleStr(cclass(c).mod));
3051    printf ( "   arity: %d\n",     cclass(c).arity );
3052    printf ( "   level: %d\n",     cclass(c).level );
3053    printf ( "   kinds: ");        print100( cclass(c).kinds );
3054    printf ( "     fds: %d\n",     cclass(c).fds );
3055    printf ( "    xfds: %d\n",     cclass(c).xfds );
3056    printf ( "    head: ");        print100( cclass(c).head );
3057    printf ( "    dcon: ");        print100( cclass(c).dcon );
3058    printf ( "  supers: ");        print100( cclass(c).supers );
3059    printf ( " #supers: %d\n",     cclass(c).numSupers );
3060    printf ( "   dsels: ");        print100( cclass(c).dsels );
3061    printf ( " members: ");        print100( cclass(c).members );
3062    printf ( "#members: %d\n",     cclass(c).numMembers );
3063    printf ( "defaults: ");        print100( cclass(c).defaults );
3064    printf ( "   insts: ");        print100( cclass(c).instances );
3065    printf ( "}\n" );
3066 }
3067
3068
3069 void dumpInst ( Int i )
3070 {
3071    if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR;
3072    if (!isInst(i)) {
3073       printf ( "dumpInst %d: not an instance\n", i);
3074       return;
3075    }
3076    printf ( "{\n" );
3077    printf ( "   class: %s\n",     maybeClassStr(inst(i).c) );
3078    printf ( "    line: %d\n",     inst(i).line );
3079    printf ( "     mod: %s\n",     maybeModuleStr(inst(i).mod));
3080    printf ( "   kinds: ");        print100( inst(i).kinds );
3081    printf ( "    head: ");        print100( inst(i).head );
3082    printf ( "   specs: ");        print100( inst(i).specifics );
3083    printf ( "  #specs: %d\n",     inst(i).numSpecifics );
3084    printf ( "   impls: ");        print100( inst(i).implements );
3085    printf ( " builder: %s\n",     maybeNameStr( inst(i).builder ) );
3086    printf ( "}\n" );
3087 }
3088
3089
3090 /* --------------------------------------------------------------------------
3091  * storage control:
3092  * ------------------------------------------------------------------------*/
3093
3094 Void storage(what)
3095 Int what; {
3096     Int i;
3097
3098     switch (what) {
3099         case POSTPREL: break;
3100
3101         case RESET   : clearStack();
3102
3103                        /* the next 2 statements are particularly important
3104                         * if you are using GLOBALfst or GLOBALsnd since the
3105                         * corresponding registers may be reset to their
3106                         * uninitialised initial values by a longjump.
3107                         */
3108                        heapTopFst = heapFst + heapSize;
3109                        heapTopSnd = heapSnd + heapSize;
3110                        consGC = TRUE;
3111                        lsave  = NIL;
3112                        rsave  = NIL;
3113                        if (isNull(lastExprSaved))
3114                            savedText = TEXT_SIZE;
3115                        break;
3116
3117         case MARK    :
3118                        start();
3119                        for (i = NAME_BASE_ADDR;
3120                             i < NAME_BASE_ADDR+tabNameSz; ++i) {
3121                           if (tabName[i-NAME_BASE_ADDR].inUse) {
3122                              mark(name(i).parent);
3123                              mark(name(i).type);
3124                              mark(name(i).defn);
3125                              mark(name(i).stgVar);
3126                           }
3127                        }
3128                        end("Names", nameHw-NAMEMIN);
3129
3130                        start();
3131                        for (i = MODULE_BASE_ADDR;
3132                             i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
3133                           if (tabModule[i-MODULE_BASE_ADDR].inUse) {
3134                              mark(module(i).tycons);
3135                              mark(module(i).names);
3136                              mark(module(i).classes);
3137                              mark(module(i).exports);
3138                              mark(module(i).qualImports);
3139                              mark(module(i).tree);
3140                              mark(module(i).uses);
3141                              mark(module(i).objectExtraNames);
3142                           }
3143                        }
3144                        mark(moduleGraph);
3145                        mark(prelModules);
3146                        mark(targetModules);
3147                        end("Modules", moduleHw-MODMIN);
3148
3149                        start();
3150                        for (i = TYCON_BASE_ADDR;
3151                             i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3152                           if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
3153                              mark(tycon(i).kind);
3154                              mark(tycon(i).what);
3155                              mark(tycon(i).defn);
3156                           }
3157                        }
3158                        end("Type constructors", tyconHw-TYCMIN);
3159
3160                        start();
3161                        for (i = CCLASS_BASE_ADDR;
3162                             i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
3163                           if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
3164                              mark(cclass(i).kinds);
3165                              mark(cclass(i).fds);
3166                              mark(cclass(i).xfds);
3167                              mark(cclass(i).head);
3168                              mark(cclass(i).supers);
3169                              mark(cclass(i).dsels);
3170                              mark(cclass(i).members);
3171                              mark(cclass(i).defaults);
3172                              mark(cclass(i).instances);
3173                           }
3174                        }
3175                        mark(classes);
3176                        end("Classes", classHw-CLASSMIN);
3177
3178                        start();
3179                        for (i = INST_BASE_ADDR;
3180                             i < INST_BASE_ADDR+tabInstSz; ++i) {
3181                           if (tabInst[i-INST_BASE_ADDR].inUse) {
3182                              mark(inst(i).kinds);
3183                              mark(inst(i).head);
3184                              mark(inst(i).specifics);
3185                              mark(inst(i).implements);
3186                           }
3187                        }
3188                        end("Instances", instHw-INSTMIN);
3189
3190                        start();
3191                        for (i=0; i<=sp; ++i)
3192                            mark(stack(i));
3193                        end("Stack", sp+1);
3194
3195                        start();
3196                        mark(lastExprSaved);
3197                        mark(lsave);
3198                        mark(rsave);
3199                        end("Last expression", 3);
3200
3201                        if (consGC) {
3202                            start();
3203                            gcCStack();
3204                            end("C stack", stackRoots);
3205                        }
3206
3207                        break;
3208
3209         case PREPREL : heapFst = heapAlloc(heapSize);
3210                        heapSnd = heapAlloc(heapSize);
3211
3212                        if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
3213                            ERRMSG(0) "Cannot allocate heap storage (%d cells)",
3214                                      heapSize
3215                            EEND;
3216                        }
3217
3218                        heapTopFst = heapFst + heapSize;
3219                        heapTopSnd = heapSnd + heapSize;
3220                        for (i=1; i<heapSize; ++i) {
3221                            fst(-i) = FREECELL;
3222                            snd(-i) = -(i+1);
3223                        }
3224                        snd(-heapSize) = NIL;
3225                        freeList  = -1;
3226                        numGcs    = 0;
3227                        consGC    = TRUE;
3228                        lsave     = NIL;
3229                        rsave     = NIL;
3230
3231                        marksSize  = bitArraySize(heapSize);
3232                        if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
3233                            ERRMSG(0) "Unable to allocate gc markspace"
3234                            EEND;
3235                        }
3236
3237                        clearStack();
3238
3239                        textHw        = 0;
3240                        nextNewText   = INVAR_BASE_ADDR;
3241                        nextNewDText  = INDVAR_BASE_ADDR;
3242                        lastExprSaved = NIL;
3243                        savedText     = TEXT_SIZE;
3244
3245                        for (i=0; i<TEXTHSZ;  ++i) textHash[i][0] = NOTEXT;
3246                        for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
3247                        for (i=0; i<NAMEHSZ;  ++i) nameHash[RC_N(i)] = NIL;
3248
3249                        break;
3250     }
3251 }
3252
3253 /*-------------------------------------------------------------------------*/