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