ghc/interpreter/storage.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Primitives for manipulating global data structures
   4  *
   5  * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
   6  * Haskell Group 1994-99, and is distributed as Open Source software
   7  * under the Artistic License; see the file "Artistic" that is included
   8  * in the distribution for details.
   9  *
  10  * $RCSfile: storage.c,v $
  11  * $Revision: 1.5 $
  12  * $Date: 1999/03/09 14:51:13 $
  13  * ------------------------------------------------------------------------*/
  14
  15 #include "prelude.h"
  16 #include "storage.h"
  17 #include "backend.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20 #include <setjmp.h>
  21
  22 /*#define DEBUG_SHOWUSE*/
  23
  24 /* --------------------------------------------------------------------------
  25  * local function prototypes:
  26  * ------------------------------------------------------------------------*/
  27
  28 static Int  local hash                  Args((String));
  29 static Int  local saveText              Args((Text));
  30 #if !IGNORE_MODULES
  31 static Module local findQualifier       Args((Text));
  32 #endif
  33 static Void local hashTycon             Args((Tycon));
  34 static List local insertTycon           Args((Tycon,List));
  35 static Void local hashName              Args((Name));
  36 static List local insertName            Args((Name,List));
  37 static Void local patternError          Args((String));
  38 static Bool local stringMatch           Args((String,String));
  39 static Bool local typeInvolves          Args((Type,Type));
  40 static Cell local markCell              Args((Cell));
  41 static Void local markSnd               Args((Cell));
  42 static Cell local lowLevelLastIn        Args((Cell));
  43 static Cell local lowLevelLastOut       Args((Cell));
  44 /* from STG */
  45        Module local moduleOfScript      Args((Script));
  46        Script local scriptThisFile      Args((Text));
  47 /* from 98 */
  48 #if IO_HANDLES
  49 static Void local freeHandle            Args((Int));
  50 #endif
  51 #if GC_STABLEPTRS
  52 static Void local resetStablePtrs       Args((Void));
  53 #endif
  54 /* end */
  55
  56 /* --------------------------------------------------------------------------
  57  * Text storage:
  58  *
  59  * provides storage for the characters making up identifier and symbol
  60  * names, string literals, character constants etc...
  61  *
  62  * All character strings are stored in a large character array, with textHw
  63  * pointing to the next free position.  Lookup in the array is improved using
  64  * a hash table.  Internally, text strings are represented by integer offsets
  65  * from the beginning of the array to the string in question.
  66  *
  67  * Where memory permits, the use of multiple hashtables gives a significant
  68  * increase in performance, particularly when large source files are used.
  69  *
  70  * Each string in the array is terminated by a zero byte.  No string is
  71  * stored more than once, so that it is safe to test equality of strings by
  72  * comparing the corresponding offsets.
  73  *
  74  * Special text values (beyond the range of the text array table) are used
  75  * to generate unique `new variable names' as required.
  76  *
  77  * The same text storage is also used to hold text values stored in a saved
  78  * expression.  This grows downwards from the top of the text table (and is
  79  * not included in the hash table).
  80  * ------------------------------------------------------------------------*/
  81
  82 #define TEXTHSZ 512                     /* Size of Text hash table         */
  83 #define NOTEXT  ((Text)(~0))            /* Empty bucket in Text hash table */
  84 static  Text    textHw;                 /* Next unused position            */
  85 static  Text    savedText = NUM_TEXT;   /* Start of saved portion of text  */
  86 static  Text    nextNewText;            /* Next new text value             */
  87 static  Text    nextNewDText;           /* Next new dict text value        */
  88 static  char    DEFTABLE(text,NUM_TEXT);/* Storage of character strings    */
  89 static  Text    textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage        */
  90
  91 String textToStr(t)                    /* find string corresp to given Text*/
  92 Text t; {
  93     static char newVar[16];
  94
  95     if (0<=t && t<NUM_TEXT)                     /* standard char string    */
  96         return text + t;
  97     if (t<0)
  98         sprintf(newVar,"d%d",-t);               /* dictionary variable     */
  99     else
 100         sprintf(newVar,"v%d",t-NUM_TEXT);       /* normal variable         */
 101     return newVar;
 102 }
 103
 104 String identToStr(v) /*find string corresp to given ident or qualified name*/
 105 Cell v; {
 106     if (!isPair(v)) {
 107         internal("identToStr");
 108     }
 109     switch (fst(v)) {
 110         case VARIDCELL  :
 111         case VAROPCELL  :
 112         case CONIDCELL  :
 113         case CONOPCELL  : return text+textOf(v);
 114
 115         case QUALIDENT  : {   Text pos = textHw;
 116                               Text t   = qmodOf(v);
 117                               while (pos+1 < savedText && text[t]!=0) {
 118                                   text[pos++] = text[t++];
 119                               }
 120                               if (pos+1 < savedText) {
 121                                   text[pos++] = '.';
 122                               }
 123                               t = qtextOf(v);
 124                               while (pos+1 < savedText && text[t]!=0) {
 125                                   text[pos++] = text[t++];
 126                               }
 127                               text[pos] = '\0';
 128                               return text+textHw;
 129                           }
 130     }
 131     internal("identToStr2");
 132     return 0; /* NOTREACHED */
 133 }
 134
 135 Text inventText()     {                 /* return new unused variable name */
 136     return nextNewText++;
 137 }
 138
 139 Text inventDictText() {                 /* return new unused dictvar name  */
 140     return nextNewDText--;
 141 }
 142
 143 Bool inventedText(t)                    /* Signal TRUE if text has been    */
 144 Text t; {                               /* generated internally            */
 145     return (t<0 || t>=NUM_TEXT);
 146 }
 147
 148 static Int local hash(s)                /* Simple hash function on strings */
 149 String s; {
 150     int v, j = 3;
 151
 152     for (v=((int)(*s))*8; *s; s++)
 153         v += ((int)(*s))*(j++);
 154     if (v<0)
 155         v = (-v);
 156     return(v%TEXTHSZ);
 157 }
 158
 159 Text findText(s)                       /* Locate string in Text array      */
 160 String s; {
 161     int    h       = hash(s);
 162     int    hashno  = 0;
 163     Text   textPos = textHash[h][hashno];
 164
 165 #define TryMatch        {   Text   originalTextPos = textPos;              \
 166                             String t;                                      \
 167                             for (t=s; *t==text[textPos]; textPos++,t++)    \
 168                                 if (*t=='\0')                              \
 169                                     return originalTextPos;                \
 170                         }
 171 #define Skip            while (text[textPos++]) ;
 172
 173     while (textPos!=NOTEXT) {
 174         TryMatch
 175         if (++hashno<NUM_TEXTH)         /* look in next hashtable entry    */
 176             textPos = textHash[h][hashno];
 177         else {
 178             Skip
 179             while (textPos < textHw) {
 180                 TryMatch
 181                 Skip
 182             }
 183             break;
 184         }
 185     }
 186
 187 #undef TryMatch
 188 #undef Skip
 189
 190     textPos = textHw;                  /* if not found, save in array      */
 191     if (textHw + (Int)strlen(s) + 1 > savedText) {
 192         ERRMSG(0) "Character string storage space exhausted"
 193         EEND;
 194     }
 195     while ((text[textHw++] = *s++) != 0) {
 196     }
 197     if (hashno<NUM_TEXTH) {            /* updating hash table as necessary */
 198         textHash[h][hashno] = textPos;
 199         if (hashno<NUM_TEXTH-1)
 200             textHash[h][hashno+1] = NOTEXT;
 201     }
 202
 203     return textPos;
 204 }
 205
 206 static Int local saveText(t)            /* Save text value in buffer       */
 207 Text t; {                               /* at top of text table            */
 208     String s = textToStr(t);
 209     Int    l = strlen(s);
 210
 211     if (textHw + l + 1 > savedText) {
 212         ERRMSG(0) "Character string storage space exhausted"
 213         EEND;
 214     }
 215     savedText -= l+1;
 216     strcpy(text+savedText,s);
 217     return savedText;
 218 }
 219
 220
 221 /* --------------------------------------------------------------------------
 222  * Ext storage:
 223  *
 224  * Currently, the only attributes that we store for each Ext value is the
 225  * corresponding Text label.  At some later stage, we may decide to cache
 226  * types, predicates, etc. here as a space saving gesture.  Given that Text
 227  * comparison is cheap, and that this is an experimental implementation, we
 228  * will use a straightforward linear search to locate Ext values from their
 229  * corresponding Text labels; a hashing scheme can be introduced later if
 230  * this turns out to be a problem.
 231  * ------------------------------------------------------------------------*/
 232
 233 #if TREX
 234 Text  DEFTABLE(tabExt,NUM_EXT);         /* Storage for Ext names           */
 235 Ext   extHw;
 236
 237 Ext mkExt(t)                            /* Allocate or find an Ext value   */
 238 Text t; {
 239     Ext e = EXTMIN;
 240     for (; e<extHw; e++)
 241         if (t==extText(e))
 242             return e;
 243     if (extHw-EXTMIN >= NUM_EXT) {
 244         ERRMSG(0) "Ext storage space exhausted"
 245         EEND;
 246     }
 247     extText(extHw) = t;
 248     return extHw++;
 249 }
 250 #endif
 251
 252 /* --------------------------------------------------------------------------
 253  * Tycon storage:
 254  *
 255  * A Tycon represents a user defined type constructor.  Tycons are indexed
 256  * by Text values ... a very simple hash function is used to improve lookup
 257  * times.  Tycon entries with the same hash code are chained together, with
 258  * the most recent entry at the front of the list.
 259  * ------------------------------------------------------------------------*/
 260
 261 #define TYCONHSZ 256                            /* Size of Tycon hash table*/
 262 #define tHash(x) ((x)%TYCONHSZ)                 /* Tycon hash function     */
 263 static  Tycon    tyconHw;                       /* next unused Tycon       */
 264 static  Tycon    DEFTABLE(tyconHash,TYCONHSZ);  /* Hash table storage      */
 265 struct  strTycon DEFTABLE(tabTycon,NUM_TYCON);  /* Tycon storage           */
 266
 267 Tycon newTycon(t)                       /* add new tycon to tycon table    */
 268 Text t; {
 269     Int h = tHash(t);
 270     if (tyconHw-TYCMIN >= NUM_TYCON) {
 271         ERRMSG(0) "Type constructor storage space exhausted"
 272         EEND;
 273     }
 274     tycon(tyconHw).text          = t;   /* clear new tycon record          */
 275     tycon(tyconHw).kind          = NIL;
 276     tycon(tyconHw).defn          = NIL;
 277     tycon(tyconHw).what          = NIL;
 278     tycon(tyconHw).conToTag      = NIL;
 279     tycon(tyconHw).tagToCon      = NIL;
 280 #if !IGNORE_MODULES
 281     tycon(tyconHw).mod           = currentModule;
 282     module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
 283 #endif
 284     tycon(tyconHw).nextTyconHash = tyconHash[h];
 285     tyconHash[h]                 = tyconHw;
 286
 287     return tyconHw++;
 288 }
 289
 290 Tycon findTycon(t)                      /* locate Tycon in tycon table     */
 291 Text t; {
 292     Tycon tc = tyconHash[tHash(t)];
 293
 294     while (nonNull(tc) && tycon(tc).text!=t)
 295         tc = tycon(tc).nextTyconHash;
 296     return tc;
 297 }
 298
 299 Tycon addTycon(tc)  /* Insert Tycon in tycon table - if no clash is caused */
 300 Tycon tc; {
 301     Tycon oldtc = findTycon(tycon(tc).text);
 302     if (isNull(oldtc)) {
 303         hashTycon(tc);
 304 #if !IGNORE_MODULES
 305         module(currentModule).tycons=cons(tc,module(currentModule).tycons);
 306 #endif
 307         return tc;
 308     } else
 309         return oldtc;
 310 }
 311
 312 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 313 Tycon tc; {
 314     Text  t = tycon(tc).text;
 315     Int   h = tHash(t);
 316     tycon(tc).nextTyconHash = tyconHash[h];
 317     tyconHash[h]            = tc;
 318 }
 319
 320 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
 321 Cell id; {
 322     if (!isPair(id)) internal("findQualTycon");
 323     switch (fst(id)) {
 324         case CONIDCELL :
 325         case CONOPCELL :
 326             return findTycon(textOf(id));
 327         case QUALIDENT : {
 328 #if IGNORE_MODULES
 329             return findTycon(qtextOf(id));
 330 #else /* !IGNORE_MODULES */
 331             Text   t  = qtextOf(id);
 332             Module m  = findQualifier(qmodOf(id));
 333             List   es = NIL;
 334             if (isNull(m)) return NIL;
 335             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 336                 Cell e = hd(es);
 337                 if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
 338                     return fst(e);
 339             }
 340             return NIL;
 341 #endif /* !IGNORE_MODULES */
 342         }
 343         default : internal("findQualTycon2");
 344     }
 345     return 0; /* NOTREACHED */
 346 }
 347
 348 Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr   */
 349 Text t;
 350 Kind kind;
 351 Int  ar;
 352 Cell what;
 353 Cell defn; {
 354     Tycon tc        = newTycon(t);
 355     tycon(tc).line  = 0;
 356     tycon(tc).kind  = kind;
 357     tycon(tc).what  = what;
 358     tycon(tc).defn  = defn;
 359     tycon(tc).arity = ar;
 360     return tc;
 361 }
 362
 363 static List local insertTycon(tc,ts)    /* insert tycon tc into sorted list*/
 364 Tycon tc;                               /* ts                              */
 365 List  ts; {
 366     Cell   prev = NIL;
 367     Cell   curr = ts;
 368     String s    = textToStr(tycon(tc).text);
 369
 370     while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
 371         if (hd(curr)==tc)               /* just in case we get duplicates! */
 372             return ts;
 373         prev = curr;
 374         curr = tl(curr);
 375     }
 376     if (nonNull(prev)) {
 377         tl(prev) = cons(tc,curr);
 378         return ts;
 379     }
 380     else
 381         return cons(tc,curr);
 382 }
 383
 384 List addTyconsMatching(pat,ts)          /* Add tycons matching pattern pat */
 385 String pat;                             /* to list of Tycons ts            */
 386 List   ts; {                            /* Null pattern matches every tycon*/
 387     Tycon tc;                           /* (Tycons with NIL kind excluded) */
 388     for (tc=TYCMIN; tc<tyconHw; ++tc)
 389         if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
 390             if (nonNull(tycon(tc).kind))
 391                 ts = insertTycon(tc,ts);
 392     return ts;
 393 }
 394
 395 /* --------------------------------------------------------------------------
 396  * Name storage:
 397  *
 398  * A Name represents a top level binding of a value to an identifier.
 399  * Such values may be a constructor function, a member function in a
 400  * class, a user-defined or primitive value/function.
 401  *
 402  * Names are indexed by Text values ... a very simple hash functions speeds
 403  * access to the table of Names and Name entries with the same hash value
 404  * are chained together, with the most recent entry at the front of the
 405  * list.
 406  * ------------------------------------------------------------------------*/
 407
 408 #define NAMEHSZ  256                            /* Size of Name hash table */
 409 #define nHash(x) ((x)%NAMEHSZ)                  /* hash fn :: Text->Int    */
 410         Name     nameHw;                        /* next unused name        */
 411 static  Name     DEFTABLE(nameHash,NAMEHSZ);    /* Hash table storage      */
 412 struct  strName  DEFTABLE(tabName,NUM_NAME);    /* Name table storage      */
 413
 414 Name newName(t,parent)                  /* Add new name to name table      */
 415 Text t;
 416 Cell parent; {
 417     Int h = nHash(t);
 418     if (nameHw-NAMEMIN >= NUM_NAME) {
 419         ERRMSG(0) "Name storage space exhausted"
 420         EEND;
 421     }
 422     name(nameHw).text         = t;      /* clear new name record           */
 423     name(nameHw).line         = 0;
 424     name(nameHw).syntax       = NO_SYNTAX;
 425     name(nameHw).parent       = parent;
 426     name(nameHw).arity        = 0;
 427     name(nameHw).number       = EXECNAME;
 428     name(nameHw).defn         = NIL;
 429     name(nameHw).stgVar       = NIL;
 430     name(nameHw).type         = NIL;
 431     name(nameHw).primop       = 0;
 432     name(nameHw).mod          = currentModule;
 433     module(currentModule).names=cons(nameHw,module(currentModule).names);
 434     name(nameHw).nextNameHash = nameHash[h];
 435     nameHash[h]               = nameHw;
 436 assert ( name(nameHw).nextNameHash != nameHash[h] );
 437     return nameHw++;
 438 }
 439
 440 Name findName(t)                        /* Locate name in name table       */
 441 Text t; {
 442     Name n = nameHash[nHash(t)];
 443
 444     while (nonNull(n) && name(n).text!=t)
 445         n = name(n).nextNameHash;
 446     return n;
 447 }
 448
 449 Name addName(nm)                        /* Insert Name in name table - if  */
 450 Name nm; {                              /* no clash is caused              */
 451     Name oldnm = findName(name(nm).text);
 452     if (isNull(oldnm)) {
 453         hashName(nm);
 454 #if !IGNORE_MODULES
 455         module(currentModule).names=cons(nm,module(currentModule).names);
 456 #endif
 457         return nm;
 458     } else
 459         return oldnm;
 460 }
 461
 462 static Void local hashName(nm)          /* Insert Name into hash table     */
 463 Name nm; {
 464     Text t                = name(nm).text;
 465     Int  h                = nHash(t);
 466     name(nm).nextNameHash = nameHash[h];
 467     nameHash[h]           = nm;
 468 }
 469
 470 Name findQualName(id)              /* Locate (possibly qualified) name*/
 471 Cell id; {                         /* in name table                   */
 472     if (!isPair(id))
 473         internal("findQualName");
 474     switch (fst(id)) {
 475         case VARIDCELL :
 476         case VAROPCELL :
 477         case CONIDCELL :
 478         case CONOPCELL :
 479             return findName(textOf(id));
 480         case QUALIDENT : {
 481 #if IGNORE_MODULES
 482             return findName(qtextOf(id));
 483 #else /* !IGNORE_MODULES */
 484             Text   t  = qtextOf(id);
 485             Module m  = findQualifier(qmodOf(id));
 486             List   es = NIL;
 487             if (isNull(m)) return NIL;
 488             for(es=module(m).exports; nonNull(es); es=tl(es)) {
 489                 Cell e = hd(es);
 490                 if (isName(e) && name(e).text==t)
 491                     return e;
 492                 else if (isPair(e) && DOTDOT==snd(e)) {
 493                     List subentities = NIL;
 494                     Cell c = fst(e);
 495                     if (isTycon(c)
 496                         && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
 497                         subentities = tycon(c).defn;
 498                     else if (isClass(c))
 499                         subentities = cclass(c).members;
 500                     for(; nonNull(subentities); subentities=tl(subentities)) {
 501                        if (!isName(hd(subentities)))
 502                             internal("findQualName3");
 503                         if (name(hd(subentities)).text == t)
 504                             return hd(subentities);
 505                     }
 506                 }
 507             }
 508             return NIL;
 509 #endif /* !IGNORE_MODULES */
 510         }
 511         default : internal("findQualName2");
 512     }
 513     return 0; /* NOTREACHED */
 514 }
 515
 516 /* --------------------------------------------------------------------------
 517  * Primitive functions:
 518  * ------------------------------------------------------------------------*/
 519
 520 Name addPrimCfunREP(t,arity,no,rep)     /* add primitive constructor func  */
 521 Text t;                                 /* sets rep, not type              */
 522 Int  arity;
 523 Int  no;
 524 Int  rep; { /* Really AsmRep */
 525     Name n          = newName(t,NIL);
 526     name(n).arity   = arity;
 527     name(n).number  = cfunNo(no);
 528     name(n).type    = NIL;
 529     name(n).primop  = (void*)rep;
 530     return n;
 531 }
 532
 533
 534 Name addPrimCfun(t,arity,no,type)       /* add primitive constructor func  */
 535 Text t;
 536 Int  arity;
 537 Int  no;
 538 Cell type; {
 539     Name n         = newName(t,NIL);
 540     name(n).arity  = arity;
 541     name(n).number = cfunNo(no);
 542     name(n).type   = type;
 543     return n;
 544 }
 545
 546
 547 Int sfunPos(s,c)                        /* Find position of field with     */
 548 Name s;                                 /* selector s in constructor c.    */
 549 Name c; {
 550     List cns;
 551     cns = name(s).defn;
 552     for (; nonNull(cns); cns=tl(cns))
 553         if (fst(hd(cns))==c)
 554             return intOf(snd(hd(cns)));
 555     internal("sfunPos");
 556     return 0;/* NOTREACHED */
 557 }
 558
 559 static List local insertName(nm,ns)     /* insert name nm into sorted list */
 560 Name nm;                                /* ns                              */
 561 List ns; {
 562     Cell   prev = NIL;
 563     Cell   curr = ns;
 564     String s    = textToStr(name(nm).text);
 565
 566     while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
 567         if (hd(curr)==nm)               /* just in case we get duplicates! */
 568             return ns;
 569         prev = curr;
 570         curr = tl(curr);
 571     }
 572     if (nonNull(prev)) {
 573         tl(prev) = cons(nm,curr);
 574         return ns;
 575     }
 576     else
 577         return cons(nm,curr);
 578 }
 579
 580 List addNamesMatching(pat,ns)           /* Add names matching pattern pat  */
 581 String pat;                             /* to list of names ns             */
 582 List   ns; {                            /* Null pattern matches every name */
 583     Name nm;                            /* (Names with NIL type, or hidden */
 584 #if 1
 585     for (nm=NAMEMIN; nm<nameHw; ++nm)   /* or invented names are excluded) */
 586         if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
 587             String str = textToStr(name(nm).text);
 588             if (str[0]!='_' && (!pat || stringMatch(pat,str)))
 589                 ns = insertName(nm,ns);
 590         }
 591     return ns;
 592 #else
 593     List mns = module(currentModule).names;
 594     for(; nonNull(mns); mns=tl(mns)) {
 595         Name nm = hd(mns);
 596         if (!inventedText(name(nm).text)) {
 597             String str = textToStr(name(nm).text);
 598             if (str[0]!='_' && (!pat || stringMatch(pat,str)))
 599                 ns = insertName(nm,ns);
 600         }
 601     }
 602     return ns;
 603 #endif
 604 }
 605
 606 /* --------------------------------------------------------------------------
 607  * A simple string matching routine
 608  *     `*'    matches any sequence of zero or more characters
 609  *     `?'    matches any single character exactly
 610  *     `@str' matches the string str exactly (ignoring any special chars)
 611  *     `\c'   matches the character c only (ignoring special chars)
 612  *     c      matches the character c only
 613  * ------------------------------------------------------------------------*/
 614
 615 static Void local patternError(s)       /* report error in pattern         */
 616 String s; {
 617     ERRMSG(0) "%s in pattern", s
 618     EEND;
 619 }
 620
 621 static Bool local stringMatch(pat,str)  /* match string against pattern    */
 622 String pat;
 623 String str; {
 624
 625     for (;;)
 626         switch (*pat) {
 627             case '\0' : return (*str=='\0');
 628
 629             case '*'  : do {
 630                             if (stringMatch(pat+1,str))
 631                                 return TRUE;
 632                         } while (*str++);
 633                         return FALSE;
 634
 635             case '?'  : if (*str++=='\0')
 636                             return FALSE;
 637                         pat++;
 638                         break;
 639
 640             case '['  : {   Bool found = FALSE;
 641                             while (*++pat!='\0' && *pat!=']')
 642                                 if (!found && ( pat[0] == *str  ||
 643                                                (pat[1] == '-'   &&
 644                                                 pat[2] != ']'   &&
 645                                                 pat[2] != '\0'  &&
 646                                                 pat[0] <= *str  &&
 647                                                 pat[2] >= *str)))
 648
 649                                     found = TRUE;
 650                             if (*pat != ']')
 651                                 patternError("missing `]'");
 652                             if (!found)
 653                                 return FALSE;
 654                             pat++;
 655                             str++;
 656                         }
 657                         break;
 658
 659             case '\\' : if (*++pat == '\0')
 660                             patternError("extra trailing `\\'");
 661                         /*fallthru!*/
 662             default   : if (*pat++ != *str++)
 663                             return FALSE;
 664                         break;
 665         }
 666 }
 667
 668 /* --------------------------------------------------------------------------
 669  * Storage of type classes, instances etc...:
 670  * ------------------------------------------------------------------------*/
 671
 672 static Class classHw;                  /* next unused class                */
 673 static List  classes;                  /* list of classes in current scope */
 674 static Inst  instHw;                   /* next unused instance record      */
 675
 676 struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records  */
 677 struct strInst far *tabInst;           /* (pointer to) table of instances  */
 678
 679 Class newClass(t)                      /* add new class to class table     */
 680 Text t; {
 681     if (classHw-CLASSMIN >= NUM_CLASSES) {
 682         ERRMSG(0) "Class storage space exhausted"
 683         EEND;
 684     }
 685     cclass(classHw).text      = t;
 686     cclass(classHw).arity     = 0;
 687     cclass(classHw).kinds     = NIL;
 688     cclass(classHw).head      = NIL;
 689     cclass(classHw).dcon      = NIL;
 690     cclass(classHw).supers    = NIL;
 691     cclass(classHw).dsels     = NIL;
 692     cclass(classHw).members   = NIL;
 693     cclass(classHw).dbuild    = NIL;
 694     cclass(classHw).defaults  = NIL;
 695     cclass(classHw).instances = NIL;
 696     classes=cons(classHw,classes);
 697 #if !IGNORE_MODULES
 698     cclass(classHw).mod       = currentModule;
 699     module(currentModule).classes=cons(classHw,module(currentModule).classes);
 700 #endif
 701     return classHw++;
 702 }
 703
 704 Class classMax() {                      /* Return max Class in use ...     */
 705     return classHw;                     /* This is a bit ugly, but it's not*/
 706 }                                       /* worth a lot of effort right now */
 707
 708 Class findClass(t)                     /* look for named class in table    */
 709 Text t; {
 710     Class cl;
 711     List cs;
 712     for (cs=classes; nonNull(cs); cs=tl(cs)) {
 713         cl=hd(cs);
 714         if (cclass(cl).text==t)
 715             return cl;
 716     }
 717     return NIL;
 718 }
 719
 720 Class addClass(c)                       /* Insert Class in class list      */
 721 Class c; {                              /*  - if no clash caused           */
 722     Class oldc = findClass(cclass(c).text);
 723     if (isNull(oldc)) {
 724         classes=cons(c,classes);
 725 #if !IGNORE_MODULES
 726         module(currentModule).classes=cons(c,module(currentModule).classes);
 727 #endif
 728         return c;
 729     }
 730     else
 731         return oldc;
 732 }
 733
 734 Class findQualClass(c)                  /* Look for (possibly qualified)   */
 735 Cell c; {                               /* class in class list             */
 736     if (!isQualIdent(c)) {
 737         return findClass(textOf(c));
 738     } else {
 739 #if IGNORE_MODULES
 740         return findClass(qtextOf(c));
 741 #else /* !IGNORE_MODULES */
 742         Text   t  = qtextOf(c);
 743         Module m  = findQualifier(qmodOf(c));
 744         List   es = NIL;
 745         if (isNull(m))
 746             return NIL;
 747         for (es=module(m).exports; nonNull(es); es=tl(es)) {
 748             Cell e = hd(es);
 749             if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
 750                 return fst(e);
 751         }
 752 #endif
 753     }
 754     return NIL;
 755 }
 756
 757 Inst newInst() {                       /* Add new instance to table        */
 758     if (instHw-INSTMIN >= NUM_INSTS) {
 759         ERRMSG(0) "Instance storage space exhausted"
 760         EEND;
 761     }
 762     inst(instHw).kinds      = NIL;
 763     inst(instHw).head       = NIL;
 764     inst(instHw).specifics  = NIL;
 765     inst(instHw).implements = NIL;
 766     inst(instHw).builder    = NIL;
 767
 768     return instHw++;
 769 }
 770
 771 #ifdef DEBUG_DICTS
 772 extern Void printInst Args((Inst));
 773
 774 Void printInst(in)
 775 Inst in; {
 776     Class cl = inst(in).c;
 777     Printf("%s-", textToStr(cclass(cl).text));
 778     printType(stdout,inst(in).t);
 779 }
 780 #endif /* DEBUG_DICTS */
 781
 782 Inst findFirstInst(tc)                  /* look for 1st instance involving */
 783 Tycon tc; {                             /* the type constructor tc         */
 784     return findNextInst(tc,INSTMIN-1);
 785 }
 786
 787 Inst findNextInst(tc,in)                /* look for next instance involving*/
 788 Tycon tc;                               /* the type constructor tc         */
 789 Inst  in; {                             /* starting after instance in      */
 790     while (++in < instHw) {
 791         Cell pi = inst(in).head;
 792         for (; isAp(pi); pi=fun(pi))
 793             if (typeInvolves(arg(pi),tc))
 794                 return in;
 795     }
 796     return NIL;
 797 }
 798
 799 static Bool local typeInvolves(ty,tc)   /* Test to see if type ty involves */
 800 Type ty;                                /* type constructor/tuple tc.      */
 801 Type tc; {
 802     return (ty==tc)
 803         || (isAp(ty) && (typeInvolves(fun(ty),tc)
 804                          || typeInvolves(arg(ty),tc)));
 805 }
 806
 807 /* --------------------------------------------------------------------------
 808  * Control stack:
 809  *
 810  * Various parts of the system use a stack of cells.  Most of the stack
 811  * operations are defined as macros, expanded inline.
 812  * ------------------------------------------------------------------------*/
 813
 814 Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack          */
 815 StackPtr sp;                        /* stack pointer                       */
 816
 817 #if GIMME_STACK_DUMPS
 818
 819 #define UPPER_DISP  5               /* # display entries on top of stack   */
 820 #define LOWER_DISP  5               /* # display entries on bottom of stack*/
 821
 822 Void hugsStackOverflow() {          /* Report stack overflow               */
 823     extern Int  rootsp;
 824     extern Cell evalRoots[];
 825
 826     ERRMSG(0) "Control stack overflow" ETHEN
 827     if (rootsp>=0) {
 828         Int i;
 829         if (rootsp>=UPPER_DISP+LOWER_DISP) {
 830             for (i=0; i<UPPER_DISP; i++) {
 831                 ERRTEXT "\nwhile evaluating: " ETHEN
 832                 ERREXPR(evalRoots[rootsp-i]);
 833             }
 834             ERRTEXT "\n..." ETHEN
 835             for (i=LOWER_DISP-1; i>=0; i--) {
 836                 ERRTEXT "\nwhile evaluating: " ETHEN
 837                 ERREXPR(evalRoots[i]);
 838             }
 839         }
 840         else {
 841             for (i=rootsp; i>=0; i--) {
 842                 ERRTEXT "\nwhile evaluating: " ETHEN
 843                 ERREXPR(evalRoots[i]);
 844             }
 845         }
 846     }
 847     ERRTEXT "\n"
 848     EEND;
 849 }
 850
 851 #else /* !GIMME_STACK_DUMPS */
 852
 853 Void hugsStackOverflow() {          /* Report stack overflow               */
 854     ERRMSG(0) "Control stack overflow"
 855     EEND;
 856 }
 857
 858 #endif /* !GIMME_STACK_DUMPS */
 859
 860 /* --------------------------------------------------------------------------
 861  * Module storage:
 862  *
 863  * A Module represents a user defined module.
 864  *
 865  * Note: there are now two lookup mechanisms in the system:
 866  *
 867  * 1) The exports from a module are stored in a big list.
 868  *    We resolve qualified names, and import lists by linearly scanning
 869  *    through this list.
 870  *
 871  * 2) Unqualified imports and local definitions for the current module
 872  *    are stored in hash tables (tyconHash and nameHash) or linear lists
 873  *    (classes).
 874  *
 875  * ------------------------------------------------------------------------*/
 876
 877 #if !IGNORE_MODULES
 878 static  Module   moduleHw;              /* next unused Module              */
 879 struct  Module   DEFTABLE(tabModule,NUM_MODULE); /* Module storage         */
 880 Module  currentModule;                  /* Module currently being processed*/
 881
 882 Bool isValidModule(m)                  /* is m a legitimate module id?     */
 883 Module m; {
 884     return (MODMIN <= m && m < moduleHw);
 885 }
 886
 887 Module newModule(t)                     /* add new module to module table  */
 888 Text t; {
 889     if (moduleHw-MODMIN >= NUM_MODULE) {
 890         ERRMSG(0) "Module storage space exhausted"
 891         EEND;
 892     }
 893     module(moduleHw).text          = t; /* clear new module record         */
 894     module(moduleHw).qualImports   = NIL;
 895     module(moduleHw).exports       = NIL;
 896     module(moduleHw).tycons        = NIL;
 897     module(moduleHw).names         = NIL;
 898     module(moduleHw).classes       = NIL;
 899     module(moduleHw).objectFile    = 0;
 900     return moduleHw++;
 901 }
 902
 903 Module findModule(t)                    /* locate Module in module table  */
 904 Text t; {
 905     Module m;
 906     for(m=MODMIN; m<moduleHw; ++m) {
 907         if (module(m).text==t)
 908             return m;
 909     }
 910     return NIL;
 911 }
 912
 913 Module findModid(c)                    /* Find module by name or filename  */
 914 Cell c; {
 915     switch (whatIs(c)) {
 916         case STRCELL   : { Script s = scriptThisFile(snd(c));
 917                            return (s==-1) ? NIL : moduleOfScript(s);
 918                          }
 919         case CONIDCELL : return findModule(textOf(c));
 920         default        : internal("findModid");
 921     }
 922     assert(0); return 0; /* NOTREACHED */
 923 }
 924
 925 static local Module findQualifier(t)    /* locate Module in import list   */
 926 Text t; {
 927     Module ms;
 928     for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
 929         if (textOf(fst(hd(ms)))==t)
 930             return snd(hd(ms));
 931     }
 932 #if 1 /* mpj */
 933     if (module(currentModule).text==t)
 934         return currentModule;
 935 #endif
 936     return NIL;
 937 }
 938
 939 Void setCurrModule(m)              /* set lookup tables for current module */
 940 Module m; {
 941     Int i;
 942     if (m!=currentModule) {
 943         currentModule = m; /* This is the only assignment to currentModule */
 944         for (i=0; i<TYCONHSZ; ++i)
 945             tyconHash[i] = NIL;
 946         mapProc(hashTycon,module(m).tycons);
 947         for (i=0; i<NAMEHSZ; ++i)
 948             nameHash[i] = NIL;
 949         mapProc(hashName,module(m).names);
 950         classes = module(m).classes;
 951     }
 952 }
 953 #endif /* !IGNORE_MODULES */
 954
 955 /* --------------------------------------------------------------------------
 956  * Script file storage:
 957  *
 958  * script files are read into the system one after another.  The state of
 959  * the stored data structures (except the garbage-collected heap) is recorded
 960  * before reading a new script.  In the event of being unable to read the
 961  * script, or if otherwise requested, the system can be restored to its
 962  * original state immediately before the file was read.
 963  * ------------------------------------------------------------------------*/
 964
 965 typedef struct {                       /* record of storage state prior to */
 966     Text  file;                        /* reading script/module            */
 967     Text  textHw;
 968     Text  nextNewText;
 969     Text  nextNewDText;
 970 #if !IGNORE_MODULES
 971     Module moduleHw;
 972 #endif
 973     Tycon tyconHw;
 974     Name  nameHw;
 975     Class classHw;
 976     Inst  instHw;
 977 #if TREX
 978     Ext   extHw;
 979 #endif
 980 } script;
 981
 982 #ifdef  DEBUG_SHOWUSE
 983 static Void local showUse(msg,val,mx)
 984 String msg;
 985 Int val, mx; {
 986     Printf("%6s : %5d of %5d (%2d%%)\n",msg,val,mx,(100*val)/mx);
 987 }
 988 #endif
 989
 990 static Script scriptHw;                 /* next unused script number       */
 991 static script scripts[NUM_SCRIPTS];     /* storage for script records      */
 992
 993 Script startNewScript(f)                /* start new script, keeping record */
 994 String f; {                             /* of status for later restoration  */
 995     if (scriptHw >= NUM_SCRIPTS) {
 996         ERRMSG(0) "Too many script files in use"
 997         EEND;
 998     }
 999 #ifdef DEBUG_SHOWUSE
1000     showUse("Text",   textHw,           NUM_TEXT);
1001 #if !IGNORE_MODULES
1002     showUse("Module", moduleHw-MODMIN,  NUM_MODULE);
1003 #endif
1004     showUse("Tycon",  tyconHw-TYCMIN,   NUM_TYCON);
1005     showUse("Name",   nameHw-NAMEMIN,   NUM_NAME);
1006     showUse("Class",  classHw-CLASSMIN, NUM_CLASSES);
1007     showUse("Inst",   instHw-INSTMIN,   NUM_INSTS);
1008 #if TREX
1009     showUse("Ext",    extHw-EXTMIN,     NUM_EXT);
1010 #endif
1011 #endif
1012
1013     scripts[scriptHw].file         = findText( f ? f : "<nofile>" );
1014     scripts[scriptHw].textHw       = textHw;
1015     scripts[scriptHw].nextNewText  = nextNewText;
1016     scripts[scriptHw].nextNewDText = nextNewDText;
1017 #if !IGNORE_MODULES
1018     scripts[scriptHw].moduleHw     = moduleHw;
1019 #endif
1020     scripts[scriptHw].tyconHw      = tyconHw;
1021     scripts[scriptHw].nameHw       = nameHw;
1022     scripts[scriptHw].classHw      = classHw;
1023     scripts[scriptHw].instHw       = instHw;
1024 #if TREX
1025     scripts[scriptHw].extHw        = extHw;
1026 #endif
1027     return scriptHw++;
1028 }
1029
1030 Bool isPreludeScript() {                /* Test whether this is the Prelude*/
1031     return (scriptHw==0);
1032 }
1033
1034 #if !IGNORE_MODULES
1035 Bool moduleThisScript(m)                /* Test if given module is defined */
1036 Module m; {                             /* in current script file          */
1037     return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
1038 }
1039
1040 Module lastModule() {              /* Return module in current script file */
1041     return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude);
1042 }
1043 #endif /* !IGNORE_MODULES */
1044
1045 #define scriptThis(nm,t,tag)            Script nm(x)                       \
1046                                         t x; {                             \
1047                                             Script s=0;                    \
1048                                             while (s<scriptHw              \
1049                                                    && x>=scripts[s].tag)   \
1050                                                 s++;                       \
1051                                             return s;                      \
1052                                         }
1053 scriptThis(scriptThisName,Name,nameHw)
1054 scriptThis(scriptThisTycon,Tycon,tyconHw)
1055 scriptThis(scriptThisInst,Inst,instHw)
1056 scriptThis(scriptThisClass,Class,classHw)
1057 #undef scriptThis
1058
1059 Module moduleOfScript(s)
1060 Script s; {
1061     return (s==0) ? modulePrelude : scripts[s-1].moduleHw;
1062 }
1063
1064 #if !IGNORE_MODULES
1065 String fileOfModule(m)
1066 Module m; {
1067     Script s;
1068     if (m == modulePrelude) {
1069         return STD_PRELUDE;
1070     }
1071     for(s=0; s<scriptHw; ++s) {
1072         if (scripts[s].moduleHw == m) {
1073             return textToStr(scripts[s].file);
1074         }
1075     }
1076     return 0;
1077 }
1078 #endif
1079
1080 Script scriptThisFile(f)
1081 Text f; {
1082     Script s;
1083     for (s=0; s < scriptHw; ++s) {
1084         if (scripts[s].file == f) {
1085             return s+1;
1086         }
1087     }
1088     if (f == findText(STD_PRELUDE)) {
1089         return 0;
1090     }
1091     return (-1);
1092 }
1093
1094 Void dropScriptsFrom(sno)               /* Restore storage to state prior  */
1095 Script sno; {                           /* to reading script sno           */
1096     if (sno<scriptHw) {                 /* is there anything to restore?   */
1097         int i;
1098         textHw       = scripts[sno].textHw;
1099         nextNewText  = scripts[sno].nextNewText;
1100         nextNewDText = scripts[sno].nextNewDText;
1101 #if !IGNORE_MODULES
1102         moduleHw     = scripts[sno].moduleHw;
1103 #endif
1104         tyconHw      = scripts[sno].tyconHw;
1105         nameHw       = scripts[sno].nameHw;
1106         classHw      = scripts[sno].classHw;
1107         instHw       = scripts[sno].instHw;
1108 #if USE_DICTHW
1109         dictHw       = scripts[sno].dictHw;
1110 #endif
1111 #if TREX
1112         extHw        = scripts[sno].extHw;
1113 #endif
1114
1115 #if 0  //zzzzzzzzzzzzzzzzz
1116         for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
1117             if (module(i).objectFile) {
1118                 printf("[bogus] closing objectFile for module %d\n",i);
1119                 /*dlclose(module(i).objectFile);*/
1120             }
1121         }
1122         moduleHw = scripts[sno].moduleHw;
1123 #endif
1124         for (i=0; i<TEXTHSZ; ++i) {
1125             int j = 0;
1126             while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
1127                                && textHash[i][j]<textHw)
1128                 ++j;
1129             if (j<NUM_TEXTH)
1130                 textHash[i][j] = NOTEXT;
1131         }
1132
1133 #if IGNORE_MODULES
1134         for (i=0; i<TYCONHSZ; ++i) {
1135             Tycon tc = tyconHash[i];
1136             while (nonNull(tc) && tc>=tyconHw)
1137                 tc = tycon(tc).nextTyconHash;
1138             tyconHash[i] = tc;
1139         }
1140
1141         for (i=0; i<NAMEHSZ; ++i) {
1142             Name n = nameHash[i];
1143             while (nonNull(n) && n>=nameHw)
1144                 n = name(n).nextNameHash;
1145             nameHash[i] = n;
1146         }
1147 #else /* !IGNORE_MODULES */
1148         currentModule=NIL;
1149         for (i=0; i<TYCONHSZ; ++i) {
1150             tyconHash[i] = NIL;
1151         }
1152         for (i=0; i<NAMEHSZ; ++i) {
1153             nameHash[i] = NIL;
1154         }
1155 #endif /* !IGNORE_MODULES */
1156
1157         for (i=CLASSMIN; i<classHw; i++) {
1158             List ins = cclass(i).instances;
1159             List is  = NIL;
1160
1161             while (nonNull(ins)) {
1162                 List temp = tl(ins);
1163                 if (hd(ins)<instHw) {
1164                     tl(ins) = is;
1165                     is      = ins;
1166                 }
1167                 ins = temp;
1168             }
1169             cclass(i).instances = rev(is);
1170         }
1171
1172         scriptHw = sno;
1173     }
1174 }
1175
1176 /* --------------------------------------------------------------------------
1177  * Heap storage:
1178  *
1179  * Provides a garbage collectable heap for storage of expressions etc.
1180  *
1181  * Now incorporates a flat resource:  A two-space collected extension of
1182  * the heap that provides storage for contiguous arrays of Cell storage,
1183  * cooperating with the garbage collection mechanisms for the main heap.
1184  * ------------------------------------------------------------------------*/
1185
1186 Int     heapSize = DEFAULTHEAP;         /* number of cells in heap         */
1187 Heap    heapFst;                        /* array of fst component of pairs */
1188 Heap    heapSnd;                        /* array of snd component of pairs */
1189 #ifndef GLOBALfst
1190 Heap    heapTopFst;
1191 #endif
1192 #ifndef GLOBALsnd
1193 Heap    heapTopSnd;
1194 #endif
1195 Bool    consGC = TRUE;                  /* Set to FALSE to turn off gc from*/
1196                                         /* C stack; use with extreme care! */
1197 #if     PROFILING
1198 Heap    heapThd, heapTopThd;            /* to keep record of producers     */
1199 Int     sysCount;                       /* record unattached cells         */
1200 Name    producer;                       /* current producer, if any        */
1201 Bool    profiling = FALSE;              /* should profiling be performed   */
1202 Int     profInterval = MAXPOSINT;       /* interval between samples        */
1203 FILE    *profile = 0;                   /* pointer to profiler log, if any */
1204 #endif
1205 Long    numCells;
1206 Int     numGcs;                         /* number of garbage collections   */
1207 Int     cellsRecovered;                 /* number of cells recovered       */
1208
1209 static  Cell freeList;                  /* free list of unused cells       */
1210 static  Cell lsave, rsave;              /* save components of pair         */
1211
1212 #if GC_WEAKPTRS
1213 static List weakPtrs;                   /* list of weak ptrs               */
1214                                         /* reconstructed during every GC   */
1215 List   finalizers = NIL;
1216 List   liveWeakPtrs = NIL;
1217 #endif
1218
1219 #if GC_STATISTICS
1220
1221 static Int markCount, stackRoots;
1222
1223 #define initStackRoots() stackRoots = 0
1224 #define recordStackRoot() stackRoots++
1225
1226 #define startGC()       \
1227     if (gcMessages) {   \
1228         Printf("\n");   \
1229         fflush(stdout); \
1230     }
1231 #define endGC()         \
1232     if (gcMessages) {   \
1233         Printf("\n");   \
1234         fflush(stdout); \
1235     }
1236
1237 #define start()      markCount = 0
1238 #define end(thing,rs) \
1239     if (gcMessages) { \
1240         Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
1241         fflush(stdout); \
1242     }
1243 #define recordMark() markCount++
1244
1245 #else /* !GC_STATISTICS */
1246
1247 #define startGC()
1248 #define endGC()
1249
1250 #define initStackRoots()
1251 #define recordStackRoot()
1252
1253 #define start()
1254 #define end(thing,root)
1255 #define recordMark()
1256
1257 #endif /* !GC_STATISTICS */
1258
1259 Cell pair(l,r)                          /* Allocate pair (l, r) from       */
1260 Cell l, r; {                            /* heap, garbage collecting first  */
1261     Cell c = freeList;                  /* if necessary ...                */
1262
1263     if (isNull(c)) {
1264         lsave = l;
1265         rsave = r;
1266         garbageCollect();
1267         l     = lsave;
1268         lsave = NIL;
1269         r     = rsave;
1270         rsave = NIL;
1271         c     = freeList;
1272     }
1273     freeList = snd(freeList);
1274     fst(c)   = l;
1275     snd(c)   = r;
1276 #if PROFILING
1277     thd(c)   = producer;
1278 #endif
1279     numCells++;
1280     return c;
1281 }
1282
1283 Void overwrite(dst,src)                 /* overwrite dst cell with src cell*/
1284 Cell dst, src; {                        /* both *MUST* be pairs            */
1285     if (isPair(dst) && isPair(src)) {
1286         fst(dst) = fst(src);
1287         snd(dst) = snd(src);
1288     }
1289     else
1290         internal("overwrite");
1291 }
1292
1293 static Int *marks;
1294 static Int marksSize;
1295
1296 Cell markExpr(c)                        /* External interface to markCell  */
1297 Cell c; {
1298     return isGenPair(c) ? markCell(c) : c;
1299 }
1300
1301 static Cell local markCell(c)           /* Traverse part of graph marking  */
1302 Cell c; {                               /* cells reachable from given root */
1303                                         /* markCell(c) is only called if c */
1304                                         /* is a pair                       */
1305     {   register int place = placeInSet(c);
1306         register int mask  = maskInSet(c);
1307         if (marks[place]&mask)
1308             return c;
1309         else {
1310             marks[place] |= mask;
1311             recordMark();
1312         }
1313     }
1314
1315     if (isGenPair(fst(c))) {
1316         fst(c) = markCell(fst(c));
1317         markSnd(c);
1318     }
1319     else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
1320         markSnd(c);
1321     }
1322
1323     return c;
1324 }
1325
1326 static Void local markSnd(c)            /* Variant of markCell used to     */
1327 Cell c; {                               /* update snd component of cell    */
1328     Cell t;                             /* using tail recursion            */
1329
1330 ma: t = c;                              /* Keep pointer to original pair   */
1331     c = snd(c);
1332     if (!isPair(c))
1333         return;
1334
1335     {   register int place = placeInSet(c);
1336         register int mask  = maskInSet(c);
1337         if (marks[place]&mask)
1338             return;
1339         else {
1340             marks[place] |= mask;
1341             recordMark();
1342         }
1343     }
1344
1345     if (isGenPair(fst(c))) {
1346         fst(c) = markCell(fst(c));
1347         goto ma;
1348     }
1349     else if (isNull(fst(c)) || fst(c)>=BCSTAG)
1350         goto ma;
1351     return;
1352 }
1353
1354 Void markWithoutMove(n)                 /* Garbage collect cell at n, as if*/
1355 Cell n; {                               /* it was a cell ref, but don't    */
1356                                         /* move cell so we don't have      */
1357                                         /* to modify the stored value of n */
1358     if (isGenPair(n)) {
1359         recordStackRoot();
1360         markCell(n);
1361     }
1362 }
1363
1364 Void garbageCollect()     {             /* Run garbage collector ...       */
1365     Bool breakStat = breakOn(FALSE);    /* disable break checking          */
1366     Int i,j;
1367     register Int mask;
1368     register Int place;
1369     Int      recovered;
1370
1371     jmp_buf  regs;                      /* save registers on stack         */
1372 printf("\n\n$$$$$$$$$$$ GARBAGE COLLECTION; aborting\n\n");
1373 exit(1);
1374     setjmp(regs);
1375
1376     gcStarted();
1377     for (i=0; i<marksSize; ++i)         /* initialise mark set to empty    */
1378         marks[i] = 0;
1379 #if GC_WEAKPTRS
1380     weakPtrs = NIL;                     /* clear list of weak pointers     */
1381 #endif
1382     everybody(MARK);                    /* Mark all components of system   */
1383
1384 #if IO_HANDLES
1385     for (i=0; i<NUM_HANDLES; ++i)       /* release any unused handles      */
1386         if (nonNull(handles[i].hcell)) {
1387             register place = placeInSet(handles[i].hcell);
1388             register mask  = maskInSet(handles[i].hcell);
1389             if ((marks[place]&mask)==0)
1390                 freeHandle(i);
1391         }
1392 #endif
1393 #if GC_MALLOCPTRS
1394     for (i=0; i<NUM_MALLOCPTRS; ++i)    /* release any unused mallocptrs   */
1395         if (isPair(mallocPtrs[i].mpcell)) {
1396             register place = placeInSet(mallocPtrs[i].mpcell);
1397             register mask  = maskInSet(mallocPtrs[i].mpcell);
1398             if ((marks[place]&mask)==0)
1399                 incMallocPtrRefCnt(i,-1);
1400         }
1401 #endif /* GC_MALLOCPTRS */
1402 #if GC_WEAKPTRS
1403     /* After GC completes, we scan the list of weak pointers that are
1404      * still live and zap their contents unless the contents are still
1405      * live (by some other means).
1406      * Note that this means the contents must itself be heap allocated.
1407      * This means it can't be a nullary constructor or an Int or a Name
1408      * or lots of other things - hope this doesn't bite too hard.
1409      */
1410     for (; nonNull(weakPtrs); weakPtrs=nextWeakPtr(weakPtrs)) {
1411         Cell ptr = derefWeakPtr(weakPtrs);
1412         if (isGenPair(ptr)) {
1413             Int  place = placeInSet(ptr);
1414             Int  mask  = maskInSet(ptr);
1415             if ((marks[place]&mask)==0) {
1416                 /* printf("Zapping weak pointer %d\n", ptr); */
1417                 derefWeakPtr(weakPtrs) = NIL;
1418             } else {
1419                 /* printf("Keeping weak pointer %d\n", ptr); */
1420             }
1421         } else if (nonNull(ptr)) {
1422             printf("Weak ptr contains object which isn't heap allocated %d\n", ptr);
1423         }
1424     }
1425
1426     if (nonNull(liveWeakPtrs) || nonNull(finalizers)) {
1427         Bool anyMarked;                 /* Weak pointers with finalizers   */
1428         List wps;
1429         List newFins = NIL;
1430
1431         /* Step 1: iterate until we've found out what is reachable         */
1432         do {
1433             anyMarked = FALSE;
1434             for (wps=liveWeakPtrs; nonNull(wps); wps=tl(wps)) {
1435                 Cell wp = hd(wps);
1436                 Cell k  = fst(snd(wp));
1437                 if (isNull(k)) {
1438                     internal("bad weak ptr");
1439                 }
1440                 if (isMarked(k)) {
1441                     Cell vf = snd(snd(wp));
1442                     if (!isMarked(fst(vf)) || !isMarked(snd(vf))) {
1443                         mark(fst(vf));
1444                         mark(snd(vf));
1445                         anyMarked = TRUE;
1446                     }
1447                 }
1448             }
1449         } while (anyMarked);
1450
1451         /* Step 2: Now we know which weak pointers will die, so we can     */
1452         /* remove them from the live set and gather their finalizers.  But */
1453         /* note that we mustn't mark *anything* at this stage or we will   */
1454         /* corrupt our view of what's alive, and what's dead.              */
1455         wps = NIL;
1456         while (nonNull(liveWeakPtrs)) {
1457             Cell wp = hd(liveWeakPtrs);
1458             List nx = tl(liveWeakPtrs);
1459             Cell k  = fst(snd(wp));
1460             if (!isMarked(k)) {                 /* If the key is dead, then*/
1461                 Cell vf      = snd(snd(wp));    /* stomp on weak pointer   */
1462                 fst(vf)      = snd(vf);
1463                 snd(vf)      = newFins;
1464                 newFins      = vf;              /* reuse because we can't  */
1465                 fst(snd(wp)) = NIL;             /* reallocate here ...     */
1466                 snd(snd(wp)) = NIL;
1467                 snd(wp)      = NIL;
1468                 liveWeakPtrs = nx;
1469             } else {
1470                 tl(liveWeakPtrs) = wps;         /* Otherwise, weak pointer */
1471                 wps              = liveWeakPtrs;/* survives to face another*/
1472                 liveWeakPtrs     = nx;          /* garbage collection      */
1473             }
1474         }
1475
1476         /* Step 3: Now we've identified the live cells and the newly       */
1477         /* scheduled finalizers, but we had better make sure that they are */
1478         /* all marked now, including any internal structure, to ensure that*/
1479         /* they make it to the other side of gc.                           */
1480         for (liveWeakPtrs=wps; nonNull(wps); wps=tl(wps)) {
1481             mark(snd(hd(wps)));
1482         }
1483         mark(liveWeakPtrs);
1484         mark(newFins);
1485         finalizers = revOnto(newFins,finalizers);
1486     }
1487
1488 #endif /* GC_WEAKPTRS */
1489     gcScanning();                       /* scan mark set                   */
1490     mask      = 1;
1491     place     = 0;
1492     recovered = 0;
1493     j         = 0;
1494 #if PROFILING
1495     if (profile) {
1496         sysCount = 0;
1497         for (i=NAMEMIN; i<nameHw; i++)
1498             name(i).count = 0;
1499     }
1500 #endif
1501     freeList = NIL;
1502     for (i=1; i<=heapSize; i++) {
1503         if ((marks[place] & mask) == 0) {
1504             snd(-i)  = freeList;
1505             fst(-i)  = FREECELL;
1506             freeList = -i;
1507             recovered++;
1508         }
1509 #if PROFILING
1510         else if (nonNull(thd(-i)))
1511             name(thd(-i)).count++;
1512         else
1513             sysCount++;
1514 #endif
1515         mask <<= 1;
1516         if (++j == bitsPerWord) {
1517             place++;
1518             mask = 1;
1519             j    = 0;
1520         }
1521     }
1522
1523     gcRecovered(recovered);
1524     breakOn(breakStat);                 /* restore break trapping if nec.  */
1525
1526 #if PROFILING
1527     if (profile) {
1528         fprintf(profile,"BEGIN_SAMPLE %ld.00\n",numReductions);
1529 /* For the time being, we won't include the system count in the output:
1530         if (sysCount>0)
1531             fprintf(profile,"  SYSTEM %d\n",sysCount);
1532 */
1533         /* Accumulate costs in top level objects */
1534         for (i=NAMEMIN; i<nameHw; i++) {
1535             Name cc = i;
1536             /* Use of "while" instead of "if" is pure paranoia - ADR */
1537             while (isName(name(cc).parent))
1538                 cc = name(cc).parent;
1539             if (i != cc) {
1540                 name(cc).count += name(i).count;
1541                 name(i).count = 0;
1542             }
1543         }
1544         for (i=NAMEMIN; i<nameHw; i++)
1545             if (name(i).count>0)
1546                 if (isPair(name(i).parent)) {
1547                     Pair p = name(i).parent;
1548                     Cell f = fst(p);
1549                     fprintf(profile,"  ");
1550                     if (isClass(f))
1551                         fprintf(profile,"%s",textToStr(cclass(f).text));
1552                     else {
1553                         fprintf(profile,"%s_",textToStr(cclass(inst(f).c).text));
1554                         /* Will hp2ps accept the spaces produced by this? */
1555                         printPred(profile,inst(f).head);
1556                     }
1557                     fprintf(profile,"_%s %d\n",
1558                             textToStr(name(snd(p)).text),
1559                             name(i).count);
1560                 } else {
1561                     fprintf(profile,"  %s %d\n",
1562                             textToStr(name(i).text),
1563                             name(i).count);
1564                 }
1565         fprintf(profile,"END_SAMPLE %ld.00\n",numReductions);
1566     }
1567 #endif
1568
1569     /* can only return if freeList is nonempty on return. */
1570     if (recovered<minRecovery || isNull(freeList)) {
1571         ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
1572         EEND;
1573     }
1574     cellsRecovered = recovered;
1575 }
1576
1577 #if PROFILING
1578 Void profilerLog(s)                     /* turn heap profiling on, saving log*/
1579 String s; {                             /* in specified file                 */
1580     if ((profile=fopen(s,"w")) != NULL) {
1581         fprintf(profile,"JOB \"Hugs Heap Profile\"\n");
1582         fprintf(profile,"DATE \"%s\"\n",timeString());
1583         fprintf(profile,"SAMPLE_UNIT \"reductions\"\n");
1584         fprintf(profile,"VALUE_UNIT \"cells\"\n");
1585     }
1586     else {
1587         ERRMSG(0) "Cannot open profile log file \"%s\"", s
1588         EEND;
1589     }
1590 }
1591 #endif
1592
1593 /* --------------------------------------------------------------------------
1594  * Code for saving last expression entered:
1595  *
1596  * This is a little tricky because some text values (e.g. strings or variable
1597  * names) may not be defined or have the same value when the expression is
1598  * recalled.  These text values are therefore saved in the top portion of
1599  * the text table.
1600  * ------------------------------------------------------------------------*/
1601
1602 static Cell lastExprSaved;              /* last expression to be saved     */
1603
1604 Void setLastExpr(e)                     /* save expression for later recall*/
1605 Cell e; {
1606     lastExprSaved = NIL;                /* in case attempt to save fails   */
1607     savedText     = NUM_TEXT;
1608     lastExprSaved = lowLevelLastIn(e);
1609 }
1610
1611 static Cell local lowLevelLastIn(c)     /* Duplicate expression tree (i.e. */
1612 Cell c; {                               /* acyclic graph) for later recall */
1613     if (isPair(c)) {                    /* Duplicating any text strings    */
1614         if (isBoxTag(fst(c)))           /* in case these are lost at some  */
1615             switch (fst(c)) {           /* point before the expr is reused */
1616                 case VARIDCELL :
1617                 case VAROPCELL :
1618                 case DICTVAR   :
1619                 case CONIDCELL :
1620                 case CONOPCELL :
1621                 case STRCELL   : return pair(fst(c),saveText(textOf(c)));
1622                 default        : return pair(fst(c),snd(c));
1623             }
1624         else
1625             return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
1626     }
1627 #if TREX
1628     else if (isExt(c))
1629         return pair(EXTCOPY,saveText(extText(c)));
1630 #endif
1631     else
1632         return c;
1633 }
1634
1635 Cell getLastExpr() {                    /* recover previously saved expr   */
1636     return lowLevelLastOut(lastExprSaved);
1637 }
1638
1639 static Cell local lowLevelLastOut(c)    /* As with lowLevelLastIn() above  */
1640 Cell c; {                               /* except that Cells refering to   */
1641     if (isPair(c)) {                    /* Text values are restored to     */
1642         if (isBoxTag(fst(c)))           /* appropriate values              */
1643             switch (fst(c)) {
1644                 case VARIDCELL :
1645                 case VAROPCELL :
1646                 case DICTVAR   :
1647                 case CONIDCELL :
1648                 case CONOPCELL :
1649                 case STRCELL   : return pair(fst(c),
1650                                              findText(text+intValOf(c)));
1651 #if TREX
1652                 case EXTCOPY   : return mkExt(findText(text+intValOf(c)));
1653 #endif
1654                 default        : return pair(fst(c),snd(c));
1655             }
1656         else
1657             return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
1658     }
1659     else
1660         return c;
1661 }
1662
1663 /* --------------------------------------------------------------------------
1664  * Miscellaneous operations on heap cells:
1665  * ------------------------------------------------------------------------*/
1666
1667 /* Profiling suggests that the number of calls to whatIs() is typically    */
1668 /* rather high.  The recoded version below attempts to improve the average */
1669 /* performance for whatIs() using a binary search for part of the analysis */
1670
1671 Cell whatIs(c)                         /* identify type of cell            */
1672 register Cell c; {
1673     if (isPair(c)) {
1674         register Cell fstc = fst(c);
1675         return isTag(fstc) ? fstc : AP;
1676     }
1677     if (c<TUPMIN)    return c;
1678     if (c>=INTMIN)   return INTCELL;
1679
1680     if (c>=NAMEMIN){if (c>=CLASSMIN)   {if (c>=CHARMIN) return CHARCELL;
1681                                         else            return CLASS;}
1682                     else                if (c>=INSTMIN) return INSTANCE;
1683                                         else            return NAME;}
1684     else            if (c>=MODMIN)     {if (c>=TYCMIN)  return TYCON;
1685                                         else            return MODULE;}
1686                     else                if (c>=OFFMIN)  return OFFSET;
1687 #if TREX
1688                                         else            return (c>=EXTMIN) ?
1689                                                                 EXT : TUPLE;
1690 #else
1691                                         else            return TUPLE;
1692 #endif
1693
1694 /*  if (isPair(c)) {
1695         register Cell fstc = fst(c);
1696         return isTag(fstc) ? fstc : AP;
1697     }
1698     if (c>=INTMIN)   return INTCELL;
1699     if (c>=CHARMIN)  return CHARCELL;
1700     if (c>=CLASSMIN) return CLASS;
1701     if (c>=INSTMIN)  return INSTANCE;
1702     if (c>=NAMEMIN)  return NAME;
1703     if (c>=TYCMIN)   return TYCON;
1704     if (c>=MODMIN)   return MODULE;
1705     if (c>=OFFMIN)   return OFFSET;
1706 #if TREX
1707     if (c>=EXTMIN)   return EXT;
1708 #endif
1709     if (c>=TUPMIN)   return TUPLE;
1710     return c;*/
1711 }
1712
1713 #if DEBUG_PRINTER
1714 /* A very, very simple printer.
1715  * Output is uglier than from printExp - but the printer is more
1716  * robust and can be used on any data structure irrespective of
1717  * its type.
1718  */
1719 Void print Args((Cell, Int));
1720 Void print(c, depth)
1721 Cell c;
1722 Int  depth; {
1723     if (0 == depth) {
1724         Printf("...");
1725 #if 0 /* Not in this version of Hugs */
1726     } else if (isPair(c) && !isGenPair(c)) {
1727         extern Void printEvalCell Args((Cell, Int));
1728         printEvalCell(c,depth);
1729 #endif
1730     } else {
1731         Int tag = whatIs(c);
1732         switch (tag) {
1733         case AP:
1734                 Putchar('(');
1735                 print(fst(c), depth-1);
1736                 Putchar(',');
1737                 print(snd(c), depth-1);
1738                 Putchar(')');
1739                 break;
1740         case FREECELL:
1741                 Printf("free(%d)", c);
1742                 break;
1743         case INTCELL:
1744                 Printf("int(%d)", intOf(c));
1745                 break;
1746         case BIGCELL:
1747                 Printf("bignum(%s)", bignumToString(c));
1748                 break;
1749         case CHARCELL:
1750                 Printf("char('%c')", charOf(c));
1751                 break;
1752         case PTRCELL:
1753                 Printf("ptr(%p)",ptrOf(c));
1754                 break;
1755         case CLASS:
1756                 Printf("class(%d)", c-CLASSMIN);
1757                 if (CLASSMIN <= c && c < classHw) {
1758                     Printf("=\"%s\"", textToStr(cclass(c).text));
1759                 }
1760                 break;
1761         case INSTANCE:
1762                 Printf("instance(%d)", c - INSTMIN);
1763                 break;
1764         case NAME:
1765                 Printf("name(%d)", c-NAMEMIN);
1766                 if (NAMEMIN <= c && c < nameHw) {
1767                     Printf("=\"%s\"", textToStr(name(c).text));
1768                 }
1769                 break;
1770         case TYCON:
1771                 Printf("tycon(%d)", c-TYCMIN);
1772                 if (TYCMIN <= c && c < tyconHw)
1773                     Printf("=\"%s\"", textToStr(tycon(c).text));
1774                 break;
1775         case MODULE:
1776                 Printf("module(%d)", c - MODMIN);
1777                 break;
1778         case OFFSET:
1779                 Printf("Offset %d", offsetOf(c));
1780                 break;
1781         case TUPLE:
1782                 Printf("Tuple %d", tupleOf(c));
1783                 break;
1784         case POLYTYPE:
1785                 Printf("Polytype");
1786                 print(snd(c),depth-1);
1787                 break;
1788         case RANK2:
1789                 Printf("Rank2(");
1790                 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
1791                     Printf("%d ", intOf(fst(snd(c))));
1792                     print(snd(snd(c)),depth-1);
1793                 } else {
1794                     print(snd(c),depth-1);
1795                 }
1796                 Printf(")");
1797                 break;
1798         case NIL:
1799                 Printf("NIL");
1800                 break;
1801         case WILDCARD:
1802                 Printf("_");
1803                 break;
1804         case STAR:
1805                 Printf("STAR");
1806                 break;
1807         case DOTDOT:
1808                 Printf("DOTDOT");
1809                 break;
1810         case DICTVAR:
1811                 Printf("{dict %d}",textOf(c));
1812                 break;
1813         case VARIDCELL:
1814         case VAROPCELL:
1815         case CONIDCELL:
1816         case CONOPCELL:
1817                 Printf("{id %s}",textToStr(textOf(c)));
1818                 break;
1819         case QUALIDENT:
1820                 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
1821                 break;
1822         case LETREC:
1823                 Printf("LetRec(");
1824                 print(fst(snd(c)),depth-1);
1825                 Putchar(',');
1826                 print(snd(snd(c)),depth-1);
1827                 Putchar(')');
1828                 break;
1829         case LAMBDA:
1830                 Printf("Lambda(");
1831                 print(snd(c),depth-1);
1832                 Putchar(')');
1833                 break;
1834         case FINLIST:
1835                 Printf("FinList(");
1836                 print(snd(c),depth-1);
1837                 Putchar(')');
1838                 break;
1839         case COMP:
1840                 Printf("Comp(");
1841                 print(fst(snd(c)),depth-1);
1842                 Putchar(',');
1843                 print(snd(snd(c)),depth-1);
1844                 Putchar(')');
1845                 break;
1846         case ASPAT:
1847                 Printf("AsPat(");
1848                 print(fst(snd(c)),depth-1);
1849                 Putchar(',');
1850                 print(snd(snd(c)),depth-1);
1851                 Putchar(')');
1852                 break;
1853         case FROMQUAL:
1854                 Printf("FromQual(");
1855                 print(fst(snd(c)),depth-1);
1856                 Putchar(',');
1857                 print(snd(snd(c)),depth-1);
1858                 Putchar(')');
1859                 break;
1860         case STGVAR:
1861                 Printf("StgVar%d=",-c);
1862                 print(snd(c), depth-1);
1863                 break;
1864         case STGAPP:
1865                 Printf("StgApp(");
1866                 print(fst(snd(c)),depth-1);
1867                 Putchar(',');
1868                 print(snd(snd(c)),depth-1);
1869                 Putchar(')');
1870                 break;
1871         case STGPRIM:
1872                 Printf("StgPrim(");
1873                 print(fst(snd(c)),depth-1);
1874                 Putchar(',');
1875                 print(snd(snd(c)),depth-1);
1876                 Putchar(')');
1877                 break;
1878         case STGCON:
1879                 Printf("StgCon(");
1880                 print(fst(snd(c)),depth-1);
1881                 Putchar(',');
1882                 print(snd(snd(c)),depth-1);
1883                 Putchar(')');
1884                 break;
1885         case PRIMCASE:
1886                 Printf("PrimCase(");
1887                 print(fst(snd(c)),depth-1);
1888                 Putchar(',');
1889                 print(snd(snd(c)),depth-1);
1890                 Putchar(')');
1891                 break;
1892         default:
1893                 if (isBoxTag(tag)) {
1894                     Printf("Tag(%d)=%d", c, tag);
1895                 } else if (isConTag(tag)) {
1896                     Printf("%d@(%d,",c,tag);
1897                     print(snd(c), depth-1);
1898                     Putchar(')');
1899                     break;
1900                 } else if (c == tag) {
1901                     Printf("Tag(%d)", c);
1902                 } else {
1903                     Printf("Tag(%d)=%d", c, tag);
1904                 }
1905                 break;
1906         }
1907     }
1908     FlushStdout();
1909 }
1910 #endif
1911
1912 Bool isVar(c)                           /* is cell a VARIDCELL/VAROPCELL ? */
1913 Cell c; {                               /* also recognises DICTVAR cells   */
1914     return isPair(c) &&
1915                (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
1916 }
1917
1918 Bool isCon(c)                          /* is cell a CONIDCELL/CONOPCELL ?  */
1919 Cell c; {
1920     return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
1921 }
1922
1923 Bool isQVar(c)                        /* is cell a [un]qualified varop/id? */
1924 Cell c; {
1925     if (!isPair(c)) return FALSE;
1926     switch (fst(c)) {
1927         case VARIDCELL  :
1928         case VAROPCELL  : return TRUE;
1929
1930         case QUALIDENT  : return isVar(snd(snd(c)));
1931
1932         default         : return FALSE;
1933     }
1934 }
1935
1936 Bool isQCon(c)                         /*is cell a [un]qualified conop/id? */
1937 Cell c; {
1938     if (!isPair(c)) return FALSE;
1939     switch (fst(c)) {
1940         case CONIDCELL  :
1941         case CONOPCELL  : return TRUE;
1942
1943         case QUALIDENT  : return isCon(snd(snd(c)));
1944
1945         default         : return FALSE;
1946     }
1947 }
1948
1949 Bool isQualIdent(c)                    /* is cell a qualified identifier?  */
1950 Cell c; {
1951     return isPair(c) && (fst(c)==QUALIDENT);
1952 }
1953
1954 Bool isIdent(c)                        /* is cell an identifier?           */
1955 Cell c; {
1956     if (!isPair(c)) return FALSE;
1957     switch (fst(c)) {
1958         case VARIDCELL  :
1959         case VAROPCELL  :
1960         case CONIDCELL  :
1961         case CONOPCELL  : return TRUE;
1962
1963         case QUALIDENT  : return TRUE;
1964
1965         default         : return FALSE;
1966     }
1967 }
1968
1969 Bool isInt(c)                          /* cell holds integer value?        */
1970 Cell c; {
1971     return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
1972 }
1973
1974 Int intOf(c)                           /* find integer value of cell?      */
1975 Cell c; {
1976     assert(isInt(c));
1977     return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
1978 }
1979
1980 Cell mkInt(n)                          /* make cell representing integer   */
1981 Int n; {
1982     return (MINSMALLINT <= n && n <= MAXSMALLINT)
1983            ? INTZERO+n
1984            : pair(INTCELL,n);
1985 }
1986
1987 #if BIGNUMS
1988 Bool isBignum(c)                       /* cell holds bignum value?         */
1989 Cell c; {
1990     return c==ZERONUM || (isPair(c) && (fst(c)==POSNUM || fst(c)==NEGNUM));
1991 }
1992 #endif
1993
1994 #if SIZEOF_INTP == SIZEOF_INT
1995 typedef union {Int i; Ptr p;} IntOrPtr;
1996 Cell mkPtr(p)
1997 Ptr p;
1998 {
1999     IntOrPtr x;
2000     x.p = p;
2001     return pair(PTRCELL,x.i);
2002 }
2003
2004 Ptr ptrOf(c)
2005 Cell c;
2006 {
2007     IntOrPtr x;
2008     assert(fst(c) == PTRCELL);
2009     x.i = snd(c);
2010     return x.p;
2011 }
2012 #elif SIZEOF_INTP == 2*SIZEOF_INT
2013 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2014 Cell mkPtr(p)
2015 Ptr p;
2016 {
2017     IntOrPtr x;
2018     x.p = p;
2019     return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2020 }
2021
2022 Ptr ptrOf(c)
2023 Cell c;
2024 {
2025     IntOrPtr x;
2026     assert(fst(c) == PTRCELL);
2027     x.i.i1 = intOf(fst(snd(c)));
2028     x.i.i2 = intOf(snd(snd(c)));
2029     return x.p;
2030 }
2031 #else
2032 #warning "type Addr not supported on this architecture - don't use it"
2033 Cell mkPtr(p)
2034 Ptr p;
2035 {
2036     ERRMSG(0) "mkPtr: type Addr not supported on this architecture"
2037     EEND;
2038 }
2039
2040 Ptr ptrOf(c)
2041 Cell c;
2042 {
2043     ERRMSG(0) "ptrOf: type Addr not supported on this architecture"
2044     EEND;
2045 }
2046 #endif
2047
2048 String stringNegate( s )
2049 String s;
2050 {
2051     if (s[0] == '-') {
2052         return &s[1];
2053     } else {
2054         static char t[100];
2055         t[0] = '-';
2056         strcpy(&t[1],s);  /* ToDo: use strncpy instead */
2057         return t;
2058     }
2059 }
2060
2061 /* --------------------------------------------------------------------------
2062  * List operations:
2063  * ------------------------------------------------------------------------*/
2064
2065 Int length(xs)                         /* calculate length of list xs      */
2066 List xs; {
2067     Int n = 0;
2068     for (; nonNull(xs); ++n)
2069         xs = tl(xs);
2070     return n;
2071 }
2072
2073 List appendOnto(xs,ys)                 /* Destructively prepend xs onto    */
2074 List xs, ys; {                         /* ys by modifying xs ...           */
2075     if (isNull(xs))
2076         return ys;
2077     else {
2078         List zs = xs;
2079         while (nonNull(tl(zs)))
2080             zs = tl(zs);
2081         tl(zs) = ys;
2082         return xs;
2083     }
2084 }
2085
2086 List dupOnto(xs,ys)      /* non-destructively prepend xs backwards onto ys */
2087 List xs;
2088 List ys; {
2089     for (; nonNull(xs); xs=tl(xs))
2090         ys = cons(hd(xs),ys);
2091     return ys;
2092 }
2093
2094 List dupListOnto(xs,ys)              /* Duplicate spine of list xs onto ys */
2095 List xs;
2096 List ys; {
2097     return revOnto(dupOnto(xs,NIL),ys);
2098 }
2099
2100 List dupList(xs)                       /* Duplicate spine of list xs       */
2101 List xs; {
2102     List ys = NIL;
2103     for (; nonNull(xs); xs=tl(xs))
2104         ys = cons(hd(xs),ys);
2105     return rev(ys);
2106 }
2107
2108 List revOnto(xs,ys)                    /* Destructively reverse elements of*/
2109 List xs, ys; {                         /* list xs onto list ys...          */
2110     Cell zs;
2111
2112     while (nonNull(xs)) {
2113         zs     = tl(xs);
2114         tl(xs) = ys;
2115         ys     = xs;
2116         xs     = zs;
2117     }
2118     return ys;
2119 }
2120
2121 #if 0
2122 List delete(xs,y)                      /* Delete first use of y from xs    */
2123 List xs;
2124 Cell y; {
2125     if (isNull(xs)) {
2126         return xs;
2127     } else if (hs(xs) == y) {
2128         return tl(xs);
2129     } else {
2130         tl(xs) = delete(tl(xs),y);
2131         return xs;
2132     }
2133 }
2134
2135 List minus(xs,ys)                      /* Delete members of ys from xs     */
2136 List xs, ys; {
2137     mapAccum(delete,xs,ys);
2138     return xs;
2139 }
2140 #endif
2141
2142 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
2143 Text t;                                /* given list of variables          */
2144 List xs; {
2145     for (; nonNull(xs); xs=tl(xs))
2146         if (t==textOf(hd(xs)))
2147             return hd(xs);
2148     return NIL;
2149 }
2150
2151 Name nameIsMember(t,ns)                 /* Test if name with text t is a   */
2152 Text t;                                 /* member of list of names xs      */
2153 List ns; {
2154     for (; nonNull(ns); ns=tl(ns))
2155         if (t==name(hd(ns)).text)
2156             return hd(ns);
2157     return NIL;
2158 }
2159
2160 Cell intIsMember(n,xs)                 /* Test if integer n is member of   */
2161 Int  n;                                /* given list of integers           */
2162 List xs; {
2163     for (; nonNull(xs); xs=tl(xs))
2164         if (n==intOf(hd(xs)))
2165             return hd(xs);
2166     return NIL;
2167 }
2168
2169 Cell cellIsMember(x,xs)                /* Test for membership of specific  */
2170 Cell x;                                /* cell x in list xs                */
2171 List xs; {
2172     for (; nonNull(xs); xs=tl(xs))
2173         if (x==hd(xs))
2174             return hd(xs);
2175     return NIL;
2176 }
2177
2178 Cell cellAssoc(c,xs)                   /* Lookup cell in association list  */
2179 Cell c;
2180 List xs; {
2181     for (; nonNull(xs); xs=tl(xs))
2182         if (c==fst(hd(xs)))
2183             return hd(xs);
2184     return NIL;
2185 }
2186
2187 Cell cellRevAssoc(c,xs)                /* Lookup cell in range of          */
2188 Cell c;                                /* association lists                */
2189 List xs; {
2190     for (; nonNull(xs); xs=tl(xs))
2191         if (c==snd(hd(xs)))
2192             return hd(xs);
2193     return NIL;
2194 }
2195
2196 List replicate(n,x)                     /* create list of n copies of x    */
2197 Int n;
2198 Cell x; {
2199     List xs=NIL;
2200     while (0<n--)
2201         xs = cons(x,xs);
2202     return xs;
2203 }
2204
2205 List diffList(from,take)               /* list difference: from\take       */
2206 List from, take; {                     /* result contains all elements of  */
2207     List result = NIL;                 /* `from' not appearing in `take'   */
2208
2209     while (nonNull(from)) {
2210         List next = tl(from);
2211         if (!cellIsMember(hd(from),take)) {
2212             tl(from) = result;
2213             result   = from;
2214         }
2215         from = next;
2216     }
2217     return rev(result);
2218 }
2219
2220 List deleteCell(xs, y)                  /* copy xs deleting pointers to y  */
2221 List xs;
2222 Cell y; {
2223     List result = NIL;
2224     for(;nonNull(xs);xs=tl(xs)) {
2225         Cell x = hd(xs);
2226         if (x != y) {
2227             result=cons(x,result);
2228         }
2229     }
2230     return rev(result);
2231 }
2232
2233 List take(n,xs)                         /* destructively truncate list to  */
2234 Int  n;                                 /* specified length                */
2235 List xs; {
2236     List ys = xs;
2237
2238     if (n==0)
2239         return NIL;
2240     while (1<n-- && nonNull(xs))
2241         xs = tl(xs);
2242     if (nonNull(xs))
2243         tl(xs) = NIL;
2244     return ys;
2245 }
2246
2247 List splitAt(n,xs)                         /* drop n things from front of list*/
2248 Int  n;
2249 List xs; {
2250     for(; n>0; --n) {
2251         xs = tl(xs);
2252     }
2253     return xs;
2254 }
2255
2256 Cell nth(n,xs)                         /* extract n'th element of list    */
2257 Int  n;
2258 List xs; {
2259     for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2260     }
2261     if (isNull(xs))
2262         internal("nth");
2263     return hd(xs);
2264 }
2265
2266 List removeCell(x,xs)                   /* destructively remove cell from  */
2267 Cell x;                                 /* list                            */
2268 List xs; {
2269     if (nonNull(xs)) {
2270         if (hd(xs)==x)
2271             return tl(xs);              /* element at front of list        */
2272         else {
2273             List prev = xs;
2274             List curr = tl(xs);
2275             for (; nonNull(curr); prev=curr, curr=tl(prev))
2276                 if (hd(curr)==x) {
2277                     tl(prev) = tl(curr);
2278                     return xs;          /* element in middle of list       */
2279                 }
2280         }
2281     }
2282     return xs;                          /* here if element not found       */
2283 }
2284
2285 /* --------------------------------------------------------------------------
2286  * Operations on applications:
2287  * ------------------------------------------------------------------------*/
2288
2289 Int argCount;                          /* number of args in application    */
2290
2291 Cell getHead(e)                        /* get head cell of application     */
2292 Cell e; {                              /* set number of args in argCount   */
2293     for (argCount=0; isAp(e); e=fun(e))
2294         argCount++;
2295     return e;
2296 }
2297
2298 List getArgs(e)                        /* get list of arguments in function*/
2299 Cell e; {                              /* application:                     */
2300     List as;                           /* getArgs(f e1 .. en) = [e1,..,en] */
2301
2302     for (as=NIL; isAp(e); e=fun(e))
2303         as = cons(arg(e),as);
2304     return as;
2305 }
2306
2307 Cell nthArg(n,e)                       /* return nth arg in application    */
2308 Int  n;                                /* of function to m args (m>=n)     */
2309 Cell e; {                              /* nthArg n (f x0 x1 ... xm) = xn   */
2310     for (n=numArgs(e)-n-1; n>0; n--)
2311         e = fun(e);
2312     return arg(e);
2313 }
2314
2315 Int numArgs(e)                         /* find number of arguments to expr */
2316 Cell e; {
2317     Int n;
2318     for (n=0; isAp(e); e=fun(e))
2319         n++;
2320     return n;
2321 }
2322
2323 Cell applyToArgs(f,args)               /* destructively apply list of args */
2324 Cell f;                                /* to function f                    */
2325 List args; {
2326     while (nonNull(args)) {
2327         Cell temp = tl(args);
2328         tl(args)  = hd(args);
2329         hd(args)  = f;
2330         f         = args;
2331         args      = temp;
2332     }
2333     return f;
2334 }
2335
2336 /* --------------------------------------------------------------------------
2337  * Handle operations:
2338  * ------------------------------------------------------------------------*/
2339
2340 #if IO_HANDLES
2341 struct strHandle DEFTABLE(handles,NUM_HANDLES);
2342
2343 Cell openHandle(s,hmode,binary)         /* open handle to file named s in  */
2344 String s;                               /* the specified hmode             */
2345 Int    hmode;
2346 Bool   binary; {
2347     Int i;
2348
2349     for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
2350         ;                                       /* Search for unused handle*/
2351     if (i>=NUM_HANDLES) {                       /* If at first we don't    */
2352         garbageCollect();                       /* succeed, garbage collect*/
2353         for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
2354             ;                                   /* and try again ...       */
2355     }
2356     if (i>=NUM_HANDLES) {                       /* ... before we give up   */
2357         ERRMSG(0) "Too many handles open; cannot open \"%s\"", s
2358         EEND;
2359     }
2360     else {                                      /* prepare to open file    */
2361         String stmode;
2362         if (binary) {
2363             stmode = (hmode&HAPPEND) ? "ab+" :
2364                      (hmode&HWRITE)  ? "wb+" :
2365                      (hmode&HREAD)   ? "rb" : (String)0;
2366         } else {
2367             stmode = (hmode&HAPPEND) ? "a+"  :
2368                      (hmode&HWRITE)  ? "w+"  :
2369                      (hmode&HREAD)   ? "r"  : (String)0;
2370         }
2371         if (stmode && (handles[i].hfp=fopen(s,stmode))) {
2372             handles[i].hmode = hmode;
2373             return (handles[i].hcell = ap(HANDCELL,i));
2374         }
2375     }
2376     return NIL;
2377 }
2378
2379 static Void local freeHandle(n)         /* release handle storage when no  */
2380 Int n; {                                /* heap references to it remain    */
2381     if (0<=n && n<NUM_HANDLES && nonNull(handles[n].hcell)) {
2382         if (n>HSTDERR && handles[n].hmode!=HCLOSED && handles[n].hfp) {
2383             fclose(handles[n].hfp);
2384             handles[n].hfp = 0;
2385         }
2386         fst(handles[n].hcell) = snd(handles[n].hcell) = NIL;
2387         handles[n].hcell      = NIL;
2388     }
2389 }
2390 #endif
2391
2392 #if GC_MALLOCPTRS
2393 /* --------------------------------------------------------------------------
2394  * Malloc Ptrs:
2395  * ------------------------------------------------------------------------*/
2396
2397 struct strMallocPtr mallocPtrs[NUM_MALLOCPTRS];
2398
2399 /* It might GC (because it uses a table not a list) which will trash any
2400  * unstable pointers.
2401  * (It happens that we never use it with unstable pointers.)
2402  */
2403 Cell mkMallocPtr(ptr,cleanup)            /* create a new malloc pointer    */
2404 Ptr ptr;
2405 Void (*cleanup) Args((Ptr)); {
2406     Int i;
2407     for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
2408         ;                                       /* Search for unused entry */
2409     if (i>=NUM_MALLOCPTRS) {                    /* If at first we don't    */
2410         garbageCollect();                       /* succeed, garbage collect*/
2411         for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
2412             ;                                   /* and try again ...       */
2413     }
2414     if (i>=NUM_MALLOCPTRS) {                    /* ... before we give up   */
2415         ERRMSG(0) "Too many ForeignObjs open"
2416         EEND;
2417     }
2418     mallocPtrs[i].ptr      = ptr;
2419     mallocPtrs[i].cleanup  = cleanup;
2420     mallocPtrs[i].refCount = 1;
2421     return (mallocPtrs[i].mpcell = ap(MPCELL,i));
2422 }
2423
2424 Void incMallocPtrRefCnt(n,i)             /* change ref count of MallocPtr */
2425 Int n;
2426 Int i; {
2427     if (!(0<=n && n<NUM_MALLOCPTRS && mallocPtrs[n].refCount > 0))
2428         internal("freeMallocPtr");
2429     mallocPtrs[n].refCount += i;
2430     if (mallocPtrs[n].refCount <= 0) {
2431         mallocPtrs[n].cleanup(mallocPtrs[n].ptr);
2432
2433         mallocPtrs[n].ptr      = 0;
2434         mallocPtrs[n].cleanup  = 0;
2435         mallocPtrs[n].refCount = 0;
2436         mallocPtrs[n].mpcell   = NIL;
2437     }
2438 }
2439 #endif /* GC_MALLOCPTRS */
2440
2441 /* --------------------------------------------------------------------------
2442  * Stable pointers
2443  * This is a mechanism that allows the C world to manipulate pointers into the
2444  * Haskell heap without having to worry that the garbage collector is going
2445  * to delete it or move it around.
2446  * The implementation and interface is based on my implementation in
2447  * GHC - but, at least for now, is simplified by using a fixed size
2448  * table of stable pointers.
2449  * ------------------------------------------------------------------------*/
2450
2451 #if GC_STABLEPTRS
2452
2453 /* Each entry in the stable pointer table is either a heap pointer
2454  * or is not currently allocated.
2455  * Unallocated entries are threaded together into a freelist.
2456  * The last entry in the list contains the Cell 0; all other values
2457  * contain a Cell whose value is the next free stable ptr in the list.
2458  * It follows that stable pointers are strictly positive (>0).
2459  */
2460 static Cell stablePtrTable[NUM_STABLEPTRS];
2461 static Int  sptFreeList;
2462 #define SPT(sp) stablePtrTable[(sp)-1]
2463
2464 static Void local resetStablePtrs() {
2465     Int i;
2466     /* It would be easier to build the free list in the other direction
2467      * but, when debugging, it's way easier to understand if the first
2468      * pointer allocated is "1".
2469      */
2470     for(i=1; i < NUM_STABLEPTRS; ++i)
2471         SPT(i) = i+1;
2472     SPT(NUM_STABLEPTRS) = 0;
2473     sptFreeList = 1;
2474 }
2475
2476 Int mkStablePtr(c)                  /* Create a stable pointer            */
2477 Cell c; {
2478     Int i = sptFreeList;
2479     if (i == 0)
2480         return 0;
2481     sptFreeList = SPT(i);
2482     SPT(i) = c;
2483     return i;
2484 }
2485
2486 Cell derefStablePtr(p)              /* Dereference a stable pointer       */
2487 Int p; {
2488     if (!(1 <= p && p <= NUM_STABLEPTRS)) {
2489         internal("derefStablePtr");
2490     }
2491     return SPT(p);
2492 }
2493
2494 Void freeStablePtr(i)               /* Free a stable pointer             */
2495 Int i; {
2496     SPT(i) = sptFreeList;
2497     sptFreeList = i;
2498 }
2499
2500 #undef SPT
2501 #endif /* GC_STABLEPTRS */
2502
2503 /* --------------------------------------------------------------------------
2504  * plugin support
2505  * ------------------------------------------------------------------------*/
2506
2507 /*---------------------------------------------------------------------------
2508  * GreenCard entry points
2509  *
2510  * GreenCard generated code accesses Hugs data structures and functions
2511  * (only) via these functions (which are stored in the virtual function
2512  * table hugsAPI1.
2513  *-------------------------------------------------------------------------*/
2514
2515 #if GREENCARD
2516
2517 static Cell  makeTuple      Args((Int));
2518 static Cell  makeInt        Args((Int));
2519 static Cell  makeChar       Args((Char));
2520 static Char  CharOf         Args((Cell));
2521 static Cell  makeFloat      Args((FloatPro));
2522 static Void* derefMallocPtr Args((Cell));
2523 static Cell* Fst            Args((Cell));
2524 static Cell* Snd            Args((Cell));
2525
2526 static Cell  makeTuple(n)      Int      n; { return mkTuple(n); }
2527 static Cell  makeInt(n)        Int      n; { return mkInt(n); }
2528 static Cell  makeChar(n)       Char     n; { return mkChar(n); }
2529 static Char  CharOf(n)         Cell     n; { return charOf(n); }
2530 static Cell  makeFloat(n)      FloatPro n; { return mkFloat(n); }
2531 static Void* derefMallocPtr(n) Cell     n; { return derefMP(n); }
2532 static Cell* Fst(n)            Cell     n; { return (Cell*)&fst(n); }
2533 static Cell* Snd(n)            Cell     n; { return (Cell*)&snd(n); }
2534
2535 HugsAPI1* hugsAPI1() {
2536     static HugsAPI1 api;
2537     static Bool initialised = FALSE;
2538     if (!initialised) {
2539         api.nameTrue        = nameTrue;
2540         api.nameFalse       = nameFalse;
2541         api.nameNil         = nameNil;
2542         api.nameCons        = nameCons;
2543         api.nameJust        = nameJust;
2544         api.nameNothing     = nameNothing;
2545         api.nameLeft        = nameLeft;
2546         api.nameRight       = nameRight;
2547         api.nameUnit        = nameUnit;
2548         api.nameIORun       = nameIORun;
2549         api.makeInt         = makeInt;
2550         api.makeChar        = makeChar;
2551         api.CharOf          = CharOf;
2552         api.makeFloat       = makeFloat;
2553         api.makeTuple       = makeTuple;
2554         api.pair            = pair;
2555         api.mkMallocPtr     = mkMallocPtr;
2556         api.derefMallocPtr  = derefMallocPtr;
2557         api.mkStablePtr     = mkStablePtr;
2558         api.derefStablePtr  = derefStablePtr;
2559         api.freeStablePtr   = freeStablePtr;
2560         api.eval            = eval;
2561         api.evalWithNoError = evalWithNoError;
2562         api.evalFails       = evalFails;
2563         api.whnfArgs        = &whnfArgs;
2564         api.whnfHead        = &whnfHead;
2565         api.whnfInt         = &whnfInt;
2566         api.whnfFloat       = &whnfFloat;
2567         api.garbageCollect  = garbageCollect;
2568         api.stackOverflow   = hugsStackOverflow;
2569         api.internal        = internal;
2570         api.registerPrims   = registerPrims;
2571         api.addPrimCfun     = addPrimCfun;
2572         api.inventText      = inventText;
2573         api.Fst             = Fst;
2574         api.Snd             = Snd;
2575         api.cellStack       = cellStack;
2576         api.sp              = &sp;
2577     }
2578     return &api;
2579 }
2580
2581 #endif /* GREENCARD */
2582
2583
2584 /* --------------------------------------------------------------------------
2585  * storage control:
2586  * ------------------------------------------------------------------------*/
2587
2588 #if DYN_TABLES
2589 static void far* safeFarCalloc Args((Int,Int));
2590 static void far* safeFarCalloc(n,s)     /* allocate table storage and check*/
2591 Int n, s; {                             /* for non-null return             */
2592     void far* tab = farCalloc(n,s);
2593     if (tab==0) {
2594         ERRMSG(0) "Cannot allocate run-time tables"
2595         EEND;
2596     }
2597     return tab;
2598 }
2599 #define TABALLOC(v,t,n)                 v=(t far*)safeFarCalloc(n,sizeof(t));
2600 #else
2601 #define TABALLOC(v,t,n)
2602 #endif
2603
2604 Void storage(what)
2605 Int what; {
2606     Int i;
2607
2608     switch (what) {
2609         case RESET   : clearStack();
2610
2611                        /* the next 2 statements are particularly important
2612                         * if you are using GLOBALfst or GLOBALsnd since the
2613                         * corresponding registers may be reset to their
2614                         * uninitialised initial values by a longjump.
2615                         */
2616                        heapTopFst = heapFst + heapSize;
2617                        heapTopSnd = heapSnd + heapSize;
2618 #if PROFILING
2619                        heapTopThd = heapThd + heapSize;
2620                        if (profile) {
2621                            garbageCollect();
2622                            fclose(profile);
2623 #if HAVE_HP2PS
2624                            system("hp2ps profile.hp");
2625 #endif
2626                            profile = 0;
2627                        }
2628 #endif
2629 #if IO_HANDLES
2630                        handles[HSTDIN].hmode  = HREAD;
2631                        handles[HSTDOUT].hmode = HAPPEND;
2632                        handles[HSTDERR].hmode = HAPPEND;
2633 #endif
2634 #if GC_MALLOCPTRS
2635                        for (i=0; i<NUM_MALLOCPTRS; i++)
2636                            mallocPtrs[i].mpcell = NIL;
2637 #endif
2638 #if !HSCRIPT
2639 #if GC_STABLEPTRS
2640                        resetStablePtrs();
2641 #endif
2642 #endif
2643                        consGC = TRUE;
2644                        lsave  = NIL;
2645                        rsave  = NIL;
2646                        if (isNull(lastExprSaved))
2647                            savedText = NUM_TEXT;
2648                        break;
2649
2650         case MARK    :
2651                        start();
2652                        for (i=NAMEMIN; i<nameHw; ++i) {
2653                            mark(name(i).parent);
2654                            mark(name(i).defn);
2655                            mark(name(i).stgVar);
2656                            mark(name(i).type);
2657                        }
2658                        end("Names", nameHw-NAMEMIN);
2659
2660 #if !IGNORE_MODULES
2661                        start();
2662                        for (i=MODMIN; i<moduleHw; ++i) {
2663                            mark(module(i).tycons);
2664                            mark(module(i).names);
2665                            mark(module(i).classes);
2666                            mark(module(i).exports);
2667                            mark(module(i).qualImports);
2668                        }
2669                        end("Modules", moduleHw-MODMIN);
2670 #endif
2671
2672                        start();
2673                        for (i=TYCMIN; i<tyconHw; ++i) {
2674                            mark(tycon(i).defn);
2675                            mark(tycon(i).kind);
2676                            mark(tycon(i).what);
2677                        }
2678                        end("Type constructors", tyconHw-TYCMIN);
2679
2680                        start();
2681                        for (i=CLASSMIN; i<classHw; ++i) {
2682                            mark(cclass(i).head);
2683                            mark(cclass(i).kinds);
2684                            mark(cclass(i).dsels);
2685                            mark(cclass(i).supers);
2686                            mark(cclass(i).members);
2687                            mark(cclass(i).defaults);
2688                            mark(cclass(i).instances);
2689                        }
2690                        mark(classes);
2691                        end("Classes", classHw-CLASSMIN);
2692
2693                        start();
2694                        for (i=INSTMIN; i<instHw; ++i) {
2695                            mark(inst(i).head);
2696                            mark(inst(i).kinds);
2697                            mark(inst(i).specifics);
2698                            mark(inst(i).implements);
2699                        }
2700                        end("Instances", instHw-INSTMIN);
2701
2702                        start();
2703                        for (i=0; i<=sp; ++i)
2704                            mark(stack(i));
2705                        end("Stack", sp+1);
2706
2707                        start();
2708                        mark(lastExprSaved);
2709                        mark(lsave);
2710                        mark(rsave);
2711                        end("Last expression", 3);
2712 #if IO_HANDLES
2713                        start();
2714                        mark(handles[HSTDIN].hcell);
2715                        mark(handles[HSTDOUT].hcell);
2716                        mark(handles[HSTDERR].hcell);
2717                        end("Standard handles", 3);
2718 #endif
2719
2720 #if GC_STABLEPTRS
2721                        start();
2722                        for (i=0; i<NUM_STABLEPTRS; ++i)
2723                            mark(stablePtrTable[i]);
2724                        end("Stable pointers", NUM_STABLEPTRS);
2725 #endif
2726
2727 #if GC_WEAKPTRS
2728                        mark(finalizers);
2729 #endif
2730
2731                        if (consGC) {
2732                            start();
2733                            gcCStack();
2734                            end("C stack", stackRoots);
2735                        }
2736
2737                        break;
2738
2739         case INSTALL : heapFst = heapAlloc(heapSize);
2740                        heapSnd = heapAlloc(heapSize);
2741
2742                        if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
2743                            ERRMSG(0) "Cannot allocate heap storage (%d cells)",
2744                                      heapSize
2745                            EEND;
2746                        }
2747
2748                        heapTopFst = heapFst + heapSize;
2749                        heapTopSnd = heapSnd + heapSize;
2750 #if PROFILING
2751                        heapThd = heapAlloc(heapSize);
2752                        if (heapThd==(Heap)0) {
2753                            ERRMSG(0) "Cannot allocate profiler storage space"
2754                            EEND;
2755                        }
2756                        heapTopThd   = heapThd + heapSize;
2757                        profile      = 0;
2758                        if (0 == profInterval)
2759                            profInterval = heapSize / DEF_PROFINTDIV;
2760 #endif
2761                        for (i=1; i<heapSize; ++i) {
2762                            fst(-i) = FREECELL;
2763                            snd(-i) = -(i+1);
2764                        }
2765                        snd(-heapSize) = NIL;
2766                        freeList  = -1;
2767                        numGcs    = 0;
2768                        consGC    = TRUE;
2769                        lsave     = NIL;
2770                        rsave     = NIL;
2771
2772                        marksSize  = bitArraySize(heapSize);
2773                        if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
2774                            ERRMSG(0) "Unable to allocate gc markspace"
2775                            EEND;
2776                        }
2777
2778                        TABALLOC(text,      char,             NUM_TEXT)
2779                        TABALLOC(tyconHash, Tycon,            TYCONHSZ)
2780                        TABALLOC(tabTycon,  struct strTycon,  NUM_TYCON)
2781                        TABALLOC(nameHash,  Name,             NAMEHSZ)
2782                        TABALLOC(tabName,   struct strName,   NUM_NAME)
2783                        TABALLOC(tabClass,  struct strClass,  NUM_CLASSES)
2784                        TABALLOC(cellStack, Cell,             NUM_STACK)
2785                        TABALLOC(tabModule, struct Module,    NUM_SCRIPTS)
2786 #if TREX
2787                        TABALLOC(tabExt,    Text,             NUM_EXT)
2788 #endif
2789                        clearStack();
2790
2791 #if IO_HANDLES
2792                        TABALLOC(handles,   struct strHandle, NUM_HANDLES)
2793                        for (i=0; i<NUM_HANDLES; i++)
2794                            handles[i].hcell = NIL;
2795                        handles[HSTDIN].hcell  = ap(HANDCELL,HSTDIN);
2796                        handles[HSTDIN].hfp    = stdin;
2797                        handles[HSTDOUT].hcell = ap(HANDCELL,HSTDOUT);
2798                        handles[HSTDOUT].hfp   = stdout;
2799                        handles[HSTDERR].hcell = ap(HANDCELL,HSTDERR);
2800                        handles[HSTDERR].hfp   = stderr;
2801 #endif
2802
2803                        textHw        = 0;
2804                        nextNewText   = NUM_TEXT;
2805                        nextNewDText  = (-1);
2806                        lastExprSaved = NIL;
2807                        savedText     = NUM_TEXT;
2808                        for (i=0; i<TEXTHSZ; ++i)
2809                            textHash[i][0] = NOTEXT;
2810
2811
2812 #if !IGNORE_MODULES
2813                        moduleHw = MODMIN;
2814 #endif
2815
2816                        tyconHw  = TYCMIN;
2817                        for (i=0; i<TYCONHSZ; ++i)
2818                            tyconHash[i] = NIL;
2819
2820 #if GC_WEAKPTRS
2821                        finalizers   = NIL;
2822                        liveWeakPtrs = NIL;
2823 #endif
2824
2825 #if GC_STABLEPTRS
2826                        resetStablePtrs();
2827 #endif
2828
2829 #if TREX
2830                        extHw    = EXTMIN;
2831 #endif
2832
2833                        nameHw   = NAMEMIN;
2834                        for (i=0; i<NAMEHSZ; ++i)
2835                            nameHash[i] = NIL;
2836
2837                        classHw  = CLASSMIN;
2838
2839                        instHw   = INSTMIN;
2840
2841 #if USE_DICTHW
2842                        dictHw   = 0;
2843 #endif
2844
2845                        tabInst  = (struct strInst far *)
2846                                     farCalloc(NUM_INSTS,sizeof(struct strInst));
2847
2848                        if (tabInst==0) {
2849                            ERRMSG(0) "Cannot allocate instance tables"
2850                            EEND;
2851                        }
2852
2853                        scriptHw = 0;
2854
2855                        break;
2856     }
2857 }
2858
2859 /*-------------------------------------------------------------------------*/