2 /* --------------------------------------------------------------------------
3 * Primitives for manipulating global data structures
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: storage.c,v $
13 * $Date: 2000/06/23 13:13:10 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
24 /* #include "Storage.h"
25 We'd like to, but Storage.h and storage.h look the same under
26 Cygwin, alas, causing compilation chaos. So just copy what
27 we need to know, which is ...
29 extern StgClosure* MarkRoot ( StgClosure* );
31 /*#define DEBUG_SHOWUSE*/
33 /* --------------------------------------------------------------------------
34 * local function prototypes:
35 * ------------------------------------------------------------------------*/
37 static Int local hash ( String );
38 static Int local saveText ( Text );
39 static Module local findQualifier ( Text );
40 static Void local hashTycon ( Tycon );
41 static List local insertTycon ( Tycon,List );
42 static Void local hashName ( Name );
43 static List local insertName ( Name,List );
44 static Void local patternError ( String );
45 static Bool local stringMatch ( String,String );
46 static Bool local typeInvolves ( Type,Type );
47 static Cell local markCell ( Cell );
48 static Void local markSnd ( Cell );
49 static Cell local lowLevelLastIn ( Cell );
50 static Cell local lowLevelLastOut ( Cell );
53 /* --------------------------------------------------------------------------
56 * provides storage for the characters making up identifier and symbol
57 * names, string literals, character constants etc...
59 * All character strings are stored in a large character array, with textHw
60 * pointing to the next free position. Lookup in the array is improved using
61 * a hash table. Internally, text strings are represented by integer offsets
62 * from the beginning of the array to the string in question.
64 * Where memory permits, the use of multiple hashtables gives a significant
65 * increase in performance, particularly when large source files are used.
67 * Each string in the array is terminated by a zero byte. No string is
68 * stored more than once, so that it is safe to test equality of strings by
69 * comparing the corresponding offsets.
71 * Special text values (beyond the range of the text array table) are used
72 * to generate unique `new variable names' as required.
74 * The same text storage is also used to hold text values stored in a saved
75 * expression. This grows downwards from the top of the text table (and is
76 * not included in the hash table).
77 * ------------------------------------------------------------------------*/
79 #define TEXTHSZ 512 /* Size of Text hash table */
80 #define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */
81 static Text textHw; /* Next unused position */
82 static Text savedText = TEXT_SIZE; /* Start of saved portion of text */
83 static Text nextNewText; /* Next new text value */
84 static Text nextNewDText; /* Next new dict text value */
85 static char text[TEXT_SIZE]; /* Storage of character strings */
86 static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */
88 String textToStr(t) /* find string corresp to given Text*/
90 static char newVar[16];
92 if (isText(t)) /* standard char string */
93 return text + t - TEXT_BASE_ADDR;
94 if (isInventedDictVar(t)) {
96 t-INDVAR_BASE_ADDR); /* dictionary variable */
99 if (isInventedVar(t)) {
100 sprintf(newVar,"v%d",
101 t-INVAR_BASE_ADDR); /* normal variable */
104 internal("textToStr");
107 String identToStr(v) /*find string corresp to given ident or qualified name*/
110 internal("identToStr");
116 case CONOPCELL : return textToStr(textOf(v));
118 case QUALIDENT : { String qmod = textToStr(qmodOf(v));
119 String qtext = textToStr(qtextOf(v));
122 while (pos+1 < savedText && *qmod!=0) {
123 text[pos++] = *qmod++;
125 if (pos+1 < savedText) {
128 while (pos+1 < savedText && *qtext!=0) {
129 text[pos++] = *qtext++;
135 internal("identToStr2");
136 return 0; /* NOTREACHED */
139 Text inventText() { /* return new unused variable name */
140 if (nextNewText >= INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
141 internal("inventText: too many invented variables");
142 return nextNewText++;
145 Text inventDictText() { /* return new unused dictvar name */
146 if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
147 internal("inventDictText: too many invented variables");
148 return nextNewDText++;
151 Bool inventedText(t) /* Signal TRUE if text has been */
152 Text t; { /* generated internally */
153 return isInventedVar(t) || isInventedDictVar(t);
156 #define MAX_FIXLIT 100
157 Text fixLitText(t) /* fix literal text that might include \ */
159 String s = textToStr(t);
162 for(i = 0;i < MAX_FIXLIT-2 && *s;s++) {
168 if (i < MAX_FIXLIT-2) {
171 ERRMSG(0) "storage space exhausted for internal literal string"
174 return (findText(p));
178 static Int local hash(s) /* Simple hash function on strings */
182 for (v=((int)(*s))*8; *s; s++)
183 v += ((int)(*s))*(j++);
189 Text findText(s) /* Locate string in Text array */
193 Text textPos = textHash[h][hashno];
195 # define TryMatch { Text originalTextPos = textPos; \
197 for (t=s; *t==text[textPos]; textPos++,t++) \
199 return originalTextPos+TEXT_BASE_ADDR; \
201 # define Skip while (text[textPos++]) ;
203 while (textPos!=NOTEXT) {
205 if (++hashno<NUM_TEXTH) /* look in next hashtable entry */
206 textPos = textHash[h][hashno];
209 while (textPos < textHw) {
220 textPos = textHw; /* if not found, save in array */
221 if (textHw + (Int)strlen(s) + 1 > savedText) {
222 ERRMSG(0) "Character string storage space exhausted"
225 while ((text[textHw++] = *s++) != 0) {
227 if (hashno<NUM_TEXTH) { /* updating hash table as necessary */
228 textHash[h][hashno] = textPos;
229 if (hashno<NUM_TEXTH-1)
230 textHash[h][hashno+1] = NOTEXT;
233 return textPos+TEXT_BASE_ADDR;
236 static Int local saveText(t) /* Save text value in buffer */
237 Text t; { /* at top of text table */
238 String s = textToStr(t);
240 if (textHw + l + 1 > savedText) {
241 ERRMSG(0) "Character string storage space exhausted"
245 strcpy(text+savedText,s);
250 static int fromHexDigit ( char c )
253 case '0': case '1': case '2': case '3': case '4':
254 case '5': case '6': case '7': case '8': case '9':
256 case 'a': case 'A': return 10;
257 case 'b': case 'B': return 11;
258 case 'c': case 'C': return 12;
259 case 'd': case 'D': return 13;
260 case 'e': case 'E': return 14;
261 case 'f': case 'F': return 15;
267 /* returns findText (unZencode s) */
268 Text unZcodeThenFindText ( String s )
275 nn = 100 + 10 * strlen(s);
277 if (!p) internal ("unZcodeThenFindText: malloc failed");
282 if (n > nn-90) internal ("unZcodeThenFindText: result is too big");
283 if (*s != 'z' && *s != 'Z') {
288 if (!(*s)) goto parse_error;
290 case 'Z': p[n++] = 'Z'; break;
291 case 'C': p[n++] = ':'; break;
292 case 'L': p[n++] = '('; break;
293 case 'R': p[n++] = ')'; break;
294 case 'M': p[n++] = '['; break;
295 case 'N': p[n++] = ']'; break;
296 case 'z': p[n++] = 'z'; break;
297 case 'a': p[n++] = '&'; break;
298 case 'b': p[n++] = '|'; break;
299 case 'd': p[n++] = '$'; break;
300 case 'e': p[n++] = '='; break;
301 case 'g': p[n++] = '>'; break;
302 case 'h': p[n++] = '#'; break;
303 case 'i': p[n++] = '.'; break;
304 case 'l': p[n++] = '<'; break;
305 case 'm': p[n++] = '-'; break;
306 case 'n': p[n++] = '!'; break;
307 case 'p': p[n++] = '+'; break;
308 case 'q': p[n++] = '\\'; break;
309 case 'r': p[n++] = '\''; break;
310 case 's': p[n++] = '/'; break;
311 case 't': p[n++] = '*'; break;
312 case 'u': p[n++] = '^'; break;
313 case 'v': p[n++] = '%'; break;
315 if (!s[0] || !s[1]) goto parse_error;
316 if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error;
317 p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]);
320 case '0': case '1': case '2': case '3': case '4':
321 case '5': case '6': case '7': case '8': case '9':
324 while (*s && isdigit((int)(*s))) {
325 i = 10 * i + (*s - '0');
328 if (*s != 'T') goto parse_error;
331 while (i > 0) { p[n++] = ','; i--; };
345 fprintf ( stderr, "\nstring = `%s'\n", s );
346 internal ( "unZcodeThenFindText: parse error on above string");
347 return NIL; /*notreached*/
351 Text enZcodeThenFindText ( String s )
356 char toHex[16] = "0123456789ABCDEF";
359 nn = 100 + 10 * strlen(s);
361 if (!p) internal ("enZcodeThenFindText: malloc failed");
365 if (n > nn-90) internal ("enZcodeThenFindText: result is too big");
368 && (isalnum((int)(*s)) || *s == '_')) {
376 while (*s && *s==',') { s++; tup++; };
377 if (*s != ')') internal("enZcodeThenFindText: invalid tuple type");
380 sprintf(num,"%d",tup);
381 p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num);
386 case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
387 case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
388 case '[': p[n++] = 'Z'; p[n++] = 'M'; break;
389 case ']': p[n++] = 'Z'; p[n++] = 'N'; break;
390 case ':': p[n++] = 'Z'; p[n++] = 'C'; break;
391 case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break;
392 case 'z': p[n++] = 'z'; p[n++] = 'z'; break;
393 case '&': p[n++] = 'z'; p[n++] = 'a'; break;
394 case '|': p[n++] = 'z'; p[n++] = 'b'; break;
395 case '$': p[n++] = 'z'; p[n++] = 'd'; break;
396 case '=': p[n++] = 'z'; p[n++] = 'e'; break;
397 case '>': p[n++] = 'z'; p[n++] = 'g'; break;
398 case '#': p[n++] = 'z'; p[n++] = 'h'; break;
399 case '.': p[n++] = 'z'; p[n++] = 'i'; break;
400 case '<': p[n++] = 'z'; p[n++] = 'l'; break;
401 case '-': p[n++] = 'z'; p[n++] = 'm'; break;
402 case '!': p[n++] = 'z'; p[n++] = 'n'; break;
403 case '+': p[n++] = 'z'; p[n++] = 'p'; break;
404 case '\'': p[n++] = 'z'; p[n++] = 'q'; break;
405 case '\\': p[n++] = 'z'; p[n++] = 'r'; break;
406 case '/': p[n++] = 'z'; p[n++] = 's'; break;
407 case '*': p[n++] = 'z'; p[n++] = 't'; break;
408 case '^': p[n++] = 'z'; p[n++] = 'u'; break;
409 case '%': p[n++] = 'z'; p[n++] = 'v'; break;
410 default: s--; p[n++] = 'z'; p[n++] = 'x';
411 p[n++] = toHex[(int)(*s)/16];
412 p[n++] = toHex[(int)(*s)%16];
423 Text textOf ( Cell c )
437 fprintf(stderr, "\ntextOf: bad tag %d\n",wot );
438 internal("textOf: bad tag");
443 /* --------------------------------------------------------------------------
446 * Currently, the only attributes that we store for each Ext value is the
447 * corresponding Text label. At some later stage, we may decide to cache
448 * types, predicates, etc. here as a space saving gesture. Given that Text
449 * comparison is cheap, and that this is an experimental implementation, we
450 * will use a straightforward linear search to locate Ext values from their
451 * corresponding Text labels; a hashing scheme can be introduced later if
452 * this turns out to be a problem.
453 * ------------------------------------------------------------------------*/
456 Text DEFTABLE(tabExt,NUM_EXT); /* Storage for Ext names */
459 Ext mkExt(t) /* Allocate or find an Ext value */
465 if (extHw-EXTMIN >= NUM_EXT) {
466 ERRMSG(0) "Ext storage space exhausted"
475 /* --------------------------------------------------------------------------
476 * Expandable symbol tables. A template, which is instantiated for the name,
477 * tycon, class, instance and module tables. Also, potentially, TREX Exts.
478 * ------------------------------------------------------------------------*/
480 #ifdef DEBUG_STORAGE_EXTRA
481 static Bool debugStorageExtra = TRUE;
483 static Bool debugStorageExtra = FALSE;
487 #define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name, \
488 proc_name,free_proc_name, \
489 free_list,tab_name,tab_size,err_msg, \
490 TAB_INIT_SIZE,TAB_MAX_SIZE, \
493 struct struct_name* tab_name = NULL; \
495 static type_name free_list = TAB_BASE_ADDR-1; \
497 void free_proc_name ( type_name n ) \
499 assert(TAB_BASE_ADDR <= n); \
500 assert(n < TAB_BASE_ADDR+tab_size); \
501 assert(tab_name[n-TAB_BASE_ADDR].inUse); \
502 tab_name[n-TAB_BASE_ADDR].inUse = FALSE; \
503 if (!debugStorageExtra) { \
504 tab_name[n-TAB_BASE_ADDR].nextFree = free_list; \
509 type_name proc_name ( void ) \
513 struct struct_name* newTab; \
514 struct struct_name* temp; \
516 if (free_list != TAB_BASE_ADDR-1) { \
517 type_name t = free_list; \
518 free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree; \
519 assert (!(tab_name[t-TAB_BASE_ADDR].inUse)); \
520 tab_name[t-TAB_BASE_ADDR].inUse = TRUE; \
524 newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size); \
525 if (newSz > TAB_MAX_SIZE) goto cant_allocate; \
526 newTab = malloc(newSz * sizeof(struct struct_name)); \
527 if (!newTab) goto cant_allocate; \
528 for (i = 0; i < tab_size; i++) \
529 newTab[i] = tab_name[i]; \
530 for (i = tab_size; i < newSz; i++) { \
531 newTab[i].inUse = FALSE; \
532 newTab[i].nextFree = i-1+TAB_BASE_ADDR; \
534 if (0 && debugStorageExtra) \
535 fprintf(stderr, "Expanding " #type_name \
536 "table to size %d\n", newSz ); \
537 newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \
538 free_list = newSz-1+TAB_BASE_ADDR; \
542 if (temp) free(temp); \
552 EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName,
553 nameFL,tabName,tabNameSz,
554 "Name storage space exhausted",
555 NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR)
558 EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon,
559 tyconFL,tabTycon,tabTyconSz,
560 "Type constructor storage space exhausted",
561 TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR)
564 EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass,
565 classFL,tabClass,tabClassSz,
566 "Class storage space exhausted",
567 CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR)
570 EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst,
571 instFL,tabInst,tabInstSz,
572 "Instance storage space exhausted",
573 INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR)
576 EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule,
577 moduleFL,tabModule,tabModuleSz,
578 "Module storage space exhausted",
579 MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR)
582 struct strName* generate_name_ref ( Cell nm )
585 nm -= NAME_BASE_ADDR;
586 assert(tabName[nm].inUse);
587 assert(isModule(tabName[nm].mod));
588 return & tabName[nm];
590 struct strTycon* generate_tycon_ref ( Cell tc )
592 assert(isTycon(tc) || isTuple(tc));
593 tc -= TYCON_BASE_ADDR;
594 assert(tabTycon[tc].inUse);
595 assert(isModule(tabTycon[tc].mod));
596 return & tabTycon[tc];
598 struct strClass* generate_cclass_ref ( Cell cl )
601 cl -= CCLASS_BASE_ADDR;
602 assert(tabClass[cl].inUse);
603 assert(isModule(tabClass[cl].mod));
604 return & tabClass[cl];
606 struct strInst* generate_inst_ref ( Cell in )
609 in -= INST_BASE_ADDR;
610 assert(tabInst[in].inUse);
611 assert(isModule(tabInst[in].mod));
612 return & tabInst[in];
614 struct strModule* generate_module_ref ( Cell mo )
616 assert(isModule(mo));
617 mo -= MODULE_BASE_ADDR;
618 assert(tabModule[mo].inUse);
619 return & tabModule[mo];
624 /* --------------------------------------------------------------------------
627 * A Tycon represents a user defined type constructor. Tycons are indexed
628 * by Text values ... a very simple hash function is used to improve lookup
629 * times. Tycon entries with the same hash code are chained together, with
630 * the most recent entry at the front of the list.
631 * ------------------------------------------------------------------------*/
633 #define TYCONHSZ 256 /* Size of Tycon hash table*/
634 static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */
636 static int tHash(Text x)
639 assert(isText(x) || inventedText(x));
648 static int RC_T ( int x )
650 assert (x >= 0 && x < TYCONHSZ);
654 Tycon newTycon ( Text t ) /* add new tycon to tycon table */
657 Tycon tc = allocNewTycon();
659 [tc-TYCON_BASE_ADDR].tuple = -1;
661 [tc-TYCON_BASE_ADDR].mod = currentModule;
662 tycon(tc).text = t; /* clear new tycon record */
663 tycon(tc).kind = NIL;
664 tycon(tc).defn = NIL;
665 tycon(tc).what = NIL;
666 tycon(tc).conToTag = NIL;
667 tycon(tc).tagToCon = NIL;
668 tycon(tc).itbl = NULL;
670 tycon(tc).closure = NIL;
671 module(currentModule).tycons = cons(tc,module(currentModule).tycons);
672 tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
673 tyconHash[RC_T(h)] = tc;
677 Tycon findTycon(t) /* locate Tycon in tycon table */
679 Tycon tc = tyconHash[RC_T(tHash(t))];
680 assert(isTycon(tc) || isTuple(tc) || isNull(tc));
681 while (nonNull(tc) && tycon(tc).text!=t)
682 tc = tycon(tc).nextTyconHash;
686 Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
689 assert(isTycon(tc) || isTuple(tc));
690 oldtc = findTycon(tycon(tc).text);
693 module(currentModule).tycons=cons(tc,module(currentModule).tycons);
699 static Void local hashTycon(tc) /* Insert Tycon into hash table */
703 assert(isTycon(tc) || isTuple(tc));
704 {int i; for (i = 0; i < TYCONHSZ; i++)
705 assert (tyconHash[i] == 0
706 || isTycon(tyconHash[i])
707 || isTuple(tyconHash[i]));
711 tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
712 tyconHash[RC_T(h)] = tc;
715 Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
717 if (!isPair(id)) internal("findQualTycon");
721 return findTycon(textOf(id));
723 Text t = qtextOf(id);
724 Module m = findQualifier(qmodOf(id));
726 if (isNull(m)) return NIL;
727 for(es=module(m).exports; nonNull(es); es=tl(es)) {
729 if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
734 default : internal("findQualTycon2");
736 return NIL; /* NOTREACHED */
739 Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
745 Tycon tc = newTycon(t);
747 tycon(tc).kind = kind;
748 tycon(tc).what = what;
749 tycon(tc).defn = defn;
750 tycon(tc).arity = ar;
754 static List local insertTycon(tc,ts) /* insert tycon tc into sorted list*/
759 String s = textToStr(tycon(tc).text);
761 while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
762 if (hd(curr)==tc) /* just in case we get duplicates! */
768 tl(prev) = cons(tc,curr);
772 return cons(tc,curr);
775 List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */
776 String pat; /* to list of Tycons ts */
777 List ts; { /* Null pattern matches every tycon*/
778 Tycon tc; /* (Tycons with NIL kind excluded) */
779 for (tc = TYCON_BASE_ADDR;
780 tc < TYCON_BASE_ADDR+tabTyconSz; ++tc)
781 if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
782 if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
783 if (nonNull(tycon(tc).kind))
784 ts = insertTycon(tc,ts);
788 Text ghcTupleText_n ( Int n )
793 if (n < 0 || n >= 100) internal("ghcTupleText_n");
794 if (n == 1) internal("ghcTupleText_n==1");
796 for (i = 1; i <= n-1; i++) buf[x++] = ',';
799 return findText(buf);
802 Text ghcTupleText(tup)
805 assert(isTuple(tup));
807 return ghcTupleText_n ( tupleOf(tup) );
811 Tycon mkTuple ( Int n )
815 internal("mkTuple: request for tuple of unsupported size");
816 for (i = TYCON_BASE_ADDR;
817 i < TYCON_BASE_ADDR+tabTyconSz; i++)
818 if (tabTycon[i-TYCON_BASE_ADDR].inUse)
819 if (tycon(i).tuple == n) return i;
820 internal("mkTuple: request for non-existent tuple");
824 /* --------------------------------------------------------------------------
827 * A Name represents a top level binding of a value to an identifier.
828 * Such values may be a constructor function, a member function in a
829 * class, a user-defined or primitive value/function.
831 * Names are indexed by Text values ... a very simple hash functions speeds
832 * access to the table of Names and Name entries with the same hash value
833 * are chained together, with the most recent entry at the front of the
835 * ------------------------------------------------------------------------*/
837 #define NAMEHSZ 256 /* Size of Name hash table */
838 static Name nameHash[NAMEHSZ]; /* Hash table storage */
840 static int nHash(Text x)
842 assert(isText(x) || inventedText(x));
850 assert (x >= 0 && x < NAMEHSZ);
854 void hashSanity ( void )
857 for (i = 0; i < TYCONHSZ; i++) {
860 assert(isTycon(j) || isTuple(j));
861 j = tycon(j).nextTyconHash;
864 for (i = 0; i < NAMEHSZ; i++) {
868 j = name(j).nextNameHash;
873 Name newName ( Text t, Cell parent ) /* Add new name to name table */
876 Name nm = allocNewName();
878 [nm-NAME_BASE_ADDR].mod = currentModule;
879 name(nm).text = t; /* clear new name record */
881 name(nm).syntax = NO_SYNTAX;
882 name(nm).parent = parent;
884 name(nm).number = EXECNAME;
886 name(nm).hasStrict = FALSE;
887 name(nm).callconv = NIL;
889 name(nm).primop = NULL;
890 name(nm).itbl = NULL;
891 name(nm).closure = NIL;
892 module(currentModule).names = cons(nm,module(currentModule).names);
893 name(nm).nextNameHash = nameHash[RC_N(h)];
894 nameHash[RC_N(h)] = nm;
898 Name findName(t) /* Locate name in name table */
900 Name n = nameHash[RC_N(nHash(t))];
901 assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
902 assert(isName(n) || isNull(n));
903 while (nonNull(n) && name(n).text!=t)
904 n = name(n).nextNameHash;
908 Name addName(nm) /* Insert Name in name table - if */
909 Name nm; { /* no clash is caused */
912 oldnm = findName(name(nm).text);
915 module(currentModule).names=cons(nm,module(currentModule).names);
921 static Void local hashName(nm) /* Insert Name into hash table */
928 name(nm).nextNameHash = nameHash[RC_N(h)];
929 nameHash[RC_N(h)] = nm;
932 Name findQualName(id) /* Locate (possibly qualified) name*/
933 Cell id; { /* in name table */
935 internal("findQualName");
941 return findName(textOf(id));
943 Text t = qtextOf(id);
944 Module m = findQualifier(qmodOf(id));
946 if (isNull(m)) return NIL;
947 for(es=module(m).exports; nonNull(es); es=tl(es)) {
949 if (isName(e) && name(e).text==t)
951 else if (isPair(e) && DOTDOT==snd(e)) {
952 List subentities = NIL;
955 && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
956 subentities = tycon(c).defn;
958 subentities = cclass(c).members;
959 for(; nonNull(subentities); subentities=tl(subentities)) {
960 if (!isName(hd(subentities)))
961 internal("findQualName3");
962 if (name(hd(subentities)).text == t)
963 return hd(subentities);
969 default : internal("findQualName2");
971 return 0; /* NOTREACHED */
975 void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s )
977 Text t = findText(s);
979 for (n = NAME_BASE_ADDR;
980 n < NAME_BASE_ADDR+tabNameSz; n++)
981 if (tabName[n-NAME_BASE_ADDR].inUse && name(n).text == t)
983 if (n == NAME_BASE_ADDR+tabNameSz) {
984 fprintf ( stderr, "can't find `%s' in ...\n", s );
985 internal("getHugs_BCO_cptr_for(1)");
987 if (!isCPtr(name(n).closure))
988 internal("getHugs_BCO_cptr_for(2)");
989 return cptrOf(name(n).closure);
992 /* --------------------------------------------------------------------------
993 * Primitive functions:
994 * ------------------------------------------------------------------------*/
996 Module findFakeModule ( Text t )
998 Module m = findModule(t);
1000 if (!module(m).fake) internal("findFakeModule");
1003 module(m).fake = TRUE;
1009 Name addWiredInBoxingTycon
1010 ( String modNm, String typeNm, String constrNm,
1011 Int rep, Kind kind )
1015 Text modT = findText(modNm);
1016 Text typeT = findText(typeNm);
1017 Text conT = findText(constrNm);
1018 Module m = findFakeModule(modT);
1021 n = newName(conT,NIL);
1023 name(n).number = cfunNo(0);
1025 name(n).primop = (void*)rep;
1027 t = newTycon(typeT);
1028 tycon(t).what = DATATYPE;
1029 tycon(t).kind = kind;
1034 Tycon addTupleTycon ( Int n )
1042 for (i = TYCON_BASE_ADDR;
1043 i < TYCON_BASE_ADDR+tabTyconSz; i++)
1044 if (tabTycon[i-TYCON_BASE_ADDR].inUse)
1045 if (tycon(i).tuple == n) return i;
1048 m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
1049 m = findModule(findText("PrelPrim"));
1053 for (i = 0; i < n; i++) k = ap(STAR,k);
1054 t = newTycon(ghcTupleText_n(n));
1057 tycon(t).what = DATATYPE;
1060 /* maybe we want to do this for all n ? */
1061 nm = newName(ghcTupleText_n(n), t);
1062 name(nm).type = t; /* ummm ... for n > 0 */
1069 Tycon addWiredInEnumTycon ( String modNm, String typeNm,
1070 List /*of Text*/ constrs )
1074 Text modT = findText(modNm);
1075 Text typeT = findText(typeNm);
1076 Module m = findFakeModule(modT);
1079 t = newTycon(typeT);
1080 tycon(t).kind = STAR;
1081 tycon(t).what = DATATYPE;
1083 constrs = reverse(constrs);
1084 i = length(constrs);
1085 for (; nonNull(constrs); constrs=tl(constrs),i--) {
1086 Text conT = hd(constrs);
1087 Name con = newName(conT,t);
1088 name(con).number = cfunNo(i);
1090 name(con).parent = t;
1091 tycon(t).defn = cons(con, tycon(t).defn);
1097 Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */
1098 Text t; /* sets rep, not type */
1101 Int rep; { /* Really AsmRep */
1102 Name n = newName(t,NIL);
1103 name(n).arity = arity;
1104 name(n).number = cfunNo(no);
1106 name(n).primop = (void*)rep;
1111 Name addPrimCfun(t,arity,no,type) /* add primitive constructor func */
1116 Name n = newName(t,NIL);
1117 name(n).arity = arity;
1118 name(n).number = cfunNo(no);
1119 name(n).type = type;
1124 Int sfunPos(s,c) /* Find position of field with */
1125 Name s; /* selector s in constructor c. */
1129 for (; nonNull(cns); cns=tl(cns))
1130 if (fst(hd(cns))==c)
1131 return intOf(snd(hd(cns)));
1132 internal("sfunPos");
1133 return 0;/* NOTREACHED */
1136 static List local insertName(nm,ns) /* insert name nm into sorted list */
1141 String s = textToStr(name(nm).text);
1143 while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
1144 if (hd(curr)==nm) /* just in case we get duplicates! */
1149 if (nonNull(prev)) {
1150 tl(prev) = cons(nm,curr);
1154 return cons(nm,curr);
1157 List addNamesMatching(pat,ns) /* Add names matching pattern pat */
1158 String pat; /* to list of names ns */
1159 List ns; { /* Null pattern matches every name */
1160 Name nm; /* (Names with NIL type, or hidden */
1161 /* or invented names are excluded) */
1163 for (nm = NAME_BASE_ADDR;
1164 nm < NAME_BASE_ADDR+tabNameSz; ++nm)
1165 if (tabName[nm-NAME_BASE_ADDR].inUse) {
1166 if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
1167 String str = textToStr(name(nm).text);
1168 if (str[0]!='_' && (!pat || stringMatch(pat,str)))
1169 ns = insertName(nm,ns);
1174 List mns = module(currentModule).names;
1175 for(; nonNull(mns); mns=tl(mns)) {
1177 if (!inventedText(name(nm).text)) {
1178 String str = textToStr(name(nm).text);
1179 if (str[0]!='_' && (!pat || stringMatch(pat,str)))
1180 ns = insertName(nm,ns);
1187 /* --------------------------------------------------------------------------
1188 * A simple string matching routine
1189 * `*' matches any sequence of zero or more characters
1190 * `?' matches any single character exactly
1191 * `@str' matches the string str exactly (ignoring any special chars)
1192 * `\c' matches the character c only (ignoring special chars)
1193 * c matches the character c only
1194 * ------------------------------------------------------------------------*/
1196 static Void local patternError(s) /* report error in pattern */
1198 ERRMSG(0) "%s in pattern", s
1202 static Bool local stringMatch(pat,str) /* match string against pattern */
1208 case '\0' : return (*str=='\0');
1211 if (stringMatch(pat+1,str))
1216 case '?' : if (*str++=='\0')
1221 case '[' : { Bool found = FALSE;
1222 while (*++pat!='\0' && *pat!=']')
1223 if (!found && ( pat[0] == *str ||
1232 patternError("missing `]'");
1240 case '\\' : if (*++pat == '\0')
1241 patternError("extra trailing `\\'");
1243 default : if (*pat++ != *str++)
1249 /* --------------------------------------------------------------------------
1250 * Storage of type classes, instances etc...:
1251 * ------------------------------------------------------------------------*/
1253 static List classes; /* list of classes in current scope */
1255 Class newClass ( Text t ) /* add new class to class table */
1257 Class cl = allocNewClass();
1259 [cl-CCLASS_BASE_ADDR].mod = currentModule;
1260 cclass(cl).text = t;
1261 cclass(cl).arity = 0;
1262 cclass(cl).kinds = NIL;
1263 cclass(cl).head = NIL;
1264 cclass(cl).fds = NIL;
1265 cclass(cl).xfds = NIL;
1266 cclass(cl).dcon = NIL;
1267 cclass(cl).supers = NIL;
1268 cclass(cl).dsels = NIL;
1269 cclass(cl).members = NIL;
1270 cclass(cl).defaults = NIL;
1271 cclass(cl).instances = NIL;
1272 classes = cons(cl,classes);
1273 module(currentModule).classes
1274 = cons(cl,module(currentModule).classes);
1278 Class findClass(t) /* look for named class in table */
1282 for (cs=classes; nonNull(cs); cs=tl(cs)) {
1284 if (cclass(cl).text==t)
1290 Class addClass(c) /* Insert Class in class list */
1291 Class c; { /* - if no clash caused */
1293 assert(whatIs(c)==CLASS);
1294 oldc = findClass(cclass(c).text);
1296 classes=cons(c,classes);
1297 module(currentModule).classes=cons(c,module(currentModule).classes);
1304 Class findQualClass(c) /* Look for (possibly qualified) */
1305 Cell c; { /* class in class list */
1306 if (!isQualIdent(c)) {
1307 return findClass(textOf(c));
1309 Text t = qtextOf(c);
1310 Module m = findQualifier(qmodOf(c));
1314 for (es=module(m).exports; nonNull(es); es=tl(es)) {
1316 if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
1323 Inst newInst() { /* Add new instance to table */
1324 Inst in = allocNewInst();
1326 [in-INST_BASE_ADDR].mod = currentModule;
1327 inst(in).kinds = NIL;
1328 inst(in).head = NIL;
1329 inst(in).specifics = NIL;
1330 inst(in).numSpecifics = 0;
1331 inst(in).implements = NIL;
1332 inst(in).builder = NIL;
1337 extern Void printInst ( Inst));
1341 Class cl = inst(in).c;
1342 Printf("%s-", textToStr(cclass(cl).text));
1343 printType(stdout,inst(in).t);
1345 #endif /* DEBUG_DICTS */
1347 Inst findFirstInst(tc) /* look for 1st instance involving */
1348 Tycon tc; { /* the type constructor tc */
1349 return findNextInst(tc,INST_BASE_ADDR-1);
1352 Inst findNextInst(tc,in) /* look for next instance involving*/
1353 Tycon tc; /* the type constructor tc */
1354 Inst in; { /* starting after instance in */
1356 while (++in < INST_BASE_ADDR+tabInstSz) {
1357 if (!tabInst[in-INST_BASE_ADDR].inUse) continue;
1358 assert(isModule(inst(in).mod));
1360 for (; isAp(pi); pi=fun(pi))
1361 if (typeInvolves(arg(pi),tc))
1367 static Bool local typeInvolves(ty,tc) /* Test to see if type ty involves */
1368 Type ty; /* type constructor/tuple tc. */
1371 || (isAp(ty) && (typeInvolves(fun(ty),tc)
1372 || typeInvolves(arg(ty),tc)));
1376 /* Needed by finishGHCInstance to find classes, before the
1377 export list has been built -- so we can't use
1380 Class findQualClassWithoutConsultingExportList ( QualId q )
1390 t_class = textOf(q);
1393 t_class = qtextOf(q);
1396 for (cl = CCLASS_BASE_ADDR;
1397 cl < CCLASS_BASE_ADDR+tabClassSz; cl++) {
1398 if (tabClass[cl-CCLASS_BASE_ADDR].inUse)
1399 if (cclass(cl).text == t_class) {
1400 /* Class name is ok, but is this the right module? */
1401 if (isNull(t_mod) /* no module name specified */
1403 && t_mod == module(cclass(cl).mod).text)
1411 /* Same deal, except for Tycons. */
1412 Tycon findQualTyconWithoutConsultingExportList ( QualId q )
1422 t_tycon = textOf(q);
1425 t_tycon = qtextOf(q);
1428 for (tc = TYCON_BASE_ADDR;
1429 tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
1430 if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
1431 if (tycon(tc).text == t_tycon) {
1432 /* Tycon name is ok, but is this the right module? */
1433 if (isNull(t_mod) /* no module name specified */
1435 && t_mod == module(tycon(tc).mod).text)
1443 /* Same deal, except for Names. */
1444 Name findQualNameWithoutConsultingExportList ( QualId q )
1450 assert(isQVar(q) || isQCon(q));
1452 if (isCon(q) || isVar(q)) {
1457 t_name = qtextOf(q);
1460 for (nm = NAME_BASE_ADDR;
1461 nm < NAME_BASE_ADDR+tabNameSz; nm++) {
1462 if (tabName[nm-NAME_BASE_ADDR].inUse)
1463 if (name(nm).text == t_name) {
1464 /* Name is ok, but is this the right module? */
1465 if (isNull(t_mod) /* no module name specified */
1467 && t_mod == module(name(nm).mod).text)
1476 Tycon findTyconInAnyModule ( Text t )
1479 for (tc = TYCON_BASE_ADDR;
1480 tc < TYCON_BASE_ADDR+tabTyconSz; tc++)
1481 if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
1482 if (tycon(tc).text == t) return tc;
1486 Class findClassInAnyModule ( Text t )
1489 for (cc = CCLASS_BASE_ADDR;
1490 cc < CCLASS_BASE_ADDR+tabClassSz; cc++)
1491 if (tabClass[cc-CCLASS_BASE_ADDR].inUse)
1492 if (cclass(cc).text == t) return cc;
1496 Name findNameInAnyModule ( Text t )
1499 for (nm = NAME_BASE_ADDR;
1500 nm < NAME_BASE_ADDR+tabNameSz; nm++)
1501 if (tabName[nm-NAME_BASE_ADDR].inUse)
1502 if (name(nm).text == t) return nm;
1507 /* returns List of QualId */
1508 List getAllKnownTyconsAndClasses ( void )
1513 for (tc = TYCON_BASE_ADDR;
1514 tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
1515 if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
1516 /* almost certainly undue paranoia about duplicate avoidance */
1517 QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
1518 if (!qualidIsMember(q,xs))
1519 xs = cons ( q, xs );
1522 for (nw = CCLASS_BASE_ADDR;
1523 nw < CCLASS_BASE_ADDR+tabClassSz; nw++) {
1524 if (tabClass[nw-CCLASS_BASE_ADDR].inUse) {
1525 QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
1526 if (!qualidIsMember(q,xs))
1527 xs = cons ( q, xs );
1533 Int numQualifiers ( Type t )
1535 if (isPolyType(t)) t = monotypeOf(t);
1537 return length ( fst(snd(t)) ); else
1542 /* Purely for debugging. */
1543 void locateSymbolByName ( Text t )
1546 for (i = NAME_BASE_ADDR;
1547 i < NAME_BASE_ADDR+tabNameSz; i++)
1548 if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t)
1549 fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR);
1550 for (i = TYCON_BASE_ADDR;
1551 i < TYCON_BASE_ADDR+tabTyconSz; i++)
1552 if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t)
1553 fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR);
1554 for (i = CCLASS_BASE_ADDR;
1555 i < CCLASS_BASE_ADDR+tabClassSz; i++)
1556 if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t)
1557 fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR);
1560 /* --------------------------------------------------------------------------
1563 * Various parts of the system use a stack of cells. Most of the stack
1564 * operations are defined as macros, expanded inline.
1565 * ------------------------------------------------------------------------*/
1567 Cell cellStack[NUM_STACK]; /* Storage for cells on stack */
1568 StackPtr sp; /* stack pointer */
1570 Void hugsStackOverflow() { /* Report stack overflow */
1571 ERRMSG(0) "Control stack overflow"
1576 /* --------------------------------------------------------------------------
1579 * A Module represents a user defined module.
1581 * Note: there are now two lookup mechanisms in the system:
1583 * 1) The exports from a module are stored in a big list.
1584 * We resolve qualified names, and import lists by linearly scanning
1585 * through this list.
1587 * 2) Unqualified imports and local definitions for the current module
1588 * are stored in hash tables (tyconHash and nameHash) or linear lists
1591 * ------------------------------------------------------------------------*/
1593 Module currentModule; /* Module currently being processed*/
1595 Bool isValidModule(m) /* is m a legitimate module id? */
1600 Module newModule ( Text t ) /* add new module to module table */
1602 Module mod = allocNewModule();
1603 module(mod).text = t; /* clear new module record */
1605 module(mod).tycons = NIL;
1606 module(mod).names = NIL;
1607 module(mod).classes = NIL;
1608 module(mod).exports = NIL;
1609 module(mod).qualImports = NIL;
1610 module(mod).codeList = NIL;
1611 module(mod).fake = FALSE;
1613 module(mod).tree = NIL;
1614 module(mod).completed = FALSE;
1615 module(mod).lastStamp = 0; /* ???? */
1617 module(mod).mode = NIL;
1618 module(mod).srcExt = findText("");
1619 module(mod).uses = NIL;
1621 module(mod).objName = findText("");
1622 module(mod).objSize = 0;
1624 module(mod).object = NULL;
1625 module(mod).objectExtras = NULL;
1626 module(mod).objectExtraNames = NIL;
1631 Bool nukeModule_needs_major_gc = TRUE;
1633 void nukeModule ( Module m )
1639 if (!isModule(m)) internal("nukeModule");
1641 /* fprintf ( stderr, "NUKE MODULE %s\n", textToStr(module(m).text) ); */
1643 /* see comment in compiler.c about this,
1644 and interaction with info tables */
1645 if (nukeModule_needs_major_gc) {
1646 /* fprintf ( stderr, "doing major GC in nukeModule\n"); */
1647 /* performMajorGC(); */
1648 nukeModule_needs_major_gc = FALSE;
1651 oc = module(m).object;
1657 oc = module(m).objectExtras;
1664 for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++)
1665 if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) {
1667 module(name(i).mod).mode == FM_SOURCE) {
1670 name(i).itbl = NULL;
1671 name(i).closure = NIL;
1675 for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++)
1676 if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) {
1677 if (tycon(i).itbl &&
1678 module(tycon(i).mod).mode == FM_SOURCE) {
1679 free(tycon(i).itbl);
1681 tycon(i).itbl = NULL;
1685 for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++)
1686 if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
1687 if (cclass(i).mod == m) {
1690 List /* Inst */ ins;
1691 List /* Inst */ ins2 = NIL;
1692 for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins))
1693 if (inst(hd(ins)).mod != m)
1694 ins2 = cons(hd(ins),ins2);
1695 cclass(i).instances = ins2;
1700 for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++)
1701 if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m)
1705 //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0;
1706 //for (i = 0; i < NAMEHSZ; i++) nameHash[i] = 0;
1711 void ppModules ( void )
1714 fflush(stderr); fflush(stdout);
1715 printf ( "begin MODULES\n" );
1716 for (i = MODULE_BASE_ADDR+tabModuleSz-1;
1717 i >= MODULE_BASE_ADDR; i--)
1718 if (tabModule[i-MODULE_BASE_ADDR].inUse)
1719 printf ( " %2d: %16s\n",
1720 i-MODULE_BASE_ADDR, textToStr(module(i).text)
1722 printf ( "end MODULES\n" );
1723 fflush(stderr); fflush(stdout);
1727 Module findModule(t) /* locate Module in module table */
1730 for(m = MODULE_BASE_ADDR;
1731 m < MODULE_BASE_ADDR+tabModuleSz; ++m) {
1732 if (tabModule[m-MODULE_BASE_ADDR].inUse)
1733 if (module(m).text==t)
1739 Module findModid(c) /* Find module by name or filename */
1741 switch (whatIs(c)) {
1742 case STRCELL : internal("findModid-STRCELL unimp");
1743 case CONIDCELL : return findModule(textOf(c));
1744 default : internal("findModid");
1746 return NIL;/*NOTUSED*/
1749 static local Module findQualifier(t) /* locate Module in import list */
1752 for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
1753 if (textOf(fst(hd(ms)))==t)
1756 if (module(currentModule).text==t)
1757 return currentModule;
1761 Void setCurrModule(m) /* set lookup tables for current module */
1764 assert(isModule(m));
1765 /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
1767 for (t = module(m).names; nonNull(t); t=tl(t))
1768 assert(isName(hd(t)));
1769 for (t = module(m).tycons; nonNull(t); t=tl(t))
1770 assert(isTycon(hd(t)) || isTuple(hd(t)));
1771 for (t = module(m).classes; nonNull(t); t=tl(t))
1772 assert(isClass(hd(t)));
1775 currentModule = m; /* This is the only assignment to currentModule */
1776 for (i=0; i<TYCONHSZ; ++i)
1777 tyconHash[RC_T(i)] = NIL;
1778 mapProc(hashTycon,module(m).tycons);
1779 for (i=0; i<NAMEHSZ; ++i)
1780 nameHash[RC_N(i)] = NIL;
1781 mapProc(hashName,module(m).names);
1782 classes = module(m).classes;
1786 void addToCodeList ( Module m, Cell c )
1788 assert(isName(c) || isTuple(c));
1789 if (nonNull(getNameOrTupleClosure(c)))
1790 module(m).codeList = cons ( c, module(m).codeList );
1791 /* fprintf ( stderr, "addToCodeList %s %s\n",
1792 textToStr(module(m).text),
1793 textToStr( isTuple(c) ? tycon(c).text : name(c).text ) );
1797 Cell getNameOrTupleClosure ( Cell c )
1799 if (isName(c)) return name(c).closure;
1800 else if (isTuple(c)) return tycon(c).closure;
1801 else internal("getNameOrTupleClosure");
1804 void setNameOrTupleClosure ( Cell c, Cell closure )
1806 if (isName(c)) name(c).closure = closure;
1807 else if (isTuple(c)) tycon(c).closure = closure;
1808 else internal("setNameOrTupleClosure");
1811 /* This function is used in ghc/rts/Assembler.c. */
1812 void* /* StgClosure* */ getNameOrTupleClosureCPtr ( Cell c )
1814 return cptrOf(getNameOrTupleClosure(c));
1817 /* used in codegen.c */
1818 void setNameOrTupleClosureCPtr ( Cell c, void* /* StgClosure* */ cptr )
1820 if (isName(c)) name(c).closure = mkCPtr(cptr);
1821 else if (isTuple(c)) tycon(c).closure = mkCPtr(cptr);
1822 else internal("setNameOrTupleClosureCPtr");
1827 Name jrsFindQualName ( Text mn, Text sn )
1832 for (m = MODULE_BASE_ADDR;
1833 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1834 if (tabModule[m-MODULE_BASE_ADDR].inUse
1835 && module(m).text == mn) break;
1837 if (m == MODULE_BASE_ADDR+tabModuleSz) return NIL;
1839 for (ns = module(m).names; nonNull(ns); ns=tl(ns))
1840 if (name(hd(ns)).text == sn) return hd(ns);
1846 char* nameFromOPtr ( void* p )
1850 for (m = MODULE_BASE_ADDR;
1851 m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1852 if (tabModule[m-MODULE_BASE_ADDR].inUse && module(m).object) {
1853 char* nm = ocLookupAddr ( module(m).object, p );
1858 /* A kludge to assist Win32 debugging; not actually necessary. */
1859 { char* nm = nameFromStaticOPtr(p);
1867 void* lookupOTabName ( Module m, char* sym )
1869 assert(isModule(m));
1870 if (module(m).object)
1871 return ocLookupSym ( module(m).object, sym );
1876 void* lookupOExtraTabName ( char* sym )
1880 for (m = MODULE_BASE_ADDR;
1881 m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1882 if (tabModule[m-MODULE_BASE_ADDR].inUse)
1883 for (oc = module(m).objectExtras; oc; oc=oc->next) {
1884 void* ad = ocLookupSym ( oc, sym );
1892 /* Only call this if in dire straits; searches every object symtab
1893 in the system -- so is therefore slow.
1895 void* lookupOTabNameAbsolutelyEverywhere ( char* sym )
1900 for (m = MODULE_BASE_ADDR;
1901 m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1902 if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1903 if (module(m).object) {
1904 ad = ocLookupSym ( module(m).object, sym );
1907 for (oc = module(m).objectExtras; oc; oc=oc->next) {
1908 ad = ocLookupSym ( oc, sym );
1917 OSectionKind lookupSection ( void* ad )
1925 if (!combined) return HUGS_SECTIONKIND_OTHER;
1927 for (m = MODULE_BASE_ADDR;
1928 m < MODULE_BASE_ADDR+tabModuleSz; m++) {
1929 if (tabModule[m-MODULE_BASE_ADDR].inUse) {
1930 if (tabModule[m-MODULE_BASE_ADDR].object) {
1931 sect = ocLookupSection ( tabModule[m-MODULE_BASE_ADDR].object, ad );
1932 if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1935 for (oc = tabModule[m-MODULE_BASE_ADDR].objectExtras; oc; oc=oc->next) {
1936 sect = ocLookupSection ( oc, ad );
1937 if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
1942 return HUGS_SECTIONKIND_OTHER;
1946 /* Called by the evaluator's GC to tell Hugs to mark stuff in the
1949 void markHugsObjects( void )
1954 for ( nm = NAME_BASE_ADDR;
1955 nm < NAME_BASE_ADDR+tabNameSz; ++nm ) {
1956 if (tabName[nm-NAME_BASE_ADDR].inUse) {
1957 Cell cl = tabName[nm-NAME_BASE_ADDR].closure;
1960 snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1965 for ( tc = TYCON_BASE_ADDR;
1966 tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) {
1967 if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
1968 Cell cl = tabTycon[tc-TYCON_BASE_ADDR].closure;
1971 snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
1978 /* --------------------------------------------------------------------------
1981 * Provides a garbage collectable heap for storage of expressions etc.
1983 * Now incorporates a flat resource: A two-space collected extension of
1984 * the heap that provides storage for contiguous arrays of Cell storage,
1985 * cooperating with the garbage collection mechanisms for the main heap.
1986 * ------------------------------------------------------------------------*/
1988 Int heapSize = DEFAULTHEAP; /* number of cells in heap */
1989 Heap heapFst; /* array of fst component of pairs */
1990 Heap heapSnd; /* array of snd component of pairs */
1993 Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
1994 /* C stack; use with extreme care! */
1997 Int numGcs; /* number of garbage collections */
1998 Int cellsRecovered; /* number of cells recovered */
2000 static Cell freeList; /* free list of unused cells */
2001 static Cell lsave, rsave; /* save components of pair */
2005 static Int markCount, stackRoots;
2007 #define initStackRoots() stackRoots = 0
2008 #define recordStackRoot() stackRoots++
2021 #define start() markCount = 0
2022 #define end(thing,rs) \
2024 Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
2027 #define recordMark() markCount++
2029 #else /* !GC_STATISTICS */
2034 #define initStackRoots()
2035 #define recordStackRoot()
2038 #define end(thing,root)
2039 #define recordMark()
2041 #endif /* !GC_STATISTICS */
2043 Cell pair(l,r) /* Allocate pair (l, r) from */
2044 Cell l, r; { /* heap, garbage collecting first */
2045 Cell c = freeList; /* if necessary ... */
2056 freeList = snd(freeList);
2064 static Int marksSize;
2066 void mark ( Cell root )
2069 Cell mstack[NUM_MSTACK];
2073 mstack[++msp] = root;
2076 if (msp > msp_max) msp_max = msp;
2078 if (!isGenPair(c)) continue;
2079 if (fst(c)==FREECELL) continue;
2081 register int place = placeInSet(c);
2082 register int mask = maskInSet(c);
2083 if (!(marks[place]&mask)) {
2084 marks[place] |= mask;
2085 if (msp >= NUM_MSTACK-5) {
2087 "hugs: fatal stack overflow during GC. "
2088 "Increase NUM_MSTACK.\n" );
2091 mstack[++msp] = fst(c);
2092 mstack[++msp] = snd(c);
2096 // fprintf(stderr, "%d ",msp_max);
2100 Void garbageCollect() { /* Run garbage collector ... */
2101 /* disable break checking */
2106 jmp_buf regs; /* save registers on stack */
2107 HugsBreakAction oldBrk
2108 = setBreakAction ( HugsIgnoreBreak );
2114 for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
2117 everybody(MARK); /* Mark all components of system */
2119 gcScanning(); /* scan mark set */
2126 for (i=1; i<=heapSize; i++) {
2127 if ((marks[place] & mask) == 0) {
2134 if (++j == bitsPerWord) {
2141 gcRecovered(recovered);
2142 setBreakAction ( oldBrk );
2146 #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
2147 /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
2150 /* can only return if freeList is nonempty on return. */
2151 if (recovered<minRecovery || isNull(freeList)) {
2152 ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
2155 cellsRecovered = recovered;
2158 /* --------------------------------------------------------------------------
2159 * Code for saving last expression entered:
2161 * This is a little tricky because some text values (e.g. strings or variable
2162 * names) may not be defined or have the same value when the expression is
2163 * recalled. These text values are therefore saved in the top portion of
2165 * ------------------------------------------------------------------------*/
2167 static Cell lastExprSaved; /* last expression to be saved */
2169 Void setLastExpr(e) /* save expression for later recall*/
2171 lastExprSaved = NIL; /* in case attempt to save fails */
2172 savedText = TEXT_SIZE;
2173 lastExprSaved = lowLevelLastIn(e);
2176 static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */
2177 Cell c; { /* acyclic graph) for later recall */
2178 if (isPair(c)) { /* Duplicating any text strings */
2179 if (isTagNonPtr(fst(c))) /* in case these are lost at some */
2180 switch (fst(c)) { /* point before the expr is reused */
2186 case STRCELL : return pair(fst(c),saveText(textOf(c)));
2187 default : return pair(fst(c),snd(c));
2190 return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
2194 return pair(EXTCOPY,saveText(extText(c)));
2200 Cell getLastExpr() { /* recover previously saved expr */
2201 return lowLevelLastOut(lastExprSaved);
2204 static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */
2205 Cell c; { /* except that Cells refering to */
2206 if (isPair(c)) { /* Text values are restored to */
2207 if (isTagNonPtr(fst(c))) /* appropriate values */
2214 case STRCELL : return pair(fst(c),
2215 findText(text+intValOf(c)));
2217 case EXTCOPY : return mkExt(findText(text+intValOf(c)));
2219 default : return pair(fst(c),snd(c));
2222 return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
2228 /* --------------------------------------------------------------------------
2229 * Miscellaneous operations on heap cells:
2230 * ------------------------------------------------------------------------*/
2232 /* Reordered 2 May 00 to have most common options first. */
2233 Cell whatIs ( register Cell c )
2236 register Cell fstc = fst(c);
2237 return isTag(fstc) ? fstc : AP;
2239 if (isTycon(c)) return TYCON;
2240 if (isOffset(c)) return OFFSET;
2241 if (isName(c)) return NAME;
2242 if (isInt(c)) return INTCELL;
2243 if (isTuple(c)) return TUPLE;
2244 if (isSpec(c)) return c;
2245 if (isClass(c)) return CLASS;
2246 if (isChar(c)) return CHARCELL;
2247 if (isNull(c)) return c;
2248 if (isInst(c)) return INSTANCE;
2249 if (isModule(c)) return MODULE;
2250 if (isText(c)) return TEXTCELL;
2251 if (isInventedVar(c)) return INVAR;
2252 if (isInventedDictVar(c)) return INDVAR;
2253 fprintf ( stderr, "whatIs: unknown %d\n", c );
2259 /* A very, very simple printer.
2260 * Output is uglier than from printExp - but the printer is more
2261 * robust and can be used on any data structure irrespective of
2264 Void print ( Cell c, Int depth )
2269 else if (isNull(c)) {
2272 else if (isTagPtr(c)) {
2273 Printf("TagP(%d)", c);
2275 else if (isTagNonPtr(c)) {
2276 Printf("TagNP(%d)", c);
2278 else if (isSpec(c) && c != STAR) {
2279 Printf("TagS(%d)", c);
2281 else if (isText(c)) {
2282 Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c));
2284 else if (isInventedVar(c)) {
2285 Printf("invented(%d)", c-INVAR_BASE_ADDR);
2287 else if (isInventedDictVar(c)) {
2288 Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR);
2291 Int tag = whatIs(c);
2295 print(fst(c), depth-1);
2297 print(snd(c), depth-1);
2301 Printf("free(%d)", c);
2304 Printf("int(%d)", intOf(c));
2307 Printf("bignum(%s)", bignumToString(c));
2310 Printf("char('%c')", charOf(c));
2313 Printf("strcell(\"%s\")",textToStr(snd(c)));
2316 Printf("mptr(%p)",mptrOf(c));
2319 Printf("cptr(%p)",cptrOf(c));
2322 Printf("addr(%p)",addrOf(c));
2325 Printf("class(%d)", c-CCLASS_BASE_ADDR);
2326 Printf("=\"%s\"", textToStr(cclass(c).text));
2329 Printf("instance(%d)", c - INST_BASE_ADDR);
2332 Printf("name(%d)", c-NAME_BASE_ADDR);
2333 Printf("=\"%s\"", textToStr(name(c).text));
2336 Printf("tycon(%d)", c-TYCON_BASE_ADDR);
2337 Printf("=\"%s\"", textToStr(tycon(c).text));
2340 Printf("module(%d)", c - MODULE_BASE_ADDR);
2341 Printf("=\"%s\"", textToStr(module(c).text));
2344 Printf("Offset %d", offsetOf(c));
2347 Printf("%s", textToStr(ghcTupleText(c)));
2351 print(snd(c),depth-1);
2355 print(snd(c),depth-1);
2359 if (isPair(snd(c)) && isInt(fst(snd(c)))) {
2360 Printf("%d ", intOf(fst(snd(c))));
2361 print(snd(snd(c)),depth-1);
2363 print(snd(c),depth-1);
2377 Printf("{dict %d}",textOf(c));
2383 Printf("{id %s}",textToStr(textOf(c)));
2387 Printf("{ip %s}",textToStr(textOf(c)));
2390 Printf("?%s",textToStr(textOf(c)));
2394 Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
2398 print(fst(snd(c)),depth-1);
2400 print(snd(snd(c)),depth-1);
2405 print(snd(c),depth-1);
2410 print(snd(c),depth-1);
2415 print(fst(snd(c)),depth-1);
2417 print(snd(snd(c)),depth-1);
2422 print(fst(snd(c)),depth-1);
2424 print(snd(snd(c)),depth-1);
2428 Printf("FromQual(");
2429 print(fst(snd(c)),depth-1);
2431 print(snd(snd(c)),depth-1);
2435 Printf("StgVar%d=",-c);
2436 print(snd(c), depth-1);
2440 print(fst(snd(c)),depth-1);
2442 print(snd(snd(c)),depth-1);
2447 print(fst(snd(c)),depth-1);
2449 print(snd(snd(c)),depth-1);
2454 print(fst(snd(c)),depth-1);
2456 print(snd(snd(c)),depth-1);
2460 Printf("PrimCase(");
2461 print(fst(snd(c)),depth-1);
2463 print(snd(snd(c)),depth-1);
2468 print(snd(c),depth-1);
2472 Printf("(UNBOXEDTUP,");
2473 print(snd(c),depth-1);
2478 print(zfst(c),depth-1);
2480 print(zsnd(c),depth-1);
2484 Printf("<ZTriple ");
2485 print(zfst3(c),depth-1);
2487 print(zsnd3(c),depth-1);
2489 print(zthd3(c),depth-1);
2494 print(snd(c),depth-1);
2498 if (isTagNonPtr(tag)) {
2499 Printf("(TagNP=%d,%d)", c, tag);
2500 } else if (isTagPtr(tag)) {
2501 Printf("(TagP=%d,",tag);
2502 print(snd(c), depth-1);
2505 } else if (c == tag) {
2506 Printf("Tag(%d)", c);
2508 Printf("Tag(%d)=%d", c, tag);
2517 Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */
2518 Cell c; { /* also recognises DICTVAR cells */
2520 (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
2523 Bool isCon(c) /* is cell a CONIDCELL/CONOPCELL ? */
2525 return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
2528 Bool isQVar(c) /* is cell a [un]qualified varop/id? */
2530 if (!isPair(c)) return FALSE;
2533 case VAROPCELL : return TRUE;
2535 case QUALIDENT : return isVar(snd(snd(c)));
2537 default : return FALSE;
2541 Bool isQCon(c) /*is cell a [un]qualified conop/id? */
2543 if (!isPair(c)) return FALSE;
2546 case CONOPCELL : return TRUE;
2548 case QUALIDENT : return isCon(snd(snd(c)));
2550 default : return FALSE;
2554 Bool isQualIdent(c) /* is cell a qualified identifier? */
2556 return isPair(c) && (fst(c)==QUALIDENT);
2559 Bool eqQualIdent ( QualId c1, QualId c2 )
2561 assert(isQualIdent(c1));
2562 if (!isQualIdent(c2)) {
2563 assert(isQualIdent(c2));
2565 return qmodOf(c1)==qmodOf(c2) &&
2566 qtextOf(c1)==qtextOf(c2);
2569 Bool isIdent(c) /* is cell an identifier? */
2571 if (!isPair(c)) return FALSE;
2576 case CONOPCELL : return TRUE;
2578 case QUALIDENT : return TRUE;
2580 default : return FALSE;
2584 Bool isInt(c) /* cell holds integer value? */
2586 return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
2589 Int intOf(c) /* find integer value of cell? */
2592 return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO);
2595 Cell mkInt(n) /* make cell representing integer */
2597 return (SMALL_INT_MIN <= SMALL_INT_ZERO+n &&
2598 SMALL_INT_ZERO+n <= SMALL_INT_MAX)
2603 #if SIZEOF_VOID_P == SIZEOF_INT
2605 typedef union {Int i; Ptr p;} IntOrPtr;
2612 return pair(ADDRCELL,x.i);
2619 assert(fst(c) == ADDRCELL);
2629 return pair(MPTRCELL,x.i);
2636 assert(fst(c) == MPTRCELL);
2646 return pair(CPTRCELL,x.i);
2653 assert(fst(c) == CPTRCELL);
2658 #elif SIZEOF_VOID_P == 2*SIZEOF_INT
2660 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
2667 return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2674 assert(fst(c) == PTRCELL);
2675 x.i.i1 = intOf(fst(snd(c)));
2676 x.i.i2 = intOf(snd(snd(c)));
2685 return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
2692 assert(fst(c) == CPTRCELL);
2693 x.i.i1 = intOf(fst(snd(c)));
2694 x.i.i2 = intOf(snd(snd(c)));
2700 #error "Can't implement mkPtr/ptrOf on this architecture."
2705 String stringNegate( s )
2713 strcpy(&t[1],s); /* ToDo: use strncpy instead */
2718 /* --------------------------------------------------------------------------
2720 * ------------------------------------------------------------------------*/
2722 Int length(xs) /* calculate length of list xs */
2725 for (; nonNull(xs); ++n)
2730 List appendOnto(xs,ys) /* Destructively prepend xs onto */
2731 List xs, ys; { /* ys by modifying xs ... */
2736 while (nonNull(tl(zs)))
2743 List dupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
2746 for (; nonNull(xs); xs=tl(xs))
2747 ys = cons(hd(xs),ys);
2751 List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
2754 return revOnto(dupOnto(xs,NIL),ys);
2757 List dupList(xs) /* Duplicate spine of list xs */
2760 for (; nonNull(xs); xs=tl(xs))
2761 ys = cons(hd(xs),ys);
2765 List revOnto(xs,ys) /* Destructively reverse elements of*/
2766 List xs, ys; { /* list xs onto list ys... */
2769 while (nonNull(xs)) {
2778 QualId qualidIsMember ( QualId q, List xs )
2780 for (; nonNull(xs); xs=tl(xs)) {
2781 if (eqQualIdent(q, hd(xs)))
2787 Cell varIsMember(t,xs) /* Test if variable is a member of */
2788 Text t; /* given list of variables */
2790 assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
2791 for (; nonNull(xs); xs=tl(xs))
2792 if (t==textOf(hd(xs)))
2797 Name nameIsMember(t,ns) /* Test if name with text t is a */
2798 Text t; /* member of list of names xs */
2800 for (; nonNull(ns); ns=tl(ns))
2801 if (t==name(hd(ns)).text)
2806 Cell intIsMember(n,xs) /* Test if integer n is member of */
2807 Int n; /* given list of integers */
2809 for (; nonNull(xs); xs=tl(xs))
2810 if (n==intOf(hd(xs)))
2815 Cell cellIsMember(x,xs) /* Test for membership of specific */
2816 Cell x; /* cell x in list xs */
2818 for (; nonNull(xs); xs=tl(xs))
2824 Cell cellAssoc(c,xs) /* Lookup cell in association list */
2827 for (; nonNull(xs); xs=tl(xs))
2833 Cell cellRevAssoc(c,xs) /* Lookup cell in range of */
2834 Cell c; /* association lists */
2836 for (; nonNull(xs); xs=tl(xs))
2842 List replicate(n,x) /* create list of n copies of x */
2851 List diffList(from,take) /* list difference: from\take */
2852 List from, take; { /* result contains all elements of */
2853 List result = NIL; /* `from' not appearing in `take' */
2855 while (nonNull(from)) {
2856 List next = tl(from);
2857 if (!cellIsMember(hd(from),take)) {
2866 List deleteCell(xs, y) /* copy xs deleting pointers to y */
2870 for(;nonNull(xs);xs=tl(xs)) {
2873 result=cons(x,result);
2879 List take(n,xs) /* destructively truncate list to */
2880 Int n; /* specified length */
2886 while (1<n-- && nonNull(xs))
2893 List splitAt(n,xs) /* drop n things from front of list*/
2902 Cell nth(n,xs) /* extract n'th element of list */
2905 for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
2912 List removeCell(x,xs) /* destructively remove cell from */
2917 return tl(xs); /* element at front of list */
2921 for (; nonNull(curr); prev=curr, curr=tl(prev))
2923 tl(prev) = tl(curr);
2924 return xs; /* element in middle of list */
2928 return xs; /* here if element not found */
2931 List nubList(xs) /* nuke dups in list */
2932 List xs; { /* non destructive */
2934 for (; nonNull(xs); xs=tl(xs))
2935 if (isNull(cellIsMember(hd(xs),outs)))
2936 outs = cons(hd(xs),outs);
2942 /* --------------------------------------------------------------------------
2943 * Tagged tuples (experimental)
2944 * ------------------------------------------------------------------------*/
2946 static void z_tag_check ( Cell x, int tag, char* caller )
2950 sprintf(buf,"z_tag_check(%s): null\n", caller);
2953 if (whatIs(x) != tag) {
2955 "z_tag_check(%s): tag was %d, expected %d\n",
2956 caller, whatIs(x), tag );
2961 Cell zpair ( Cell x1, Cell x2 )
2962 { return ap(ZTUP2,ap(x1,x2)); }
2963 Cell zfst ( Cell zpair )
2964 { z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
2965 Cell zsnd ( Cell zpair )
2966 { z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
2968 Cell ztriple ( Cell x1, Cell x2, Cell x3 )
2969 { return ap(ZTUP3,ap(x1,ap(x2,x3))); }
2970 Cell zfst3 ( Cell zpair )
2971 { z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
2972 Cell zsnd3 ( Cell zpair )
2973 { z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
2974 Cell zthd3 ( Cell zpair )
2975 { z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
2977 Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
2978 { return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
2979 Cell zsel14 ( Cell zpair )
2980 { z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
2981 Cell zsel24 ( Cell zpair )
2982 { z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
2983 Cell zsel34 ( Cell zpair )
2984 { z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
2985 Cell zsel44 ( Cell zpair )
2986 { z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
2988 Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
2989 { return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
2990 Cell zsel15 ( Cell zpair )
2991 { z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
2992 Cell zsel25 ( Cell zpair )
2993 { z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
2994 Cell zsel35 ( Cell zpair )
2995 { z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
2996 Cell zsel45 ( Cell zpair )
2997 { z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
2998 Cell zsel55 ( Cell zpair )
2999 { z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
3002 Cell unap ( int tag, Cell c )
3005 if (whatIs(c) != tag) {
3006 sprintf(buf, "unap: specified %d, actual %d\n",
3013 /* --------------------------------------------------------------------------
3014 * Operations on applications:
3015 * ------------------------------------------------------------------------*/
3017 Int argCount; /* number of args in application */
3019 Cell getHead(e) /* get head cell of application */
3020 Cell e; { /* set number of args in argCount */
3021 for (argCount=0; isAp(e); e=fun(e))
3026 List getArgs(e) /* get list of arguments in function*/
3027 Cell e; { /* application: */
3028 List as; /* getArgs(f e1 .. en) = [e1,..,en] */
3030 for (as=NIL; isAp(e); e=fun(e))
3031 as = cons(arg(e),as);
3035 Cell nthArg(n,e) /* return nth arg in application */
3036 Int n; /* of function to m args (m>=n) */
3037 Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
3038 for (n=numArgs(e)-n-1; n>0; n--)
3043 Int numArgs(e) /* find number of arguments to expr */
3046 for (n=0; isAp(e); e=fun(e))
3051 Cell applyToArgs(f,args) /* destructively apply list of args */
3052 Cell f; /* to function f */
3054 while (nonNull(args)) {
3055 Cell temp = tl(args);
3056 tl(args) = hd(args);
3064 /* --------------------------------------------------------------------------
3066 * ------------------------------------------------------------------------*/
3068 /* Given the address of an info table, find the constructor/tuple
3069 that it belongs to, and return the name. Only needed for debugging.
3071 char* lookupHugsItblName ( void* v )
3074 for (i = TYCON_BASE_ADDR;
3075 i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3076 if (tabTycon[i-TYCON_BASE_ADDR].inUse
3077 && tycon(i).itbl == v)
3078 return textToStr(tycon(i).text);
3080 for (i = NAME_BASE_ADDR;
3081 i < NAME_BASE_ADDR+tabNameSz; ++i) {
3082 if (tabName[i-NAME_BASE_ADDR].inUse
3083 && name(i).itbl == v)
3084 return textToStr(name(i).text);
3089 static String maybeModuleStr ( Module m )
3091 if (isModule(m)) return textToStr(module(m).text); else return "??";
3094 static String maybeNameStr ( Name n )
3096 if (isName(n)) return textToStr(name(n).text); else return "??";
3099 static String maybeTyconStr ( Tycon t )
3101 if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
3104 static String maybeClassStr ( Class c )
3106 if (isClass(c)) return textToStr(cclass(c).text); else return "??";
3109 static String maybeText ( Text t )
3111 if (isNull(t)) return "(nil)";
3112 return textToStr(t);
3115 static void print100 ( Int x )
3117 print ( x, 100); printf("\n");
3120 void dumpTycon ( Int t )
3122 if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR;
3124 printf ( "dumpTycon %d: not a tycon\n", t);
3128 printf ( " text: %s\n", textToStr(tycon(t).text) );
3129 printf ( " line: %d\n", tycon(t).line );
3130 printf ( " mod: %s\n", maybeModuleStr(tycon(t).mod));
3131 printf ( " tuple: %d\n", tycon(t).tuple);
3132 printf ( " arity: %d\n", tycon(t).arity);
3133 printf ( " kind: "); print100(tycon(t).kind);
3134 printf ( " what: %d\n", tycon(t).what);
3135 printf ( " defn: "); print100(tycon(t).defn);
3136 printf ( " cToT: %d %s\n", tycon(t).conToTag,
3137 maybeNameStr(tycon(t).conToTag));
3138 printf ( " tToC: %d %s\n", tycon(t).tagToCon,
3139 maybeNameStr(tycon(t).tagToCon));
3140 printf ( " itbl: %p\n", tycon(t).itbl);
3141 printf ( " nextTH: %d %s\n", tycon(t).nextTyconHash,
3142 maybeTyconStr(tycon(t).nextTyconHash));
3146 void dumpName ( Int n )
3148 if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR;
3150 printf ( "dumpName %d: not a name\n", n);
3154 printf ( " text: %s\n", textToStr(name(n).text) );
3155 printf ( " line: %d\n", name(n).line );
3156 printf ( " mod: %s\n", maybeModuleStr(name(n).mod));
3157 printf ( " syntax: %d\n", name(n).syntax );
3158 printf ( " parent: %d\n", name(n).parent );
3159 printf ( " arity: %d\n", name(n).arity );
3160 printf ( " number: %d\n", name(n).number );
3161 printf ( " type: "); print100(name(n).type);
3162 printf ( " defn: %d\n", name(n).defn );
3163 printf ( " cconv: %d\n", name(n).callconv );
3164 printf ( " primop: %p\n", name(n).primop );
3165 printf ( " itbl: %p\n", name(n).itbl );
3166 printf ( " closure: %d\n", name(n).closure );
3167 printf ( " nextNH: %d\n", name(n).nextNameHash );
3172 void dumpClass ( Int c )
3174 if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR;
3176 printf ( "dumpClass %d: not a class\n", c);
3180 printf ( " text: %s\n", textToStr(cclass(c).text) );
3181 printf ( " line: %d\n", cclass(c).line );
3182 printf ( " mod: %s\n", maybeModuleStr(cclass(c).mod));
3183 printf ( " arity: %d\n", cclass(c).arity );
3184 printf ( " level: %d\n", cclass(c).level );
3185 printf ( " kinds: "); print100( cclass(c).kinds );
3186 printf ( " fds: %d\n", cclass(c).fds );
3187 printf ( " xfds: %d\n", cclass(c).xfds );
3188 printf ( " head: "); print100( cclass(c).head );
3189 printf ( " dcon: "); print100( cclass(c).dcon );
3190 printf ( " supers: "); print100( cclass(c).supers );
3191 printf ( " #supers: %d\n", cclass(c).numSupers );
3192 printf ( " dsels: "); print100( cclass(c).dsels );
3193 printf ( " members: "); print100( cclass(c).members );
3194 printf ( "#members: %d\n", cclass(c).numMembers );
3195 printf ( "defaults: "); print100( cclass(c).defaults );
3196 printf ( " insts: "); print100( cclass(c).instances );
3201 void dumpInst ( Int i )
3203 if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR;
3205 printf ( "dumpInst %d: not an instance\n", i);
3209 printf ( " class: %s\n", maybeClassStr(inst(i).c) );
3210 printf ( " line: %d\n", inst(i).line );
3211 printf ( " mod: %s\n", maybeModuleStr(inst(i).mod));
3212 printf ( " kinds: "); print100( inst(i).kinds );
3213 printf ( " head: "); print100( inst(i).head );
3214 printf ( " specs: "); print100( inst(i).specifics );
3215 printf ( " #specs: %d\n", inst(i).numSpecifics );
3216 printf ( " impls: "); print100( inst(i).implements );
3217 printf ( " builder: %s\n", maybeNameStr( inst(i).builder ) );
3222 /* --------------------------------------------------------------------------
3224 * ------------------------------------------------------------------------*/
3231 case POSTPREL: break;
3233 case RESET : clearStack();
3235 /* the next 2 statements are particularly important
3236 * if you are using GLOBALfst or GLOBALsnd since the
3237 * corresponding registers may be reset to their
3238 * uninitialised initial values by a longjump.
3240 heapTopFst = heapFst + heapSize;
3241 heapTopSnd = heapSnd + heapSize;
3245 if (isNull(lastExprSaved))
3246 savedText = TEXT_SIZE;
3251 for (i = NAME_BASE_ADDR;
3252 i < NAME_BASE_ADDR+tabNameSz; ++i) {
3253 if (tabName[i-NAME_BASE_ADDR].inUse) {
3254 mark(name(i).parent);
3257 mark(name(i).closure);
3260 end("Names", nameHw-NAMEMIN);
3263 for (i = MODULE_BASE_ADDR;
3264 i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
3265 if (tabModule[i-MODULE_BASE_ADDR].inUse) {
3266 mark(module(i).tycons);
3267 mark(module(i).names);
3268 mark(module(i).classes);
3269 mark(module(i).exports);
3270 mark(module(i).qualImports);
3271 mark(module(i).codeList);
3272 mark(module(i).tree);
3273 mark(module(i).uses);
3274 mark(module(i).objectExtraNames);
3279 mark(targetModules);
3280 end("Modules", moduleHw-MODMIN);
3283 for (i = TYCON_BASE_ADDR;
3284 i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
3285 if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
3286 mark(tycon(i).kind);
3287 mark(tycon(i).what);
3288 mark(tycon(i).defn);
3289 mark(tycon(i).closure);
3292 end("Type constructors", tyconHw-TYCMIN);
3295 for (i = CCLASS_BASE_ADDR;
3296 i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
3297 if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
3298 mark(cclass(i).kinds);
3299 mark(cclass(i).fds);
3300 mark(cclass(i).xfds);
3301 mark(cclass(i).head);
3302 mark(cclass(i).supers);
3303 mark(cclass(i).dsels);
3304 mark(cclass(i).members);
3305 mark(cclass(i).defaults);
3306 mark(cclass(i).instances);
3310 end("Classes", classHw-CLASSMIN);
3313 for (i = INST_BASE_ADDR;
3314 i < INST_BASE_ADDR+tabInstSz; ++i) {
3315 if (tabInst[i-INST_BASE_ADDR].inUse) {
3316 mark(inst(i).kinds);
3318 mark(inst(i).specifics);
3319 mark(inst(i).implements);
3322 end("Instances", instHw-INSTMIN);
3325 for (i=0; i<=sp; ++i)
3330 mark(lastExprSaved);
3333 end("Last expression", 3);
3338 end("C stack", stackRoots);
3343 case PREPREL : heapFst = heapAlloc(heapSize);
3344 heapSnd = heapAlloc(heapSize);
3346 if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
3347 ERRMSG(0) "Cannot allocate heap storage (%d cells)",
3352 heapTopFst = heapFst + heapSize;
3353 heapTopSnd = heapSnd + heapSize;
3354 for (i=1; i<heapSize; ++i) {
3358 snd(-heapSize) = NIL;
3365 marksSize = bitArraySize(heapSize);
3366 if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
3367 ERRMSG(0) "Unable to allocate gc markspace"
3374 nextNewText = INVAR_BASE_ADDR;
3375 nextNewDText = INDVAR_BASE_ADDR;
3376 lastExprSaved = NIL;
3377 savedText = TEXT_SIZE;
3379 for (i=0; i<TEXTHSZ; ++i) textHash[i][0] = NOTEXT;
3380 for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
3381 for (i=0; i<NAMEHSZ; ++i) nameHash[RC_N(i)] = NIL;
3387 /*-------------------------------------------------------------------------*/