2 /* --------------------------------------------------------------------------
3 * Primitives for manipulating global data structures
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.
10 * $RCSfile: storage.c,v $
12 * $Date: 1999/02/03 17:08:40 $
13 * ------------------------------------------------------------------------*/
22 /*#define DEBUG_SHOWUSE*/
24 /* --------------------------------------------------------------------------
25 * local function prototypes:
26 * ------------------------------------------------------------------------*/
28 static Int local hash Args((String));
29 static Int local saveText Args((Text));
31 static Module local findQualifier Args((Text));
33 static Void local hashTycon Args((Tycon));
34 static List local insertTycon Args((Tycon,List));
35 static Void local hashName Args((Name));
36 static List local insertName Args((Name,List));
37 static Void local patternError Args((String));
38 static Bool local stringMatch Args((String,String));
39 static Bool local typeInvolves Args((Type,Type));
40 static Cell local markCell Args((Cell));
41 static Void local markSnd Args((Cell));
42 static Cell local indirectChain Args((Cell));
43 static Bool local isMarked Args((Cell));
44 static Cell local lowLevelLastIn Args((Cell));
45 static Cell local lowLevelLastOut Args((Cell));
47 Module local moduleOfScript Args((Script));
48 Script local scriptThisFile Args((Text));
51 static Void local freeHandle Args((Int));
54 static Void local resetStablePtrs Args((Void));
58 /* --------------------------------------------------------------------------
61 * provides storage for the characters making up identifier and symbol
62 * names, string literals, character constants etc...
64 * All character strings are stored in a large character array, with textHw
65 * pointing to the next free position. Lookup in the array is improved using
66 * a hash table. Internally, text strings are represented by integer offsets
67 * from the beginning of the array to the string in question.
69 * Where memory permits, the use of multiple hashtables gives a significant
70 * increase in performance, particularly when large source files are used.
72 * Each string in the array is terminated by a zero byte. No string is
73 * stored more than once, so that it is safe to test equality of strings by
74 * comparing the corresponding offsets.
76 * Special text values (beyond the range of the text array table) are used
77 * to generate unique `new variable names' as required.
79 * The same text storage is also used to hold text values stored in a saved
80 * expression. This grows downwards from the top of the text table (and is
81 * not included in the hash table).
82 * ------------------------------------------------------------------------*/
84 #define TEXTHSZ 512 /* Size of Text hash table */
85 #define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */
86 static Text textHw; /* Next unused position */
87 static Text savedText = NUM_TEXT; /* Start of saved portion of text */
88 static Text nextNewText; /* Next new text value */
89 static Text nextNewDText; /* Next new dict text value */
90 static char DEFTABLE(text,NUM_TEXT);/* Storage of character strings */
91 static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */
93 String textToStr(t) /* find string corresp to given Text*/
95 static char newVar[16];
97 if (0<=t && t<NUM_TEXT) /* standard char string */
100 sprintf(newVar,"d%d",-t); /* dictionary variable */
102 sprintf(newVar,"v%d",t-NUM_TEXT); /* normal variable */
106 String identToStr(v) /*find string corresp to given ident or qualified name*/
109 internal("identToStr");
115 case CONOPCELL : return text+textOf(v);
117 case QUALIDENT : { Text pos = textHw;
119 while (pos+1 < savedText && text[t]!=0) {
120 text[pos++] = text[t++];
122 if (pos+1 < savedText) {
126 while (pos+1 < savedText && text[t]!=0) {
127 text[pos++] = text[t++];
133 internal("identToStr2");
134 assert(0); return 0; /* NOTREACHED */
137 Text inventText() { /* return new unused variable name */
138 return nextNewText++;
141 Text inventDictText() { /* return new unused dictvar name */
142 return nextNewDText--;
145 Bool inventedText(t) /* Signal TRUE if text has been */
146 Text t; { /* generated internally */
147 return (t<0 || t>=NUM_TEXT);
150 static Int local hash(s) /* Simple hash function on strings */
154 for (v=((int)(*s))*8; *s; s++)
155 v += ((int)(*s))*(j++);
161 Text findText(s) /* Locate string in Text array */
165 Text textPos = textHash[h][hashno];
167 #define TryMatch { Text originalTextPos = textPos; \
169 for (t=s; *t==text[textPos]; textPos++,t++) \
171 return originalTextPos; \
173 #define Skip while (text[textPos++]) ;
175 while (textPos!=NOTEXT) {
177 if (++hashno<NUM_TEXTH) /* look in next hashtable entry */
178 textPos = textHash[h][hashno];
181 while (textPos < textHw) {
192 textPos = textHw; /* if not found, save in array */
193 if (textHw + (Int)strlen(s) + 1 > savedText) {
194 ERRMSG(0) "Character string storage space exhausted"
197 while ((text[textHw++] = *s++) != 0) {
199 if (hashno<NUM_TEXTH) { /* updating hash table as necessary */
200 textHash[h][hashno] = textPos;
201 if (hashno<NUM_TEXTH-1)
202 textHash[h][hashno+1] = NOTEXT;
208 static Int local saveText(t) /* Save text value in buffer */
209 Text t; { /* at top of text table */
210 String s = textToStr(t);
213 if (textHw + l + 1 > savedText) {
214 ERRMSG(0) "Character string storage space exhausted"
218 strcpy(text+savedText,s);
223 /* --------------------------------------------------------------------------
226 * Currently, the only attributes that we store for each Ext value is the
227 * corresponding Text label. At some later stage, we may decide to cache
228 * types, predicates, etc. here as a space saving gesture. Given that Text
229 * comparison is cheap, and that this is an experimental implementation, we
230 * will use a straightforward linear search to locate Ext values from their
231 * corresponding Text labels; a hashing scheme can be introduced later if
232 * this turns out to be a problem.
233 * ------------------------------------------------------------------------*/
236 Text DEFTABLE(tabExt,NUM_EXT); /* Storage for Ext names */
239 Ext mkExt(t) /* Allocate or find an Ext value */
245 if (extHw-EXTMIN >= NUM_EXT) {
246 ERRMSG(0) "Ext storage space exhausted"
254 /* --------------------------------------------------------------------------
257 * A Tycon represents a user defined type constructor. Tycons are indexed
258 * by Text values ... a very simple hash function is used to improve lookup
259 * times. Tycon entries with the same hash code are chained together, with
260 * the most recent entry at the front of the list.
261 * ------------------------------------------------------------------------*/
263 #define TYCONHSZ 256 /* Size of Tycon hash table*/
264 #define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */
265 static Tycon tyconHw; /* next unused Tycon */
266 static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */
267 struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */
269 Tycon newTycon(t) /* add new tycon to tycon table */
273 if (tyconHw-TYCMIN >= NUM_TYCON) {
274 ERRMSG(0) "Type constructor storage space exhausted"
277 tycon(tyconHw).text = t; /* clear new tycon record */
278 tycon(tyconHw).kind = NIL;
279 tycon(tyconHw).defn = NIL;
280 tycon(tyconHw).what = NIL;
282 tycon(tyconHw).mod = currentModule;
283 module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
285 tycon(tyconHw).nextTyconHash = tyconHash[h];
286 tyconHash[h] = tyconHw;
291 Tycon findTycon(t) /* locate Tycon in tycon table */
293 Tycon tc = tyconHash[tHash(t)];
295 while (nonNull(tc) && tycon(tc).text!=t)
296 tc = tycon(tc).nextTyconHash;
300 Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
302 Tycon oldtc = findTycon(tycon(tc).text);
306 module(currentModule).tycons=cons(tc,module(currentModule).tycons);
313 static Void local hashTycon(tc) /* Insert Tycon into hash table */
315 Text t = tycon(tc).text;
317 tycon(tc).nextTyconHash = tyconHash[h];
321 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
323 if (!isPair(id)) internal("findQualTycon");
327 return findTycon(textOf(id));
330 return findTycon(qtextOf(id));
331 #else /* !IGNORE_MODULES */
332 Text t = qtextOf(id);
333 Module m = findQualifier(qmodOf(id));
335 if (isNull(m)) return NIL;
336 for(es=module(m).exports; nonNull(es); es=tl(es)) {
338 if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
342 #endif /* !IGNORE_MODULES */
344 default : internal("findQualTycon2");
346 assert(0); return 0; /* NOTREACHED */
349 Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
355 Tycon tc = newTycon(t);
357 tycon(tc).kind = kind;
358 tycon(tc).what = what;
359 tycon(tc).defn = defn;
360 tycon(tc).arity = ar;
364 static List local insertTycon(tc,ts) /* insert tycon tc into sorted list*/
369 String s = textToStr(tycon(tc).text);
371 while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
372 if (hd(curr)==tc) /* just in case we get duplicates! */
378 tl(prev) = cons(tc,curr);
382 return cons(tc,curr);
385 List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */
386 String pat; /* to list of Tycons ts */
387 List ts; { /* Null pattern matches every tycon*/
388 Tycon tc; /* (Tycons with NIL kind excluded) */
389 for (tc=TYCMIN; tc<tyconHw; ++tc)
390 if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
391 if (nonNull(tycon(tc).kind))
392 ts = insertTycon(tc,ts);
396 /* --------------------------------------------------------------------------
399 * A Name represents a top level binding of a value to an identifier.
400 * Such values may be a constructor function, a member function in a
401 * class, a user-defined or primitive value/function.
403 * Names are indexed by Text values ... a very simple hash functions speeds
404 * access to the table of Names and Name entries with the same hash value
405 * are chained together, with the most recent entry at the front of the
407 * ------------------------------------------------------------------------*/
409 #define NAMEHSZ 256 /* Size of Name hash table */
410 #define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */
411 static Name nameHw; /* next unused name */
412 static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */
413 struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */
415 Name newName(t,parent) /* Add new name to name table */
420 if (nameHw-NAMEMIN >= NUM_NAME) {
421 ERRMSG(0) "Name storage space exhausted"
424 name(nameHw).text = t; /* clear new name record */
425 name(nameHw).line = 0;
426 name(nameHw).syntax = NO_SYNTAX;
427 name(nameHw).parent = parent;
428 name(nameHw).arity = 0;
429 name(nameHw).number = EXECNAME;
430 name(nameHw).defn = NIL;
431 name(nameHw).stgVar = NIL;
432 name(nameHw).type = NIL;
433 name(nameHw).primop = 0;
434 name(nameHw).mod = currentModule;
436 module(currentModule).names=cons(nameHw,module(currentModule).names);
437 name(nameHw).nextNameHash = nameHash[h];
438 nameHash[h] = nameHw;
442 Name findName(t) /* Locate name in name table */
444 Name n = nameHash[nHash(t)];
446 while (nonNull(n) && name(n).text!=t) {
447 n = name(n).nextNameHash;
449 assert(isNull(n) || (isName(n) && n < nameHw));
453 Name addName(nm) /* Insert Name in name table - if */
454 Name nm; { /* no clash is caused */
455 Name oldnm = findName(name(nm).text);
459 module(currentModule).names=cons(nm,module(currentModule).names);
466 static Void local hashName(nm) /* Insert Name into hash table */
468 Text t = name(nm).text;
470 name(nm).nextNameHash = nameHash[h];
474 Name findQualName(id) /* Locate (possibly qualified) name*/
475 Cell id; { /* in name table */
477 internal("findQualName");
483 return findName(textOf(id));
486 return findName(qtextOf(id));
487 #else /* !IGNORE_MODULES */
488 Text t = qtextOf(id);
489 Module m = findQualifier(qmodOf(id));
491 if (isNull(m)) return NIL;
492 if (m==currentModule) {
493 /* The Haskell report (rightly) forbids this.
494 * We added it to let the Prelude refer to itself
495 * without having to import itself.
499 for(es=module(m).exports; nonNull(es); es=tl(es)) {
501 if (isName(e) && name(e).text==t)
503 else if (isPair(e) && DOTDOT==snd(e)) {
504 List subentities = NIL;
507 && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
508 subentities = tycon(c).defn;
510 subentities = cclass(c).members;
511 for(; nonNull(subentities); subentities=tl(subentities)) {
512 assert(isName(hd(subentities)));
513 if (name(hd(subentities)).text == t)
514 return hd(subentities);
519 #endif /* !IGNORE_MODULES */
521 default : internal("findQualName2");
523 assert(0); return 0; /* NOTREACHED */
526 /* --------------------------------------------------------------------------
527 * Primitive functions:
528 * ------------------------------------------------------------------------*/
530 Name addPrimCfun(t,arity,no,rep) /* add primitive constructor func */
534 Int rep; { /* Really AsmRep */
535 Name n = newName(t,NIL);
536 name(n).arity = arity;
537 name(n).number = cfunNo(no);
539 name(n).primop = (void*)rep;
543 Int sfunPos(s,c) /* Find position of field with */
544 Name s; /* selector s in constructor c. */
548 for (; nonNull(cns); cns=tl(cns))
550 return intOf(snd(hd(cns)));
552 return 0;/* NOTREACHED */
555 static List local insertName(nm,ns) /* insert name nm into sorted list */
560 String s = textToStr(name(nm).text);
562 while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
563 if (hd(curr)==nm) /* just in case we get duplicates! */
569 tl(prev) = cons(nm,curr);
573 return cons(nm,curr);
576 List addNamesMatching(pat,ns) /* Add names matching pattern pat */
577 String pat; /* to list of names ns */
578 List ns; { /* Null pattern matches every name */
579 Name nm; /* (Names with NIL type, or hidden */
581 for (nm=NAMEMIN; nm<nameHw; ++nm) /* or invented names are excluded) */
582 if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
583 String str = textToStr(name(nm).text);
584 if (str[0]!='_' && (!pat || stringMatch(pat,str)))
585 ns = insertName(nm,ns);
589 List mns = module(currentModule).names;
590 for(; nonNull(mns); mns=tl(mns)) {
592 if (!inventedText(name(nm).text)) {
593 String str = textToStr(name(nm).text);
594 if (str[0]!='_' && (!pat || stringMatch(pat,str)))
595 ns = insertName(nm,ns);
602 /* --------------------------------------------------------------------------
603 * A simple string matching routine
604 * `*' matches any sequence of zero or more characters
605 * `?' matches any single character exactly
606 * `@str' matches the string str exactly (ignoring any special chars)
607 * `\c' matches the character c only (ignoring special chars)
608 * c matches the character c only
609 * ------------------------------------------------------------------------*/
611 static Void local patternError(s) /* report error in pattern */
613 ERRMSG(0) "%s in pattern", s
617 static Bool local stringMatch(pat,str) /* match string against pattern */
623 case '\0' : return (*str=='\0');
626 if (stringMatch(pat+1,str))
631 case '?' : if (*str++=='\0')
636 case '[' : { Bool found = FALSE;
637 while (*++pat!='\0' && *pat!=']')
638 if (!found && ( pat[0] == *str ||
647 patternError("missing `]'");
655 case '\\' : if (*++pat == '\0')
656 patternError("extra trailing `\\'");
658 default : if (*pat++ != *str++)
664 /* --------------------------------------------------------------------------
665 * Storage of type classes, instances etc...:
666 * ------------------------------------------------------------------------*/
668 static Class classHw; /* next unused class */
669 static List classes; /* list of classes in current scope */
670 static Inst instHw; /* next unused instance record */
672 struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records */
673 struct strInst far *tabInst; /* (pointer to) table of instances */
675 Class newClass(t) /* add new class to class table */
677 if (classHw-CLASSMIN >= NUM_CLASSES) {
678 ERRMSG(0) "Class storage space exhausted"
681 cclass(classHw).text = t;
682 cclass(classHw).arity = 0;
683 cclass(classHw).kinds = NIL;
684 cclass(classHw).head = NIL;
685 cclass(classHw).dcon = NIL;
686 cclass(classHw).supers = NIL;
687 cclass(classHw).dsels = NIL;
688 cclass(classHw).members = NIL;
689 cclass(classHw).dbuild = NIL;
690 cclass(classHw).defaults = NIL;
691 cclass(classHw).instances = NIL;
692 classes=cons(classHw,classes);
694 cclass(classHw).mod = currentModule;
695 module(currentModule).classes=cons(classHw,module(currentModule).classes);
700 Class classMax() { /* Return max Class in use ... */
701 return classHw; /* This is a bit ugly, but it's not*/
702 } /* worth a lot of effort right now */
704 Class findClass(t) /* look for named class in table */
708 for (cs=classes; nonNull(cs); cs=tl(cs)) {
710 if (cclass(cl).text==t)
716 Class addClass(c) /* Insert Class in class list */
717 Class c; { /* - if no clash caused */
718 Class oldc = findClass(cclass(c).text);
720 classes=cons(c,classes);
722 module(currentModule).classes=cons(c,module(currentModule).classes);
730 Class findQualClass(c) /* Look for (possibly qualified) */
731 Cell c; { /* class in class list */
732 if (!isQualIdent(c)) {
733 return findClass(textOf(c));
736 return findClass(qtextOf(c));
737 #else /* !IGNORE_MODULES */
739 Module m = findQualifier(qmodOf(c));
743 for (es=module(m).exports; nonNull(es); es=tl(es)) {
745 if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
753 Inst newInst() { /* Add new instance to table */
754 if (instHw-INSTMIN >= NUM_INSTS) {
755 ERRMSG(0) "Instance storage space exhausted"
758 inst(instHw).kinds = NIL;
759 inst(instHw).head = NIL;
760 inst(instHw).specifics = NIL;
761 inst(instHw).implements = NIL;
762 inst(instHw).builder = NIL;
763 /* from STG */ inst(instHw).mod = currentModule;
769 extern Void printInst Args((Inst));
773 Class cl = inst(in).c;
774 Printf("%s-", textToStr(cclass(cl).text));
775 printType(stdout,inst(in).t);
777 #endif /* DEBUG_DICTS */
779 Inst findFirstInst(tc) /* look for 1st instance involving */
780 Tycon tc; { /* the type constructor tc */
781 return findNextInst(tc,INSTMIN-1);
784 Inst findNextInst(tc,in) /* look for next instance involving*/
785 Tycon tc; /* the type constructor tc */
786 Inst in; { /* starting after instance in */
787 while (++in < instHw) {
788 Cell pi = inst(in).head;
789 for (; isAp(pi); pi=fun(pi))
790 if (typeInvolves(arg(pi),tc))
796 static Bool local typeInvolves(ty,tc) /* Test to see if type ty involves */
797 Type ty; /* type constructor/tuple tc. */
800 || (isAp(ty) && (typeInvolves(fun(ty),tc)
801 || typeInvolves(arg(ty),tc)));
804 /* --------------------------------------------------------------------------
807 * Various parts of the system use a stack of cells. Most of the stack
808 * operations are defined as macros, expanded inline.
809 * ------------------------------------------------------------------------*/
811 Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */
812 StackPtr sp; /* stack pointer */
814 #if GIMME_STACK_DUMPS
816 #define UPPER_DISP 5 /* # display entries on top of stack */
817 #define LOWER_DISP 5 /* # display entries on bottom of stack*/
819 Void hugsStackOverflow() { /* Report stack overflow */
821 extern Cell evalRoots[];
823 ERRMSG(0) "Control stack overflow" ETHEN
826 if (rootsp>=UPPER_DISP+LOWER_DISP) {
827 for (i=0; i<UPPER_DISP; i++) {
828 ERRTEXT "\nwhile evaluating: " ETHEN
829 ERREXPR(evalRoots[rootsp-i]);
831 ERRTEXT "\n..." ETHEN
832 for (i=LOWER_DISP-1; i>=0; i--) {
833 ERRTEXT "\nwhile evaluating: " ETHEN
834 ERREXPR(evalRoots[i]);
838 for (i=rootsp; i>=0; i--) {
839 ERRTEXT "\nwhile evaluating: " ETHEN
840 ERREXPR(evalRoots[i]);
848 #else /* !GIMME_STACK_DUMPS */
850 Void hugsStackOverflow() { /* Report stack overflow */
851 ERRMSG(0) "Control stack overflow"
855 #endif /* !GIMME_STACK_DUMPS */
857 /* --------------------------------------------------------------------------
860 * A Module represents a user defined module.
862 * Note: there are now two lookup mechanisms in the system:
864 * 1) The exports from a module are stored in a big list.
865 * We resolve qualified names, and import lists by linearly scanning
868 * 2) Unqualified imports and local definitions for the current module
869 * are stored in hash tables (tyconHash and nameHash) or linear lists
872 * ------------------------------------------------------------------------*/
875 static Module moduleHw; /* next unused Module */
876 struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */
877 Module currentModule; /* Module currently being processed*/
879 Bool isValidModule(m) /* is m a legitimate module id? */
881 return (MODMIN <= m && m < moduleHw);
884 Module newModule(t) /* add new module to module table */
886 if (moduleHw-MODMIN >= NUM_MODULE) {
887 ERRMSG(0) "Module storage space exhausted"
890 module(moduleHw).text = t; /* clear new module record */
891 module(moduleHw).qualImports = NIL;
892 module(moduleHw).exports = NIL;
893 module(moduleHw).tycons = NIL;
894 module(moduleHw).names = NIL;
895 module(moduleHw).classes = NIL;
896 module(moduleHw).objectFile = 0;
900 Module findModule(t) /* locate Module in module table */
903 for(m=MODMIN; m<moduleHw; ++m) {
904 if (module(m).text==t)
910 Module findModid(c) /* Find module by name or filename */
913 case STRCELL : { Script s = scriptThisFile(snd(c));
914 return (s==-1) ? NIL : moduleOfScript(s);
916 case CONIDCELL : return findModule(textOf(c));
917 default : internal("findModid");
919 assert(0); return 0; /* NOTREACHED */
922 static local Module findQualifier(t) /* locate Module in import list */
925 if (t==module(modulePreludeHugs).text) {
926 /* The Haskell report (rightly) forbids this.
927 * We added it to let the Prelude refer to itself
928 * without having to import itself.
930 return modulePreludeHugs;
932 for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
933 if (textOf(fst(hd(ms)))==t)
937 if (module(currentModule).text==t)
938 return currentModule;
943 Void setCurrModule(m) /* set lookup tables for current module */
946 if (m!=currentModule) {
947 currentModule = m; /* This is the only assignment to currentModule */
948 for (i=0; i<TYCONHSZ; ++i)
950 mapProc(hashTycon,module(m).tycons);
951 for (i=0; i<NAMEHSZ; ++i)
953 mapProc(hashName,module(m).names);
954 classes = module(m).classes;
957 #endif /* !IGNORE_MODULES */
959 /* --------------------------------------------------------------------------
960 * Script file storage:
962 * script files are read into the system one after another. The state of
963 * the stored data structures (except the garbage-collected heap) is recorded
964 * before reading a new script. In the event of being unable to read the
965 * script, or if otherwise requested, the system can be restored to its
966 * original state immediately before the file was read.
967 * ------------------------------------------------------------------------*/
969 typedef struct { /* record of storage state prior to */
970 Text file; /* reading script/module */
987 static Void local showUse(msg,val,mx)
990 Printf("%6s : %d of %d (%d%%)\n",msg,val,mx,(100*val)/mx);
994 static Script scriptHw; /* next unused script number */
995 static script scripts[NUM_SCRIPTS]; /* storage for script records */
997 Script startNewScript(f) /* start new script, keeping record */
998 String f; { /* of status for later restoration */
999 if (scriptHw >= NUM_SCRIPTS) {
1000 ERRMSG(0) "Too many script files in use"
1003 #ifdef DEBUG_SHOWUSE
1004 showUse("Text", textHw, NUM_TEXT);
1006 showUse("Module", moduleHw-MODMIN, NUM_MODULE);
1008 showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON);
1009 showUse("Name", nameHw-NAMEMIN, NUM_NAME);
1010 showUse("Class", classHw-CLASSMIN, NUM_CLASSES);
1011 showUse("Inst", instHw-INSTMIN, NUM_INSTS);
1013 showUse("Ext", extHw-EXTMIN, NUM_EXT);
1017 scripts[scriptHw].file = findText( f ? f : "<nofile>" );
1018 scripts[scriptHw].textHw = textHw;
1019 scripts[scriptHw].nextNewText = nextNewText;
1020 scripts[scriptHw].nextNewDText = nextNewDText;
1022 scripts[scriptHw].moduleHw = moduleHw;
1024 scripts[scriptHw].tyconHw = tyconHw;
1025 scripts[scriptHw].nameHw = nameHw;
1026 scripts[scriptHw].classHw = classHw;
1027 scripts[scriptHw].instHw = instHw;
1029 scripts[scriptHw].extHw = extHw;
1034 Bool isPreludeScript() { /* Test whether this is the Prelude*/
1035 return (scriptHw==0);
1039 Bool moduleThisScript(m) /* Test if given module is defined */
1040 Module m; { /* in current script file */
1041 return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
1044 Module lastModule() { /* Return module in current script file */
1045 return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude);
1047 #endif /* !IGNORE_MODULES */
1049 #define scriptThis(nm,t,tag) Script nm(x) \
1053 && x>=scripts[s].tag) \
1057 scriptThis(scriptThisName,Name,nameHw)
1058 scriptThis(scriptThisTycon,Tycon,tyconHw)
1059 scriptThis(scriptThisInst,Inst,instHw)
1060 scriptThis(scriptThisClass,Class,classHw)
1063 Module moduleOfScript(s)
1065 return (s==0) ? modulePrelude : scripts[s-1].moduleHw;
1069 String fileOfModule(m)
1072 if (m == modulePrelude) {
1075 for(s=0; s<scriptHw; ++s) {
1076 if (scripts[s].moduleHw == m) {
1077 return textToStr(scripts[s].file);
1084 Script scriptThisFile(f)
1087 for (s=0; s < scriptHw; ++s) {
1088 if (scripts[s].file == f) {
1092 if (f == findText(STD_PRELUDE)) {
1098 Void dropScriptsFrom(sno) /* Restore storage to state prior */
1099 Script sno; { /* to reading script sno */
1100 if (sno<scriptHw) { /* is there anything to restore? */
1102 textHw = scripts[sno].textHw;
1103 nextNewText = scripts[sno].nextNewText;
1104 nextNewDText = scripts[sno].nextNewDText;
1106 moduleHw = scripts[sno].moduleHw;
1108 tyconHw = scripts[sno].tyconHw;
1109 nameHw = scripts[sno].nameHw;
1110 classHw = scripts[sno].classHw;
1111 instHw = scripts[sno].instHw;
1113 dictHw = scripts[sno].dictHw;
1116 extHw = scripts[sno].extHw;
1119 for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
1120 if (module(i).objectFile) {
1121 printf("[bogus] closing objectFile for module %d\n",i);
1122 /*dlclose(module(i).objectFile);*/
1125 moduleHw = scripts[sno].moduleHw;
1127 for (i=0; i<TEXTHSZ; ++i) {
1129 while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
1130 && textHash[i][j]<textHw)
1133 textHash[i][j] = NOTEXT;
1137 for (i=0; i<TYCONHSZ; ++i) {
1138 Tycon tc = tyconHash[i];
1139 while (nonNull(tc) && tc>=tyconHw)
1140 tc = tycon(tc).nextTyconHash;
1144 for (i=0; i<NAMEHSZ; ++i) {
1145 Name n = nameHash[i];
1146 while (nonNull(n) && n>=nameHw)
1147 n = name(n).nextNameHash;
1150 #else /* !IGNORE_MODULES */
1152 for (i=0; i<TYCONHSZ; ++i) {
1155 for (i=0; i<NAMEHSZ; ++i) {
1158 #endif /* !IGNORE_MODULES */
1160 for (i=CLASSMIN; i<classHw; i++) {
1161 List ins = cclass(i).instances;
1164 while (nonNull(ins)) {
1165 List temp = tl(ins);
1166 if (hd(ins)<instHw) {
1172 cclass(i).instances = rev(is);
1179 /* --------------------------------------------------------------------------
1182 * Provides a garbage collectable heap for storage of expressions etc.
1184 * Now incorporates a flat resource: A two-space collected extension of
1185 * the heap that provides storage for contiguous arrays of Cell storage,
1186 * cooperating with the garbage collection mechanisms for the main heap.
1187 * ------------------------------------------------------------------------*/
1189 Int heapSize = DEFAULTHEAP; /* number of cells in heap */
1190 Heap heapFst; /* array of fst component of pairs */
1191 Heap heapSnd; /* array of snd component of pairs */
1198 Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
1199 /* C stack; use with extreme care! */
1201 Heap heapThd, heapTopThd; /* to keep record of producers */
1202 Int sysCount; /* record unattached cells */
1203 Name producer; /* current producer, if any */
1204 Bool profiling = FALSE; /* should profiling be performed */
1205 Int profInterval = MAXPOSINT; /* interval between samples */
1206 FILE *profile = 0; /* pointer to profiler log, if any */
1209 Int numGcs; /* number of garbage collections */
1210 Int cellsRecovered; /* number of cells recovered */
1212 static Cell freeList; /* free list of unused cells */
1213 static Cell lsave, rsave; /* save components of pair */
1216 static List weakPtrs; /* list of weak ptrs */
1217 /* reconstructed during every GC */
1218 List finalizers = NIL;
1219 List liveWeakPtrs = NIL;
1224 static Int markCount, stackRoots;
1226 #define initStackRoots() stackRoots = 0
1227 #define recordStackRoot() stackRoots++
1240 #define start() markCount = 0
1241 #define end(thing,rs) \
1243 Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
1246 #define recordMark() markCount++
1248 #else /* !GC_STATISTICS */
1253 #define initStackRoots()
1254 #define recordStackRoot()
1257 #define end(thing,root)
1258 #define recordMark()
1260 #endif /* !GC_STATISTICS */
1262 Cell pair(l,r) /* Allocate pair (l, r) from */
1263 Cell l, r; { /* heap, garbage collecting first */
1264 Cell c = freeList; /* if necessary ... */
1276 freeList = snd(freeList);
1286 Void overwrite(dst,src) /* overwrite dst cell with src cell*/
1287 Cell dst, src; { /* both *MUST* be pairs */
1288 if (isPair(dst) && isPair(src)) {
1289 fst(dst) = fst(src);
1290 snd(dst) = snd(src);
1293 internal("overwrite");
1297 static Int marksSize;
1299 Cell markExpr(c) /* External interface to markCell */
1301 return isGenPair(c) ? markCell(c) : c;
1304 static Cell local markCell(c) /* Traverse part of graph marking */
1305 Cell c; { /* cells reachable from given root */
1306 /* markCell(c) is only called if c */
1308 { register int place = placeInSet(c);
1309 register int mask = maskInSet(c);
1310 if (marks[place]&mask)
1313 marks[place] |= mask;
1318 if (isGenPair(fst(c))) {
1319 fst(c) = markCell(fst(c));
1322 else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
1329 static Void local markSnd(c) /* Variant of markCell used to */
1330 Cell c; { /* update snd component of cell */
1331 Cell t; /* using tail recursion */
1333 ma: t = c; /* Keep pointer to original pair */
1338 { register int place = placeInSet(c);
1339 register int mask = maskInSet(c);
1340 if (marks[place]&mask)
1343 marks[place] |= mask;
1348 if (isGenPair(fst(c))) {
1349 fst(c) = markCell(fst(c));
1352 else if (isNull(fst(c)) || fst(c)>=BCSTAG)
1357 Void markWithoutMove(n) /* Garbage collect cell at n, as if*/
1358 Cell n; { /* it was a cell ref, but don't */
1359 /* move cell so we don't have */
1360 /* to modify the stored value of n */
1367 Void garbageCollect() { /* Run garbage collector ... */
1368 Bool breakStat = breakOn(FALSE); /* disable break checking */
1373 jmp_buf regs; /* save registers on stack */
1377 for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
1380 weakPtrs = NIL; /* clear list of weak pointers */
1382 everybody(MARK); /* Mark all components of system */
1385 for (i=0; i<NUM_HANDLES; ++i) /* release any unused handles */
1386 if (nonNull(handles[i].hcell)) {
1387 register place = placeInSet(handles[i].hcell);
1388 register mask = maskInSet(handles[i].hcell);
1389 if ((marks[place]&mask)==0)
1394 for (i=0; i<NUM_MALLOCPTRS; ++i) /* release any unused mallocptrs */
1395 if (isPair(mallocPtrs[i].mpcell)) {
1396 register place = placeInSet(mallocPtrs[i].mpcell);
1397 register mask = maskInSet(mallocPtrs[i].mpcell);
1398 if ((marks[place]&mask)==0)
1399 incMallocPtrRefCnt(i,-1);
1401 #endif /* GC_MALLOCPTRS */
1403 /* After GC completes, we scan the list of weak pointers that are
1404 * still live and zap their contents unless the contents are still
1405 * live (by some other means).
1406 * Note that this means the contents must itself be heap allocated.
1407 * This means it can't be a nullary constructor or an Int or a Name
1408 * or lots of other things - hope this doesn't bite too hard.
1410 for (; nonNull(weakPtrs); weakPtrs=nextWeakPtr(weakPtrs)) {
1411 Cell ptr = derefWeakPtr(weakPtrs);
1412 if (isGenPair(ptr)) {
1413 Int place = placeInSet(ptr);
1414 Int mask = maskInSet(ptr);
1415 if ((marks[place]&mask)==0) {
1416 /* printf("Zapping weak pointer %d\n", ptr); */
1417 derefWeakPtr(weakPtrs) = NIL;
1419 /* printf("Keeping weak pointer %d\n", ptr); */
1421 } else if (nonNull(ptr)) {
1422 printf("Weak ptr contains object which isn't heap allocated %d\n", ptr);
1426 if (nonNull(liveWeakPtrs) || nonNull(finalizers)) {
1427 Bool anyMarked; /* Weak pointers with finalizers */
1431 /* Step 1: iterate until we've found out what is reachable */
1434 for (wps=liveWeakPtrs; nonNull(wps); wps=tl(wps)) {
1436 Cell k = fst(snd(wp));
1438 internal("bad weak ptr");
1441 Cell vf = snd(snd(wp));
1442 if (!isMarked(fst(vf)) || !isMarked(snd(vf))) {
1449 } while (anyMarked);
1451 /* Step 2: Now we know which weak pointers will die, so we can */
1452 /* remove them from the live set and gather their finalizers. But */
1453 /* note that we mustn't mark *anything* at this stage or we will */
1454 /* corrupt our view of what's alive, and what's dead. */
1456 while (nonNull(liveWeakPtrs)) {
1457 Cell wp = hd(liveWeakPtrs);
1458 List nx = tl(liveWeakPtrs);
1459 Cell k = fst(snd(wp));
1460 if (!isMarked(k)) { /* If the key is dead, then*/
1461 Cell vf = snd(snd(wp)); /* stomp on weak pointer */
1464 newFins = vf; /* reuse because we can't */
1465 fst(snd(wp)) = NIL; /* reallocate here ... */
1470 tl(liveWeakPtrs) = wps; /* Otherwise, weak pointer */
1471 wps = liveWeakPtrs;/* survives to face another*/
1472 liveWeakPtrs = nx; /* garbage collection */
1476 /* Step 3: Now we've identified the live cells and the newly */
1477 /* scheduled finalizers, but we had better make sure that they are */
1478 /* all marked now, including any internal structure, to ensure that*/
1479 /* they make it to the other side of gc. */
1480 for (liveWeakPtrs=wps; nonNull(wps); wps=tl(wps)) {
1485 finalizers = revOnto(newFins,finalizers);
1488 #endif /* GC_WEAKPTRS */
1489 gcScanning(); /* scan mark set */
1497 for (i=NAMEMIN; i<nameHw; i++)
1502 for (i=1; i<=heapSize; i++) {
1503 if ((marks[place] & mask) == 0) {
1510 else if (nonNull(thd(-i)))
1511 name(thd(-i)).count++;
1516 if (++j == bitsPerWord) {
1523 gcRecovered(recovered);
1524 breakOn(breakStat); /* restore break trapping if nec. */
1528 fprintf(profile,"BEGIN_SAMPLE %ld.00\n",numReductions);
1529 /* For the time being, we won't include the system count in the output:
1531 fprintf(profile," SYSTEM %d\n",sysCount);
1533 /* Accumulate costs in top level objects */
1534 for (i=NAMEMIN; i<nameHw; i++) {
1536 /* Use of "while" instead of "if" is pure paranoia - ADR */
1537 while (isName(name(cc).parent))
1538 cc = name(cc).parent;
1540 name(cc).count += name(i).count;
1544 for (i=NAMEMIN; i<nameHw; i++)
1545 if (name(i).count>0)
1546 if (isPair(name(i).parent)) {
1547 Pair p = name(i).parent;
1549 fprintf(profile," ");
1551 fprintf(profile,"%s",textToStr(cclass(f).text));
1553 fprintf(profile,"%s_",textToStr(cclass(inst(f).c).text));
1554 /* Will hp2ps accept the spaces produced by this? */
1555 printPred(profile,inst(f).head);
1557 fprintf(profile,"_%s %d\n",
1558 textToStr(name(snd(p)).text),
1561 fprintf(profile," %s %d\n",
1562 textToStr(name(i).text),
1565 fprintf(profile,"END_SAMPLE %ld.00\n",numReductions);
1569 /* can only return if freeList is nonempty on return. */
1570 if (recovered<minRecovery || isNull(freeList)) {
1571 ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
1574 cellsRecovered = recovered;
1578 Void profilerLog(s) /* turn heap profiling on, saving log*/
1579 String s; { /* in specified file */
1580 if ((profile=fopen(s,"w")) != NULL) {
1581 fprintf(profile,"JOB \"Hugs Heap Profile\"\n");
1582 fprintf(profile,"DATE \"%s\"\n",timeString());
1583 fprintf(profile,"SAMPLE_UNIT \"reductions\"\n");
1584 fprintf(profile,"VALUE_UNIT \"cells\"\n");
1587 ERRMSG(0) "Cannot open profile log file \"%s\"", s
1593 /* --------------------------------------------------------------------------
1594 * Code for saving last expression entered:
1596 * This is a little tricky because some text values (e.g. strings or variable
1597 * names) may not be defined or have the same value when the expression is
1598 * recalled. These text values are therefore saved in the top portion of
1600 * ------------------------------------------------------------------------*/
1602 static Cell lastExprSaved; /* last expression to be saved */
1604 Void setLastExpr(e) /* save expression for later recall*/
1606 lastExprSaved = NIL; /* in case attempt to save fails */
1607 savedText = NUM_TEXT;
1608 lastExprSaved = lowLevelLastIn(e);
1611 static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */
1612 Cell c; { /* acyclic graph) for later recall */
1613 if (isPair(c)) /* Duplicating any text strings */
1614 if (isBoxTag(fst(c))) /* in case these are lost at some */
1615 switch (fst(c)) { /* point before the expr is reused */
1621 case STRCELL : return pair(fst(c),saveText(textOf(c)));
1622 default : return pair(fst(c),snd(c));
1625 return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
1628 return pair(EXTCOPY,saveText(extText(c)));
1634 Cell getLastExpr() { /* recover previously saved expr */
1635 return lowLevelLastOut(lastExprSaved);
1638 static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */
1639 Cell c; { /* except that Cells refering to */
1640 if (isPair(c)) /* Text values are restored to */
1641 if (isBoxTag(fst(c))) /* appropriate values */
1648 case STRCELL : return pair(fst(c),
1649 findText(text+intValOf(c)));
1651 case EXTCOPY : return mkExt(findText(text+intValOf(c)));
1653 default : return pair(fst(c),snd(c));
1656 return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
1661 /* --------------------------------------------------------------------------
1662 * Miscellaneous operations on heap cells:
1663 * ------------------------------------------------------------------------*/
1665 /* Profiling suggests that the number of calls to whatIs() is typically */
1666 /* rather high. The recoded version below attempts to improve the average */
1667 /* performance for whatIs() using a binary search for part of the analysis */
1669 Cell whatIs(c) /* identify type of cell */
1672 register Cell fstc = fst(c);
1673 return isTag(fstc) ? fstc : AP;
1675 if (c<TUPMIN) return c;
1676 if (c>=INTMIN) return INTCELL;
1678 if (c>=NAMEMIN) if (c>=CLASSMIN) if (c>=CHARMIN) return CHARCELL;
1680 else if (c>=INSTMIN) return INSTANCE;
1682 else if (c>=MODMIN) if (c>=TYCMIN) return TYCON;
1684 else if (c>=OFFMIN) return OFFSET;
1686 else return (c>=EXTMIN) ?
1693 register Cell fstc = fst(c);
1694 return isTag(fstc) ? fstc : AP;
1696 if (c>=INTMIN) return INTCELL;
1697 if (c>=CHARMIN) return CHARCELL;
1698 if (c>=CLASSMIN) return CLASS;
1699 if (c>=INSTMIN) return INSTANCE;
1700 if (c>=NAMEMIN) return NAME;
1701 if (c>=TYCMIN) return TYCON;
1702 if (c>=MODMIN) return MODULE;
1703 if (c>=OFFMIN) return OFFSET;
1705 if (c>=EXTMIN) return EXT;
1707 if (c>=TUPMIN) return TUPLE;
1712 /* A very, very simple printer.
1713 * Output is uglier than from printExp - but the printer is more
1714 * robust and can be used on any data structure irrespective of
1717 Void print Args((Cell, Int));
1718 Void print(c, depth)
1723 #if 0 /* Not in this version of Hugs */
1724 } else if (isPair(c) && !isGenPair(c)) {
1725 extern Void printEvalCell Args((Cell, Int));
1726 printEvalCell(c,depth);
1729 Int tag = whatIs(c);
1733 print(fst(c), depth-1);
1735 print(snd(c), depth-1);
1739 Printf("free(%d)", c);
1742 Printf("int(%d)", intOf(c));
1745 Printf("bignum(%s)", bignumToString(c));
1748 Printf("char('%c')", charOf(c));
1751 Printf("ptr(%p)",ptrOf(c));
1754 Printf("class(%d)", c-CLASSMIN);
1755 if (CLASSMIN <= c && c < classHw) {
1756 Printf("=\"%s\"", textToStr(cclass(c).text));
1760 Printf("instance(%d)", c - INSTMIN);
1763 Printf("name(%d)", c-NAMEMIN);
1764 if (NAMEMIN <= c && c < nameHw) {
1765 Printf("=\"%s\"", textToStr(name(c).text));
1769 Printf("tycon(%d)", c-TYCMIN);
1770 if (TYCMIN <= c && c < tyconHw)
1771 Printf("=\"%s\"", textToStr(tycon(c).text));
1774 Printf("module(%d)", c - MODMIN);
1777 Printf("Offset %d", offsetOf(c));
1780 Printf("Tuple %d", tupleOf(c));
1784 print(snd(c),depth-1);
1788 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
1789 Printf("%d ", intOf(fst(snd(c))));
1790 print(snd(snd(c)),depth-1);
1792 print(snd(c),depth-1);
1809 Printf("{dict %d}",textOf(c));
1815 Printf("{id %s}",textToStr(textOf(c)));
1818 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
1822 print(fst(snd(c)),depth-1);
1824 print(snd(snd(c)),depth-1);
1829 print(snd(c),depth-1);
1834 print(snd(c),depth-1);
1839 print(fst(snd(c)),depth-1);
1841 print(snd(snd(c)),depth-1);
1846 print(fst(snd(c)),depth-1);
1848 print(snd(snd(c)),depth-1);
1852 Printf("FromQual(");
1853 print(fst(snd(c)),depth-1);
1855 print(snd(snd(c)),depth-1);
1859 Printf("StgVar%d=",-c);
1860 print(snd(c), depth-1);
1864 print(fst(snd(c)),depth-1);
1866 print(snd(snd(c)),depth-1);
1871 print(fst(snd(c)),depth-1);
1873 print(snd(snd(c)),depth-1);
1878 print(fst(snd(c)),depth-1);
1880 print(snd(snd(c)),depth-1);
1884 Printf("PrimCase(");
1885 print(fst(snd(c)),depth-1);
1887 print(snd(snd(c)),depth-1);
1891 if (isBoxTag(tag)) {
1892 Printf("Tag(%d)=%d", c, tag);
1893 } else if (isConTag(tag)) {
1894 Printf("%d@(%d,",c,tag);
1895 print(snd(c), depth-1);
1898 } else if (c == tag) {
1899 Printf("Tag(%d)", c);
1901 Printf("Tag(%d)=%d", c, tag);
1910 Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */
1911 Cell c; { /* also recognises DICTVAR cells */
1913 (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
1916 Bool isCon(c) /* is cell a CONIDCELL/CONOPCELL ? */
1918 return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
1921 Bool isQVar(c) /* is cell a [un]qualified varop/id? */
1923 if (!isPair(c)) return FALSE;
1926 case VAROPCELL : return TRUE;
1928 case QUALIDENT : return isVar(snd(snd(c)));
1930 default : return FALSE;
1934 Bool isQCon(c) /*is cell a [un]qualified conop/id? */
1936 if (!isPair(c)) return FALSE;
1939 case CONOPCELL : return TRUE;
1941 case QUALIDENT : return isCon(snd(snd(c)));
1943 default : return FALSE;
1947 Bool isQualIdent(c) /* is cell a qualified identifier? */
1949 return isPair(c) && (fst(c)==QUALIDENT);
1952 Bool isIdent(c) /* is cell an identifier? */
1954 if (!isPair(c)) return FALSE;
1959 case CONOPCELL : return TRUE;
1961 case QUALIDENT : return TRUE;
1963 default : return FALSE;
1967 Bool isInt(c) /* cell holds integer value? */
1969 return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
1972 Int intOf(c) /* find integer value of cell? */
1975 return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
1978 Cell mkInt(n) /* make cell representing integer */
1980 return (MINSMALLINT <= n && n <= MAXSMALLINT)
1986 Bool isBignum(c) /* cell holds bignum value? */
1988 return c==ZERONUM || (isPair(c) && (fst(c)==POSNUM || fst(c)==NEGNUM));
1992 #if SIZEOF_INTP == SIZEOF_INT
1993 typedef union {Int i; Ptr p;} IntOrPtr;
1999 return pair(PTRCELL,x.i);
2006 assert(fst(c) == PTRCELL);
2010 #elif SIZEOF_INTP == 2*SIZEOF_INT
2011 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2017 return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2024 assert(fst(c) == PTRCELL);
2025 x.i.i1 = intOf(fst(snd(c)));
2026 x.i.i2 = intOf(snd(snd(c)));
2030 #warning "type Addr not supported on this architecture - don't use it"
2034 ERRMSG(0) "mkPtr: type Addr not supported on this architecture"
2041 ERRMSG(0) "ptrOf: type Addr not supported on this architecture"
2046 /* --------------------------------------------------------------------------
2048 * ------------------------------------------------------------------------*/
2050 Int length(xs) /* calculate length of list xs */
2053 for (; nonNull(xs); ++n)
2058 List appendOnto(xs,ys) /* Destructively prepend xs onto */
2059 List xs, ys; { /* ys by modifying xs ... */
2064 while (nonNull(tl(zs)))
2071 List dupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
2074 for (; nonNull(xs); xs=tl(xs))
2075 ys = cons(hd(xs),ys);
2079 List dupList(xs) /* Duplicate spine of list xs */
2082 for (; nonNull(xs); xs=tl(xs))
2083 ys = cons(hd(xs),ys);
2087 List revOnto(xs,ys) /* Destructively reverse elements of*/
2088 List xs, ys; { /* list xs onto list ys... */
2091 while (nonNull(xs)) {
2101 List delete(xs,y) /* Delete first use of y from xs */
2106 } else if (hs(xs) == y) {
2109 tl(xs) = delete(tl(xs),y);
2114 List minus(xs,ys) /* Delete members of ys from xs */
2116 mapAccum(delete,xs,ys);
2121 Cell varIsMember(t,xs) /* Test if variable is a member of */
2122 Text t; /* given list of variables */
2124 for (; nonNull(xs); xs=tl(xs))
2125 if (t==textOf(hd(xs)))
2130 Name nameIsMember(t,ns) /* Test if name with text t is a */
2131 Text t; /* member of list of names xs */
2133 for (; nonNull(ns); ns=tl(ns))
2134 if (t==name(hd(ns)).text)
2139 Cell intIsMember(n,xs) /* Test if integer n is member of */
2140 Int n; /* given list of integers */
2142 for (; nonNull(xs); xs=tl(xs))
2143 if (n==intOf(hd(xs)))
2148 Cell cellIsMember(x,xs) /* Test for membership of specific */
2149 Cell x; /* cell x in list xs */
2151 for (; nonNull(xs); xs=tl(xs))
2157 Cell cellAssoc(c,xs) /* Lookup cell in association list */
2160 for (; nonNull(xs); xs=tl(xs))
2166 Cell cellRevAssoc(c,xs) /* Lookup cell in range of */
2167 Cell c; /* association lists */
2169 for (; nonNull(xs); xs=tl(xs))
2175 List replicate(n,x) /* create list of n copies of x */
2184 List diffList(from,take) /* list difference: from\take */
2185 List from, take; { /* result contains all elements of */
2186 List result = NIL; /* `from' not appearing in `take' */
2188 while (nonNull(from)) {
2189 List next = tl(from);
2190 if (!cellIsMember(hd(from),take)) {
2199 List deleteCell(xs, y) /* copy xs deleting pointers to y */
2203 for(;nonNull(xs);xs=tl(xs)) {
2206 result=cons(x,result);
2212 List take(n,xs) /* destructively truncate list to */
2213 Int n; /* specified length */
2219 while (1<n-- && nonNull(xs))
2226 List splitAt(n,xs) /* drop n things from front of list*/
2235 Cell nth(n,xs) /* extract n'th element of list */
2238 for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2245 List removeCell(x,xs) /* destructively remove cell from */
2250 return tl(xs); /* element at front of list */
2254 for (; nonNull(curr); prev=curr, curr=tl(prev))
2256 tl(prev) = tl(curr);
2257 return xs; /* element in middle of list */
2261 return xs; /* here if element not found */
2264 /* --------------------------------------------------------------------------
2265 * Operations on applications:
2266 * ------------------------------------------------------------------------*/
2268 Int argCount; /* number of args in application */
2270 Cell getHead(e) /* get head cell of application */
2271 Cell e; { /* set number of args in argCount */
2272 for (argCount=0; isAp(e); e=fun(e))
2277 List getArgs(e) /* get list of arguments in function*/
2278 Cell e; { /* application: */
2279 List as; /* getArgs(f e1 .. en) = [e1,..,en] */
2281 for (as=NIL; isAp(e); e=fun(e))
2282 as = cons(arg(e),as);
2286 Cell nthArg(n,e) /* return nth arg in application */
2287 Int n; /* of function to m args (m>=n) */
2288 Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
2289 for (n=numArgs(e)-n-1; n>0; n--)
2294 Int numArgs(e) /* find number of arguments to expr */
2297 for (n=0; isAp(e); e=fun(e))
2302 Cell applyToArgs(f,args) /* destructively apply list of args */
2303 Cell f; /* to function f */
2305 while (nonNull(args)) {
2306 Cell temp = tl(args);
2307 tl(args) = hd(args);
2315 /* --------------------------------------------------------------------------
2316 * Handle operations:
2317 * ------------------------------------------------------------------------*/
2320 struct strHandle DEFTABLE(handles,NUM_HANDLES);
2322 Cell openHandle(s,hmode,binary) /* open handle to file named s in */
2323 String s; /* the specified hmode */
2328 for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
2329 ; /* Search for unused handle*/
2330 if (i>=NUM_HANDLES) { /* If at first we don't */
2331 garbageCollect(); /* succeed, garbage collect*/
2332 for (i=0; i<NUM_HANDLES && nonNull(handles[i].hcell); ++i)
2333 ; /* and try again ... */
2335 if (i>=NUM_HANDLES) { /* ... before we give up */
2336 ERRMSG(0) "Too many handles open; cannot open \"%s\"", s
2339 else { /* prepare to open file */
2342 stmode = (hmode&HAPPEND) ? "ab+" :
2343 (hmode&HWRITE) ? "wb+" :
2344 (hmode&HREAD) ? "rb" : (String)0;
2346 stmode = (hmode&HAPPEND) ? "a+" :
2347 (hmode&HWRITE) ? "w+" :
2348 (hmode&HREAD) ? "r" : (String)0;
2350 if (stmode && (handles[i].hfp=fopen(s,stmode))) {
2351 handles[i].hmode = hmode;
2352 return (handles[i].hcell = ap(HANDCELL,i));
2358 static Void local freeHandle(n) /* release handle storage when no */
2359 Int n; { /* heap references to it remain */
2360 if (0<=n && n<NUM_HANDLES && nonNull(handles[n].hcell)) {
2361 if (n>HSTDERR && handles[n].hmode!=HCLOSED && handles[n].hfp) {
2362 fclose(handles[n].hfp);
2365 fst(handles[n].hcell) = snd(handles[n].hcell) = NIL;
2366 handles[n].hcell = NIL;
2372 /* --------------------------------------------------------------------------
2374 * ------------------------------------------------------------------------*/
2376 struct strMallocPtr mallocPtrs[NUM_MALLOCPTRS];
2378 /* It might GC (because it uses a table not a list) which will trash any
2379 * unstable pointers.
2380 * (It happens that we never use it with unstable pointers.)
2382 Cell mkMallocPtr(ptr,cleanup) /* create a new malloc pointer */
2384 Void (*cleanup) Args((Ptr)); {
2386 for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
2387 ; /* Search for unused entry */
2388 if (i>=NUM_MALLOCPTRS) { /* If at first we don't */
2389 garbageCollect(); /* succeed, garbage collect*/
2390 for (i=0; i<NUM_MALLOCPTRS && mallocPtrs[i].refCount!=0; ++i)
2391 ; /* and try again ... */
2393 if (i>=NUM_MALLOCPTRS) { /* ... before we give up */
2394 ERRMSG(0) "Too many ForeignObjs open"
2397 mallocPtrs[i].ptr = ptr;
2398 mallocPtrs[i].cleanup = cleanup;
2399 mallocPtrs[i].refCount = 1;
2400 return (mallocPtrs[i].mpcell = ap(MPCELL,i));
2403 Void incMallocPtrRefCnt(n,i) /* change ref count of MallocPtr */
2406 if (!(0<=n && n<NUM_MALLOCPTRS && mallocPtrs[n].refCount > 0))
2407 internal("freeMallocPtr");
2408 mallocPtrs[n].refCount += i;
2409 if (mallocPtrs[n].refCount <= 0) {
2410 mallocPtrs[n].cleanup(mallocPtrs[n].ptr);
2412 mallocPtrs[n].ptr = 0;
2413 mallocPtrs[n].cleanup = 0;
2414 mallocPtrs[n].refCount = 0;
2415 mallocPtrs[n].mpcell = NIL;
2418 #endif /* GC_MALLOCPTRS */
2420 /* --------------------------------------------------------------------------
2422 * This is a mechanism that allows the C world to manipulate pointers into the
2423 * Haskell heap without having to worry that the garbage collector is going
2424 * to delete it or move it around.
2425 * The implementation and interface is based on my implementation in
2426 * GHC - but, at least for now, is simplified by using a fixed size
2427 * table of stable pointers.
2428 * ------------------------------------------------------------------------*/
2432 /* Each entry in the stable pointer table is either a heap pointer
2433 * or is not currently allocated.
2434 * Unallocated entries are threaded together into a freelist.
2435 * The last entry in the list contains the Cell 0; all other values
2436 * contain a Cell whose value is the next free stable ptr in the list.
2437 * It follows that stable pointers are strictly positive (>0).
2439 static Cell stablePtrTable[NUM_STABLEPTRS];
2440 static Int sptFreeList;
2441 #define SPT(sp) stablePtrTable[(sp)-1]
2443 static Void local resetStablePtrs() {
2445 /* It would be easier to build the free list in the other direction
2446 * but, when debugging, it's way easier to understand if the first
2447 * pointer allocated is "1".
2449 for(i=1; i < NUM_STABLEPTRS; ++i)
2451 SPT(NUM_STABLEPTRS) = 0;
2455 Int mkStablePtr(c) /* Create a stable pointer */
2457 Int i = sptFreeList;
2460 sptFreeList = SPT(i);
2465 Cell derefStablePtr(p) /* Dereference a stable pointer */
2467 if (!(1 <= p && p <= NUM_STABLEPTRS)) {
2468 internal("derefStablePtr");
2473 Void freeStablePtr(i) /* Free a stable pointer */
2475 SPT(i) = sptFreeList;
2480 #endif /* GC_STABLEPTRS */
2482 /* --------------------------------------------------------------------------
2484 * ------------------------------------------------------------------------*/
2486 /*---------------------------------------------------------------------------
2487 * GreenCard entry points
2489 * GreenCard generated code accesses Hugs data structures and functions
2490 * (only) via these functions (which are stored in the virtual function
2492 *-------------------------------------------------------------------------*/
2496 static Cell makeTuple Args((Int));
2497 static Cell makeInt Args((Int));
2498 static Cell makeChar Args((Char));
2499 static Char CharOf Args((Cell));
2500 static Cell makeFloat Args((FloatPro));
2501 static Void* derefMallocPtr Args((Cell));
2502 static Cell* Fst Args((Cell));
2503 static Cell* Snd Args((Cell));
2505 static Cell makeTuple(n) Int n; { return mkTuple(n); }
2506 static Cell makeInt(n) Int n; { return mkInt(n); }
2507 static Cell makeChar(n) Char n; { return mkChar(n); }
2508 static Char CharOf(n) Cell n; { return charOf(n); }
2509 static Cell makeFloat(n) FloatPro n; { return mkFloat(n); }
2510 static Void* derefMallocPtr(n) Cell n; { return derefMP(n); }
2511 static Cell* Fst(n) Cell n; { return (Cell*)&fst(n); }
2512 static Cell* Snd(n) Cell n; { return (Cell*)&snd(n); }
2514 HugsAPI1* hugsAPI1() {
2515 static HugsAPI1 api;
2516 static Bool initialised = FALSE;
2518 api.nameTrue = nameTrue;
2519 api.nameFalse = nameFalse;
2520 api.nameNil = nameNil;
2521 api.nameCons = nameCons;
2522 api.nameJust = nameJust;
2523 api.nameNothing = nameNothing;
2524 api.nameLeft = nameLeft;
2525 api.nameRight = nameRight;
2526 api.nameUnit = nameUnit;
2527 api.nameIORun = nameIORun;
2528 api.makeInt = makeInt;
2529 api.makeChar = makeChar;
2530 api.CharOf = CharOf;
2531 api.makeFloat = makeFloat;
2532 api.makeTuple = makeTuple;
2534 api.mkMallocPtr = mkMallocPtr;
2535 api.derefMallocPtr = derefMallocPtr;
2536 api.mkStablePtr = mkStablePtr;
2537 api.derefStablePtr = derefStablePtr;
2538 api.freeStablePtr = freeStablePtr;
2540 api.evalWithNoError = evalWithNoError;
2541 api.evalFails = evalFails;
2542 api.whnfArgs = &whnfArgs;
2543 api.whnfHead = &whnfHead;
2544 api.whnfInt = &whnfInt;
2545 api.whnfFloat = &whnfFloat;
2546 api.garbageCollect = garbageCollect;
2547 api.stackOverflow = hugsStackOverflow;
2548 api.internal = internal;
2549 api.registerPrims = registerPrims;
2550 api.addPrimCfun = addPrimCfun;
2551 api.inventText = inventText;
2554 api.cellStack = cellStack;
2560 #endif /* GREENCARD */
2563 /* --------------------------------------------------------------------------
2565 * ------------------------------------------------------------------------*/
2568 static void far* safeFarCalloc Args((Int,Int));
2569 static void far* safeFarCalloc(n,s) /* allocate table storage and check*/
2570 Int n, s; { /* for non-null return */
2571 void far* tab = farCalloc(n,s);
2573 ERRMSG(0) "Cannot allocate run-time tables"
2578 #define TABALLOC(v,t,n) v=(t far*)safeFarCalloc(n,sizeof(t));
2580 #define TABALLOC(v,t,n)
2588 case RESET : clearStack();
2590 /* the next 2 statements are particularly important
2591 * if you are using GLOBALfst or GLOBALsnd since the
2592 * corresponding registers may be reset to their
2593 * uninitialised initial values by a longjump.
2595 heapTopFst = heapFst + heapSize;
2596 heapTopSnd = heapSnd + heapSize;
2598 heapTopThd = heapThd + heapSize;
2603 system("hp2ps profile.hp");
2609 handles[HSTDIN].hmode = HREAD;
2610 handles[HSTDOUT].hmode = HAPPEND;
2611 handles[HSTDERR].hmode = HAPPEND;
2614 for (i=0; i<NUM_MALLOCPTRS; i++)
2615 mallocPtrs[i].mpcell = NIL;
2625 if (isNull(lastExprSaved))
2626 savedText = NUM_TEXT;
2631 for (i=NAMEMIN; i<nameHw; ++i) {
2632 mark(name(i).parent);
2634 mark(name(i).stgVar);
2637 end("Names", nameHw-NAMEMIN);
2641 for (i=MODMIN; i<moduleHw; ++i) {
2642 mark(module(i).tycons);
2643 mark(module(i).names);
2644 mark(module(i).classes);
2645 mark(module(i).exports);
2646 mark(module(i).qualImports);
2648 end("Modules", moduleHw-MODMIN);
2652 for (i=TYCMIN; i<tyconHw; ++i) {
2653 mark(tycon(i).defn);
2654 mark(tycon(i).kind);
2655 mark(tycon(i).what);
2657 end("Type constructors", tyconHw-TYCMIN);
2660 for (i=CLASSMIN; i<classHw; ++i) {
2661 mark(cclass(i).head);
2662 mark(cclass(i).kinds);
2663 mark(cclass(i).dsels);
2664 mark(cclass(i).supers);
2665 mark(cclass(i).members);
2666 mark(cclass(i).defaults);
2667 mark(cclass(i).instances);
2670 end("Classes", classHw-CLASSMIN);
2673 for (i=INSTMIN; i<instHw; ++i) {
2675 mark(inst(i).kinds);
2676 mark(inst(i).specifics);
2677 mark(inst(i).implements);
2679 end("Instances", instHw-INSTMIN);
2682 for (i=0; i<=sp; ++i)
2687 mark(lastExprSaved);
2690 end("Last expression", 3);
2693 mark(handles[HSTDIN].hcell);
2694 mark(handles[HSTDOUT].hcell);
2695 mark(handles[HSTDERR].hcell);
2696 end("Standard handles", 3);
2701 for (i=0; i<NUM_STABLEPTRS; ++i)
2702 mark(stablePtrTable[i]);
2703 end("Stable pointers", NUM_STABLEPTRS);
2713 end("C stack", stackRoots);
2718 case INSTALL : heapFst = heapAlloc(heapSize);
2719 heapSnd = heapAlloc(heapSize);
2721 if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
2722 ERRMSG(0) "Cannot allocate heap storage (%d cells)",
2727 heapTopFst = heapFst + heapSize;
2728 heapTopSnd = heapSnd + heapSize;
2730 heapThd = heapAlloc(heapSize);
2731 if (heapThd==(Heap)0) {
2732 ERRMSG(0) "Cannot allocate profiler storage space"
2735 heapTopThd = heapThd + heapSize;
2737 if (0 == profInterval)
2738 profInterval = heapSize / DEF_PROFINTDIV;
2740 for (i=1; i<heapSize; ++i) {
2744 snd(-heapSize) = NIL;
2751 marksSize = bitArraySize(heapSize);
2752 if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
2753 ERRMSG(0) "Unable to allocate gc markspace"
2757 TABALLOC(text, char, NUM_TEXT)
2758 TABALLOC(tyconHash, Tycon, TYCONHSZ)
2759 TABALLOC(tabTycon, struct strTycon, NUM_TYCON)
2760 TABALLOC(nameHash, Name, NAMEHSZ)
2761 TABALLOC(tabName, struct strName, NUM_NAME)
2762 TABALLOC(tabClass, struct strClass, NUM_CLASSES)
2763 TABALLOC(cellStack, Cell, NUM_STACK)
2764 TABALLOC(tabModule, struct Module, NUM_SCRIPTS)
2766 TABALLOC(tabExt, Text, NUM_EXT)
2771 TABALLOC(handles, struct strHandle, NUM_HANDLES)
2772 for (i=0; i<NUM_HANDLES; i++)
2773 handles[i].hcell = NIL;
2774 handles[HSTDIN].hcell = ap(HANDCELL,HSTDIN);
2775 handles[HSTDIN].hfp = stdin;
2776 handles[HSTDOUT].hcell = ap(HANDCELL,HSTDOUT);
2777 handles[HSTDOUT].hfp = stdout;
2778 handles[HSTDERR].hcell = ap(HANDCELL,HSTDERR);
2779 handles[HSTDERR].hfp = stderr;
2783 nextNewText = NUM_TEXT;
2784 nextNewDText = (-1);
2785 lastExprSaved = NIL;
2786 savedText = NUM_TEXT;
2787 for (i=0; i<TEXTHSZ; ++i)
2788 textHash[i][0] = NOTEXT;
2796 for (i=0; i<TYCONHSZ; ++i)
2813 for (i=0; i<NAMEHSZ; ++i)
2824 tabInst = (struct strInst far *)
2825 farCalloc(NUM_INSTS,sizeof(struct strInst));
2828 ERRMSG(0) "Cannot allocate instance tables"
2838 /*-------------------------------------------------------------------------*/