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