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