X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstorage.c;h=183495e0dd81955aa936bccf96fc9f0232e22388;hb=a634bc4711b13d878ce4a5fe9a45ae5c7468255c;hp=7de66abd5a3388aa44850666f5580ffdffc7dafb;hpb=ca6e1e45c806ac5190589eb9e6720c5cf133df1b;p=ghc-hetmet.git diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 7de66ab..183495e 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -2,21 +2,22 @@ /* -------------------------------------------------------------------------- * Primitives for manipulating global data structures * - * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale - * Haskell Group 1994-99, and is distributed as Open Source software - * under the Artistic License; see the file "Artistic" that is included - * in the distribution for details. + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, All rights reserved. It is distributed as + * free software under the license in the file "License", which is + * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/07/06 15:24:43 $ + * $Revision: 1.61 $ + * $Date: 2000/04/04 15:41:56 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" #include "errors.h" +#include "object.h" #include /*#define DEBUG_SHOWUSE*/ @@ -25,22 +26,21 @@ * local function prototypes: * ------------------------------------------------------------------------*/ -static Int local hash Args((String)); -static Int local saveText Args((Text)); -static Module local findQualifier Args((Text)); -static Void local hashTycon Args((Tycon)); -static List local insertTycon Args((Tycon,List)); -static Void local hashName Args((Name)); -static List local insertName Args((Name,List)); -static Void local patternError Args((String)); -static Bool local stringMatch Args((String,String)); -static Bool local typeInvolves Args((Type,Type)); -static Cell local markCell Args((Cell)); -static Void local markSnd Args((Cell)); -static Cell local lowLevelLastIn Args((Cell)); -static Cell local lowLevelLastOut Args((Cell)); - Module local moduleOfScript Args((Script)); - Script local scriptThisFile Args((Text)); +static Int local hash ( String ); +static Int local saveText ( Text ); +static Module local findQualifier ( Text ); +static Void local hashTycon ( Tycon ); +static List local insertTycon ( Tycon,List ); +static Void local hashName ( Name ); +static List local insertName ( Name,List ); +static Void local patternError ( String ); +static Bool local stringMatch ( String,String ); +static Bool local typeInvolves ( Type,Type ); +static Cell local markCell ( Cell ); +static Void local markSnd ( Cell ); +static Cell local lowLevelLastIn ( Cell ); +static Cell local lowLevelLastOut ( Cell ); + /* -------------------------------------------------------------------------- * Text storage: @@ -71,23 +71,29 @@ static Cell local lowLevelLastOut Args((Cell)); #define TEXTHSZ 512 /* Size of Text hash table */ #define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */ static Text textHw; /* Next unused position */ -static Text savedText = NUM_TEXT; /* Start of saved portion of text */ +static Text savedText = TEXT_SIZE; /* Start of saved portion of text */ static Text nextNewText; /* Next new text value */ static Text nextNewDText; /* Next new dict text value */ -static char DEFTABLE(text,NUM_TEXT);/* Storage of character strings */ +static char text[TEXT_SIZE]; /* Storage of character strings */ static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */ String textToStr(t) /* find string corresp to given Text*/ Text t; { static char newVar[16]; - if (0<=t && t= INVAR_BASE_ADDR+INVAR_MAX_AVAIL) + internal("inventText: too many invented variables"); + return nextNewText++; } Text inventDictText() { /* return new unused dictvar name */ - return nextNewDText--; + if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL) + internal("inventDictText: too many invented variables"); + return nextNewDText++; } Bool inventedText(t) /* Signal TRUE if text has been */ Text t; { /* generated internally */ - return (t<0 || t>=NUM_TEXT); + return isInventedVar(t) || isInventedDictVar(t); +} + +#define MAX_FIXLIT 100 +Text fixLitText(t) /* fix literal text that might include \ */ +Text t; { + String s = textToStr(t); + char p[MAX_FIXLIT]; + Int i; + for(i = 0;i < MAX_FIXLIT-2 && *s;s++) { + p[i++] = *s; + if (*s == '\\') { + p[i++] = '\\'; + } + } + if (i < MAX_FIXLIT-2) { + p[i] = 0; + } else { + ERRMSG(0) "storage space exhausted for internal literal string" + EEND; + } + return (findText(p)); } +#undef MAX_FIXLIT static Int local hash(s) /* Simple hash function on strings */ String s; { @@ -151,13 +184,13 @@ String s; { int hashno = 0; Text textPos = textHash[h][hashno]; -#define TryMatch { Text originalTextPos = textPos; \ +# define TryMatch { Text originalTextPos = textPos; \ String t; \ for (t=s; *t==text[textPos]; textPos++,t++) \ if (*t=='\0') \ - return originalTextPos; \ + return originalTextPos+TEXT_BASE_ADDR; \ } -#define Skip while (text[textPos++]) ; +# define Skip while (text[textPos++]) ; while (textPos!=NOTEXT) { TryMatch @@ -189,14 +222,13 @@ String s; { textHash[h][hashno+1] = NOTEXT; } - return textPos; + return textPos+TEXT_BASE_ADDR; } static Int local saveText(t) /* Save text value in buffer */ Text t; { /* at top of text table */ String s = textToStr(t); Int l = strlen(s); - if (textHw + l + 1 > savedText) { ERRMSG(0) "Character string storage space exhausted" EEND; @@ -207,6 +239,199 @@ Text t; { /* at top of text table */ } +static int fromHexDigit ( char c ) +{ + switch (c) { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + return c - '0'; + case 'a': case 'A': return 10; + case 'b': case 'B': return 11; + case 'c': case 'C': return 12; + case 'd': case 'D': return 13; + case 'e': case 'E': return 14; + case 'f': case 'F': return 15; + default: return -1; + } +} + + +/* returns findText (unZencode s) */ +Text unZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn, i; + Text t; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("unZcodeThenFindText: malloc failed"); + n = 0; + + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("unZcodeThenFindText: result is too big"); + if (*s != 'z' && *s != 'Z') { + p[n] = *s; n++; s++; + continue; + } + s++; + if (!(*s)) goto parse_error; + switch (*s++) { + case 'Z': p[n++] = 'Z'; break; + case 'C': p[n++] = ':'; break; + case 'L': p[n++] = '('; break; + case 'R': p[n++] = ')'; break; + case 'M': p[n++] = '['; break; + case 'N': p[n++] = ']'; break; + case 'z': p[n++] = 'z'; break; + case 'a': p[n++] = '&'; break; + case 'b': p[n++] = '|'; break; + case 'd': p[n++] = '$'; break; + case 'e': p[n++] = '='; break; + case 'g': p[n++] = '>'; break; + case 'h': p[n++] = '#'; break; + case 'i': p[n++] = '.'; break; + case 'l': p[n++] = '<'; break; + case 'm': p[n++] = '-'; break; + case 'n': p[n++] = '!'; break; + case 'p': p[n++] = '+'; break; + case 'q': p[n++] = '\\'; break; + case 'r': p[n++] = '\''; break; + case 's': p[n++] = '/'; break; + case 't': p[n++] = '*'; break; + case 'u': p[n++] = '^'; break; + case 'v': p[n++] = '%'; break; + case 'x': + if (!s[0] || !s[1]) goto parse_error; + if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error; + p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]); + p += 2; s += 2; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = 0; + s--; + while (*s && isdigit((int)(*s))) { + i = 10 * i + (*s - '0'); + s++; + } + if (*s != 'T') goto parse_error; + s++; + p[n++] = '('; + while (i > 0) { p[n++] = ','; i--; }; + p[n++] = ')'; + break; + default: + goto parse_error; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; + + parse_error: + free(p); + fprintf ( stderr, "\nstring = `%s'\n", s ); + internal ( "unZcodeThenFindText: parse error on above string"); + return NIL; /*notreached*/ +} + + +Text enZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn; + Text t; + char toHex[16] = "0123456789ABCDEF"; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("enZcodeThenFindText: malloc failed"); + n = 0; + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("enZcodeThenFindText: result is too big"); + if (*s != 'z' + && *s != 'Z' + && (isalnum((int)(*s)) || *s == '_')) { + p[n] = *s; n++; s++; + continue; + } + if (*s == '(') { + int tup = 0; + char num[12]; + s++; + while (*s && *s==',') { s++; tup++; }; + if (*s != ')') internal("enZcodeThenFindText: invalid tuple type"); + s++; + p[n++] = 'Z'; + sprintf(num,"%d",tup); + p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num); + p[n++] = 'T'; + continue; + } + switch (*s++) { + case '(': p[n++] = 'Z'; p[n++] = 'L'; break; + case ')': p[n++] = 'Z'; p[n++] = 'R'; break; + case '[': p[n++] = 'Z'; p[n++] = 'M'; break; + case ']': p[n++] = 'Z'; p[n++] = 'N'; break; + case ':': p[n++] = 'Z'; p[n++] = 'C'; break; + case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break; + case 'z': p[n++] = 'z'; p[n++] = 'z'; break; + case '&': p[n++] = 'z'; p[n++] = 'a'; break; + case '|': p[n++] = 'z'; p[n++] = 'b'; break; + case '$': p[n++] = 'z'; p[n++] = 'd'; break; + case '=': p[n++] = 'z'; p[n++] = 'e'; break; + case '>': p[n++] = 'z'; p[n++] = 'g'; break; + case '#': p[n++] = 'z'; p[n++] = 'h'; break; + case '.': p[n++] = 'z'; p[n++] = 'i'; break; + case '<': p[n++] = 'z'; p[n++] = 'l'; break; + case '-': p[n++] = 'z'; p[n++] = 'm'; break; + case '!': p[n++] = 'z'; p[n++] = 'n'; break; + case '+': p[n++] = 'z'; p[n++] = 'p'; break; + case '\'': p[n++] = 'z'; p[n++] = 'q'; break; + case '\\': p[n++] = 'z'; p[n++] = 'r'; break; + case '/': p[n++] = 'z'; p[n++] = 's'; break; + case '*': p[n++] = 'z'; p[n++] = 't'; break; + case '^': p[n++] = 'z'; p[n++] = 'u'; break; + case '%': p[n++] = 'z'; p[n++] = 'v'; break; + default: s--; p[n++] = 'z'; p[n++] = 'x'; + p[n++] = toHex[(int)(*s)/16]; + p[n++] = toHex[(int)(*s)%16]; + s++; break; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; +} + + +Text textOf ( Cell c ) +{ + Int wot = whatIs(c); + Bool ok = + (wot==VARIDCELL + || wot==CONIDCELL + || wot==VAROPCELL + || wot==CONOPCELL + || wot==STRCELL + || wot==DICTVAR + || wot==IPCELL + || wot==IPVAR + ); + if (!ok) { + fprintf(stderr, "\ntextOf: bad tag %d\n",wot ); + internal("textOf: bad tag"); + } + return snd(c); +} + /* -------------------------------------------------------------------------- * Ext storage: * @@ -238,6 +463,146 @@ Text t; { } #endif + +/* -------------------------------------------------------------------------- + * Expandable symbol tables. A template, which is instantiated for the name, + * tycon, class, instance and module tables. Also, potentially, TREX Exts. + * ------------------------------------------------------------------------*/ + +#define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name, \ + proc_name,free_proc_name, \ + free_list,tab_name,tab_size,err_msg, \ + TAB_INIT_SIZE,TAB_MAX_SIZE, \ + TAB_BASE_ADDR) \ + \ + struct struct_name* tab_name = NULL; \ + int tab_size = 0; \ + static type_name free_list = TAB_BASE_ADDR-1; \ + \ + void free_proc_name ( type_name n ) \ + { \ + assert(TAB_BASE_ADDR <= n); \ + assert(n < TAB_BASE_ADDR+tab_size); \ + assert(tab_name[n-TAB_BASE_ADDR].inUse); \ + tab_name[n-TAB_BASE_ADDR].inUse = FALSE; \ + /*tab_name[n-TAB_BASE_ADDR].nextFree = free_list; */ \ + /*free_list = n;*/ \ + } \ + \ + type_name proc_name ( void ) \ + { \ + Int i; \ + Int newSz; \ + struct struct_name* newTab; \ + struct struct_name* temp; \ + try_again: \ + if (free_list != TAB_BASE_ADDR-1) { \ + type_name t = free_list; \ + free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree; \ + assert (!(tab_name[t-TAB_BASE_ADDR].inUse)); \ + tab_name[t-TAB_BASE_ADDR].inUse = TRUE; \ + return t; \ + } \ + \ + newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size); \ + if (newSz > TAB_MAX_SIZE) goto cant_allocate; \ + newTab = malloc(newSz * sizeof(struct struct_name)); \ + if (!newTab) goto cant_allocate; \ + for (i = 0; i < tab_size; i++) \ + newTab[i] = tab_name[i]; \ + for (i = tab_size; i < newSz; i++) { \ + newTab[i].inUse = FALSE; \ + newTab[i].nextFree = i-1+TAB_BASE_ADDR; \ + } \ + /* fprintf(stderr, "Expanding " #type_name \ + "table to size %d\n", newSz );*/ \ + newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \ + free_list = newSz-1+TAB_BASE_ADDR; \ + tab_size = newSz; \ + temp = tab_name; \ + tab_name = newTab; \ + if (temp) free(temp); \ + goto try_again; \ + \ + cant_allocate: \ + ERRMSG(0) err_msg \ + EEND; \ + } \ + + + +EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName, + nameFL,tabName,tabNameSz, + "Name storage space exhausted", + NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon, + tyconFL,tabTycon,tabTyconSz, + "Type constructor storage space exhausted", + TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass, + classFL,tabClass,tabClassSz, + "Class storage space exhausted", + CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst, + instFL,tabInst,tabInstSz, + "Instance storage space exhausted", + INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule, + moduleFL,tabModule,tabModuleSz, + "Module storage space exhausted", + MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR) + +#ifdef DEBUG_STORAGE +struct strName* generate_name_ref ( Cell nm ) +{ + assert(isName(nm)); + nm -= NAME_BASE_ADDR; + assert(tabName[nm].inUse); + assert(isModule(tabName[nm].mod)); + return & tabName[nm]; +} +struct strTycon* generate_tycon_ref ( Cell tc ) +{ + assert(isTycon(tc) || isTuple(tc)); + tc -= TYCON_BASE_ADDR; + assert(tabTycon[tc].inUse); + assert(isModule(tabTycon[tc].mod)); + return & tabTycon[tc]; +} +struct strClass* generate_cclass_ref ( Cell cl ) +{ + assert(isClass(cl)); + cl -= CCLASS_BASE_ADDR; + assert(tabClass[cl].inUse); + assert(isModule(tabClass[cl].mod)); + return & tabClass[cl]; +} +struct strInst* generate_inst_ref ( Cell in ) +{ + assert(isInst(in)); + in -= INST_BASE_ADDR; + assert(tabInst[in].inUse); + assert(isModule(tabInst[in].mod)); + return & tabInst[in]; +} +struct strModule* generate_module_ref ( Cell mo ) +{ + assert(isModule(mo)); + mo -= MODULE_BASE_ADDR; + assert(tabModule[mo].inUse); + return & tabModule[mo]; +} +#endif + + /* -------------------------------------------------------------------------- * Tycon storage: * @@ -248,36 +613,50 @@ Text t; { * ------------------------------------------------------------------------*/ #define TYCONHSZ 256 /* Size of Tycon hash table*/ -#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */ -static Tycon tyconHw; /* next unused Tycon */ -static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */ -struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */ - -Tycon newTycon(t) /* add new tycon to tycon table */ -Text t; { - Int h = tHash(t); - if (tyconHw-TYCMIN >= NUM_TYCON) { - ERRMSG(0) "Type constructor storage space exhausted" - EEND; - } - tycon(tyconHw).text = t; /* clear new tycon record */ - tycon(tyconHw).kind = NIL; - tycon(tyconHw).defn = NIL; - tycon(tyconHw).what = NIL; - tycon(tyconHw).conToTag = NIL; - tycon(tyconHw).tagToCon = NIL; - tycon(tyconHw).mod = currentModule; - module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); - tycon(tyconHw).nextTyconHash = tyconHash[h]; - tyconHash[h] = tyconHw; - - return tyconHw++; + //#define tHash(x) (((x)-TEXT_BASE_ADDR)%TYCONHSZ)/* Tycon hash function */ +static int tHash(Text x) +{ + int r; + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + r= x%TYCONHSZ; + assert(r>=0); + assert(r= 0 && x < TYCONHSZ); + return x; +} +Tycon newTycon ( Text t ) /* add new tycon to tycon table */ +{ + Int h = tHash(t); + Tycon tc = allocNewTycon(); + tabTycon + [tc-TYCON_BASE_ADDR].tuple = -1; + tabTycon + [tc-TYCON_BASE_ADDR].mod = currentModule; + tycon(tc).text = t; /* clear new tycon record */ + tycon(tc).kind = NIL; + tycon(tc).defn = NIL; + tycon(tc).what = NIL; + tycon(tc).conToTag = NIL; + tycon(tc).tagToCon = NIL; + tycon(tc).itbl = NULL; + tycon(tc).arity = 0; + module(currentModule).tycons = cons(tc,module(currentModule).tycons); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; + return tc; } Tycon findTycon(t) /* locate Tycon in tycon table */ Text t; { - Tycon tc = tyconHash[tHash(t)]; - + Tycon tc = tyconHash[RC_T(tHash(t))]; +assert(isTycon(tc) || isTuple(tc) || isNull(tc)); while (nonNull(tc) && tycon(tc).text!=t) tc = tycon(tc).nextTyconHash; return tc; @@ -285,7 +664,9 @@ Text t; { Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */ Tycon tc; { - Tycon oldtc = findTycon(tycon(tc).text); + Tycon oldtc; + assert(isTycon(tc) || isTuple(tc)); + oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { hashTycon(tc); module(currentModule).tycons=cons(tc,module(currentModule).tycons); @@ -296,10 +677,18 @@ Tycon tc; { static Void local hashTycon(tc) /* Insert Tycon into hash table */ Tycon tc; { - Text t = tycon(tc).text; - Int h = tHash(t); - tycon(tc).nextTyconHash = tyconHash[h]; - tyconHash[h] = tc; + Text t; + Int h; + assert(isTycon(tc) || isTuple(tc)); + {int i; for (i = 0; i < TYCONHSZ; i++) + assert (tyconHash[i] == 0 + || isTycon(tyconHash[i]) + || isTuple(tyconHash[i])); + } + t = tycon(tc).text; + h = tHash(t); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; } Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */ @@ -323,7 +712,7 @@ Cell id; { } default : internal("findQualTycon2"); } - return 0; /* NOTREACHED */ + return NIL; /* NOTREACHED */ } Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */ @@ -366,13 +755,51 @@ List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */ String pat; /* to list of Tycons ts */ List ts; { /* Null pattern matches every tycon*/ Tycon tc; /* (Tycons with NIL kind excluded) */ - for (tc=TYCMIN; tc= 100) internal("ghcTupleText_n"); + if (n == 1) internal("ghcTupleText_n==1"); + buf[x++] = '('; + for (i = 1; i <= n-1; i++) buf[x++] = ','; + buf[x++] = ')'; + buf[x++] = 0; + return findText(buf); +} + +Text ghcTupleText(tup) +Tycon tup; { + if (!isTuple(tup)) { + assert(isTuple(tup)); + } + return ghcTupleText_n ( tupleOf(tup) ); +} + + +Tycon mkTuple ( Int n ) +{ + Int i; + if (n >= NUM_TUPLES) + internal("mkTuple: request for tuple of unsupported size"); + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; + internal("mkTuple: request for non-existent tuple"); +} + + /* -------------------------------------------------------------------------- * Name storage: * @@ -387,44 +814,68 @@ List ts; { /* Null pattern matches every tycon*/ * ------------------------------------------------------------------------*/ #define NAMEHSZ 256 /* Size of Name hash table */ -#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */ - Name nameHw; /* next unused name */ -static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */ -struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */ - -Name newName(t,parent) /* Add new name to name table */ -Text t; -Cell parent; { +//#define nHash(x) (((x)-TEXT_BASE_ADDR)%NAMEHSZ) /* hash fn :: Text->Int */ +static int nHash(Text x) +{ + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + return x%NAMEHSZ; +} +static Name nameHash[NAMEHSZ]; /* Hash table storage */ +int RC_N ( int x ) +{ + assert (x >= 0 && x < NAMEHSZ); + return x; +} +void hashSanity ( void ) +{ + Int i, j; + for (i = 0; i < TYCONHSZ; i++) { + j = tyconHash[i]; + while (nonNull(j)) { + assert(isTycon(j) || isTuple(j)); + j = tycon(j).nextTyconHash; + } + } + for (i = 0; i < NAMEHSZ; i++) { + j = nameHash[i]; + while (nonNull(j)) { + assert(isName(j)); + j = name(j).nextNameHash; + } + } +} + +Name newName ( Text t, Cell parent ) /* Add new name to name table */ +{ Int h = nHash(t); - if (nameHw-NAMEMIN >= NUM_NAME) { - ERRMSG(0) "Name storage space exhausted" - EEND; - } - name(nameHw).text = t; /* clear new name record */ - name(nameHw).line = 0; - name(nameHw).syntax = NO_SYNTAX; - name(nameHw).parent = parent; - name(nameHw).arity = 0; - name(nameHw).number = EXECNAME; - name(nameHw).defn = NIL; - name(nameHw).stgVar = NIL; - name(nameHw).stgSize = 0; - name(nameHw).inlineMe = FALSE; - name(nameHw).simplified = FALSE; - name(nameHw).isDBuilder = FALSE; - name(nameHw).type = NIL; - name(nameHw).primop = 0; - name(nameHw).mod = currentModule; - module(currentModule).names=cons(nameHw,module(currentModule).names); - name(nameHw).nextNameHash = nameHash[h]; - nameHash[h] = nameHw; - return nameHw++; + Name nm = allocNewName(); + tabName + [nm-NAME_BASE_ADDR].mod = currentModule; + name(nm).text = t; /* clear new name record */ + name(nm).line = 0; + name(nm).syntax = NO_SYNTAX; + name(nm).parent = parent; + name(nm).arity = 0; + name(nm).number = EXECNAME; + name(nm).defn = NIL; + name(nm).stgVar = NIL; + name(nm).callconv = NIL; + name(nm).type = NIL; + name(nm).primop = NULL; + name(nm).itbl = NULL; + module(currentModule).names = cons(nm,module(currentModule).names); + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; + return nm; } Name findName(t) /* Locate name in name table */ Text t; { - Name n = nameHash[nHash(t)]; - + Name n = nameHash[RC_N(nHash(t))]; +assert(isText(t)); +assert(isName(n) || isNull(n)); while (nonNull(n) && name(n).text!=t) n = name(n).nextNameHash; return n; @@ -432,7 +883,9 @@ Text t; { Name addName(nm) /* Insert Name in name table - if */ Name nm; { /* no clash is caused */ - Name oldnm = findName(name(nm).text); + Name oldnm; + assert(isName(nm)); + oldnm = findName(name(nm).text); if (isNull(oldnm)) { hashName(nm); module(currentModule).names=cons(nm,module(currentModule).names); @@ -448,8 +901,8 @@ Name nm; { assert(isName(nm)); t = name(nm).text; h = nHash(t); - name(nm).nextNameHash = nameHash[h]; - nameHash[h] = nm; + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; } Name findQualName(id) /* Locate (possibly qualified) name*/ @@ -498,16 +951,137 @@ Cell id; { /* in name table */ Name nameFromStgVar ( StgVar v ) { Int n; - for (n = NAMEMIN; n < nameHw; n++) - if (name(n).stgVar == v) return n; + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).stgVar == v) return n; return NIL; } +void* getHugs_AsmObject_for ( char* s ) +{ + StgVar v; + Text t = findText(s); + Name n = NIL; + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).text == t) break; + if (n == NAME_BASE_ADDR+tabNameSz) { + fprintf ( stderr, "can't find `%s' in ...\n", s ); + internal("getHugs_AsmObject_for(1)"); + } + v = name(n).stgVar; + if (!isStgVar(v) || !isPtr(stgVarInfo(v))) + internal("getHugs_AsmObject_for(2)"); + return ptrOf(stgVarInfo(v)); +} /* -------------------------------------------------------------------------- * Primitive functions: * ------------------------------------------------------------------------*/ +Module findFakeModule ( Text t ) +{ + Module m = findModule(t); + if (nonNull(m)) { + if (!module(m).fake) internal("findFakeModule"); + } else { + m = newModule(t); + module(m).fake = TRUE; + } + return m; +} + + +Name addWiredInBoxingTycon + ( String modNm, String typeNm, String constrNm, + Int rep, Kind kind ) +{ + Name n; + Tycon t; + Text modT = findText(modNm); + Text typeT = findText(typeNm); + Text conT = findText(constrNm); + Module m = findFakeModule(modT); + setCurrModule(m); + + n = newName(conT,NIL); + name(n).arity = 1; + name(n).number = cfunNo(0); + name(n).type = NIL; + name(n).primop = (void*)rep; + + t = newTycon(typeT); + tycon(t).what = DATATYPE; + tycon(t).kind = kind; + return n; +} + + +Tycon addTupleTycon ( Int n ) +{ + Int i; + Kind k; + Tycon t; + Module m; + Name nm; + + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; + + if (combined) + m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else + m = findModule(findText("PrimPrel")); + + setCurrModule(m); + k = STAR; + for (i = 0; i < n; i++) k = ap(STAR,k); + t = newTycon(ghcTupleText_n(n)); + tycon(t).kind = k; + tycon(t).tuple = n; + tycon(t).what = DATATYPE; + + if (n == 0) { + /* maybe we want to do this for all n ? */ + nm = newName(ghcTupleText_n(n), t); + name(nm).type = t; /* ummm ... for n > 0 */ + } + + return t; +} + + +Tycon addWiredInEnumTycon ( String modNm, String typeNm, + List /*of Text*/ constrs ) +{ + Int i; + Tycon t; + Text modT = findText(modNm); + Text typeT = findText(typeNm); + Module m = findFakeModule(modT); + setCurrModule(m); + + t = newTycon(typeT); + tycon(t).kind = STAR; + tycon(t).what = DATATYPE; + + constrs = reverse(constrs); + i = length(constrs); + for (; nonNull(constrs); constrs=tl(constrs),i--) { + Text conT = hd(constrs); + Name con = newName(conT,t); + name(con).number = cfunNo(i); + name(con).type = t; + name(con).parent = t; + tycon(t).defn = cons(con, tycon(t).defn); + } + return t; +} + + Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */ Text t; /* sets rep, not type */ Int arity; @@ -572,13 +1146,17 @@ List addNamesMatching(pat,ns) /* Add names matching pattern pat */ String pat; /* to list of names ns */ List ns; { /* Null pattern matches every name */ Name nm; /* (Names with NIL type, or hidden */ + /* or invented names are excluded) */ #if 1 - for (nm=NAMEMIN; nm= NUM_CLASSES) { - ERRMSG(0) "Class storage space exhausted" - EEND; - } - cclass(classHw).text = t; - cclass(classHw).arity = 0; - cclass(classHw).kinds = NIL; - cclass(classHw).head = NIL; - cclass(classHw).dcon = NIL; - cclass(classHw).supers = NIL; - cclass(classHw).dsels = NIL; - cclass(classHw).members = NIL; - cclass(classHw).dbuild = NIL; - cclass(classHw).defaults = NIL; - cclass(classHw).instances = NIL; - classes=cons(classHw,classes); - cclass(classHw).mod = currentModule; - module(currentModule).classes=cons(classHw,module(currentModule).classes); - return classHw++; -} - -Class classMax() { /* Return max Class in use ... */ - return classHw; /* This is a bit ugly, but it's not*/ -} /* worth a lot of effort right now */ +Class newClass ( Text t ) /* add new class to class table */ +{ + Class cl = allocNewClass(); + tabClass + [cl-CCLASS_BASE_ADDR].mod = currentModule; + cclass(cl).text = t; + cclass(cl).arity = 0; + cclass(cl).kinds = NIL; + cclass(cl).head = NIL; + cclass(cl).fds = NIL; + cclass(cl).xfds = NIL; + cclass(cl).dcon = NIL; + cclass(cl).supers = NIL; + cclass(cl).dsels = NIL; + cclass(cl).members = NIL; + cclass(cl).defaults = NIL; + cclass(cl).instances = NIL; + classes = cons(cl,classes); + module(currentModule).classes + = cons(cl,module(currentModule).classes); + return cl; +} Class findClass(t) /* look for named class in table */ Text t; { @@ -708,7 +1277,9 @@ Text t; { Class addClass(c) /* Insert Class in class list */ Class c; { /* - if no clash caused */ - Class oldc = findClass(cclass(c).text); + Class oldc; + assert(whatIs(c)==CLASS); + oldc = findClass(cclass(c).text); if (isNull(oldc)) { classes=cons(c,classes); module(currentModule).classes=cons(c,module(currentModule).classes); @@ -738,22 +1309,19 @@ Cell c; { /* class in class list */ } Inst newInst() { /* Add new instance to table */ - if (instHw-INSTMIN >= NUM_INSTS) { - ERRMSG(0) "Instance storage space exhausted" - EEND; - } - inst(instHw).kinds = NIL; - inst(instHw).head = NIL; - inst(instHw).specifics = NIL; - inst(instHw).implements = NIL; - inst(instHw).builder = NIL; - inst(instHw).mod = currentModule; - - return instHw++; + Inst in = allocNewInst(); + tabInst + [in-INST_BASE_ADDR].mod = currentModule; + inst(in).kinds = NIL; + inst(in).head = NIL; + inst(in).specifics = NIL; + inst(in).implements = NIL; + inst(in).builder = NIL; + return in; } #ifdef DEBUG_DICTS -extern Void printInst Args((Inst)); +extern Void printInst ( Inst)); Void printInst(in) Inst in; { @@ -765,14 +1333,17 @@ Inst in; { Inst findFirstInst(tc) /* look for 1st instance involving */ Tycon tc; { /* the type constructor tc */ - return findNextInst(tc,INSTMIN-1); + return findNextInst(tc,INST_BASE_ADDR-1); } Inst findNextInst(tc,in) /* look for next instance involving*/ Tycon tc; /* the type constructor tc */ Inst in; { /* starting after instance in */ - while (++in < instHw) { - Cell pi = inst(in).head; + Cell pi; + while (++in < INST_BASE_ADDR+tabInstSz) { + if (!tabInst[in-INST_BASE_ADDR].inUse) continue; + assert(isModule(inst(in).mod)); + pi = inst(in).head; for (; isAp(pi); pi=fun(pi)) if (typeInvolves(arg(pi),tc)) return in; @@ -788,6 +1359,182 @@ Type tc; { || typeInvolves(arg(ty),tc))); } + +/* Needed by finishGHCInstance to find classes, before the + export list has been built -- so we can't use + findQualClass. +*/ +Class findQualClassWithoutConsultingExportList ( QualId q ) +{ + Class cl; + Text t_mod; + Text t_class; + + assert(isQCon(q)); + + if (isCon(q)) { + t_mod = NIL; + t_class = textOf(q); + } else { + t_mod = qmodOf(q); + t_class = qtextOf(q); + } + + for (cl = CCLASS_BASE_ADDR; + cl < CCLASS_BASE_ADDR+tabClassSz; cl++) { + if (tabClass[cl-CCLASS_BASE_ADDR].inUse) + if (cclass(cl).text == t_class) { + /* Class name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(cclass(cl).mod).text) + ) + return cl; + } + } + return NIL; +} + +/* Same deal, except for Tycons. */ +Tycon findQualTyconWithoutConsultingExportList ( QualId q ) +{ + Tycon tc; + Text t_mod; + Text t_tycon; + + assert(isQCon(q)); + + if (isCon(q)) { + t_mod = NIL; + t_tycon = textOf(q); + } else { + t_mod = qmodOf(q); + t_tycon = qtextOf(q); + } + + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + if (tycon(tc).text == t_tycon) { + /* Tycon name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(tycon(tc).mod).text) + ) + return tc; + } + } + return NIL; +} + +/* Same deal, except for Names. */ +Name findQualNameWithoutConsultingExportList ( QualId q ) +{ + Name nm; + Text t_mod; + Text t_name; + + assert(isQVar(q) || isQCon(q)); + + if (isCon(q) || isVar(q)) { + t_mod = NIL; + t_name = textOf(q); + } else { + t_mod = qmodOf(q); + t_name = qtextOf(q); + } + + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) { + if (tabName[nm-NAME_BASE_ADDR].inUse) + if (name(nm).text == t_name) { + /* Name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(name(nm).mod).text) + ) + return nm; + } + } + return NIL; +} + + +Tycon findTyconInAnyModule ( Text t ) +{ + Tycon tc; + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + if (tycon(tc).text == t) return tc; + return NIL; +} + +Class findClassInAnyModule ( Text t ) +{ + Class cc; + for (cc = CCLASS_BASE_ADDR; + cc < CCLASS_BASE_ADDR+tabClassSz; cc++) + if (tabClass[cc-CCLASS_BASE_ADDR].inUse) + if (cclass(cc).text == t) return cc; + return NIL; +} + +Name findNameInAnyModule ( Text t ) +{ + Name nm; + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) + if (tabName[nm-NAME_BASE_ADDR].inUse) + if (name(nm).text == t) return nm; + return NIL; +} + + +/* returns List of QualId */ +List getAllKnownTyconsAndClasses ( void ) +{ + Tycon tc; + Class nw; + List xs = NIL; + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) { + /* almost certainly undue paranoia about duplicate avoidance */ + QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } + } + for (nw = CCLASS_BASE_ADDR; + nw < CCLASS_BASE_ADDR+tabClassSz; nw++) { + if (tabClass[nw-CCLASS_BASE_ADDR].inUse) { + QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } + } + return xs; +} + +/* Purely for debugging. */ +void locateSymbolByName ( Text t ) +{ + Int i; + for (i = NAME_BASE_ADDR; + i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t) + fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR); + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t) + fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR); + for (i = CCLASS_BASE_ADDR; + i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t) + fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR); +} + /* -------------------------------------------------------------------------- * Control stack: * @@ -795,51 +1542,14 @@ Type tc; { * operations are defined as macros, expanded inline. * ------------------------------------------------------------------------*/ -Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */ +Cell cellStack[NUM_STACK]; /* Storage for cells on stack */ StackPtr sp; /* stack pointer */ -#if GIMME_STACK_DUMPS - -#define UPPER_DISP 5 /* # display entries on top of stack */ -#define LOWER_DISP 5 /* # display entries on bottom of stack*/ - -Void hugsStackOverflow() { /* Report stack overflow */ - extern Int rootsp; - extern Cell evalRoots[]; - - ERRMSG(0) "Control stack overflow" ETHEN - if (rootsp>=0) { - Int i; - if (rootsp>=UPPER_DISP+LOWER_DISP) { - for (i=0; i=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - else { - for (i=rootsp; i>=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - } - ERRTEXT "\n" - EEND; -} - -#else /* !GIMME_STACK_DUMPS */ - Void hugsStackOverflow() { /* Report stack overflow */ ERRMSG(0) "Control stack overflow" EEND; } -#endif /* !GIMME_STACK_DUMPS */ /* -------------------------------------------------------------------------- * Module storage: @@ -858,35 +1568,100 @@ Void hugsStackOverflow() { /* Report stack overflow */ * * ------------------------------------------------------------------------*/ -static Module moduleHw; /* next unused Module */ -struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */ Module currentModule; /* Module currently being processed*/ -Bool isValidModule(m) /* is m a legitimate module id? */ +Bool isValidModule(m) /* is m a legitimate module id? */ Module m; { - return (MODMIN <= m && m < moduleHw); + return isModule(m); } -Module newModule(t) /* add new module to module table */ -Text t; { - if (moduleHw-MODMIN >= NUM_MODULE) { - ERRMSG(0) "Module storage space exhausted" - EEND; - } - module(moduleHw).text = t; /* clear new module record */ - module(moduleHw).qualImports = NIL; - module(moduleHw).exports = NIL; - module(moduleHw).tycons = NIL; - module(moduleHw).names = NIL; - module(moduleHw).classes = NIL; - module(moduleHw).oImage = NULL; - module(moduleHw).oTab = NULL; - module(moduleHw).sizeoTab = 0; - module(moduleHw).usedoTab = 0; - module(moduleHw).dlTab = NULL; - module(moduleHw).sizedlTab = 0; - module(moduleHw).useddlTab = 0; - return moduleHw++; +Module newModule ( Text t ) /* add new module to module table */ +{ + Module mod = allocNewModule(); + module(mod).text = t; /* clear new module record */ + + module(mod).tycons = NIL; + module(mod).names = NIL; + module(mod).classes = NIL; + module(mod).exports = NIL; + module(mod).qualImports = NIL; + module(mod).fake = FALSE; + + module(mod).tree = NIL; + module(mod).completed = FALSE; + module(mod).lastStamp = 0; /* ???? */ + + module(mod).mode = NIL; + module(mod).srcExt = findText(""); + module(mod).uses = NIL; + + module(mod).objName = findText(""); + module(mod).objSize = 0; + + module(mod).object = NULL; + module(mod).objectExtras = NULL; + module(mod).objectExtraNames = NIL; + return mod; +} + +void nukeModule ( Module m ) +{ + ObjectCode* oc; + ObjectCode* oc2; + Int i; +assert(isModule(m)); +/*fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); */ + oc = module(m).object; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + oc = module(m).objectExtras; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + + for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) { + if (name(i).itbl) free(name(i).itbl); + name(i).itbl = NULL; + freeName(i); + } + + for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) { + if (tycon(i).itbl) free(tycon(i).itbl); + tycon(i).itbl = NULL; + freeTycon(i); + } + + for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse) { + if (cclass(i).mod == m) { + freeClass(i); + } else { + List /* Inst */ ins; + List /* Inst */ ins2 = NIL; + for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins)) + if (inst(hd(ins)).mod != m) + ins2 = cons(hd(ins),ins2); + cclass(i).instances = ins2; + } + } + + + for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++) + if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m) + freeInst(i); + + freeModule(m); + //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0; + //for (i = 0; i < NAMEHSZ; i++) nameHash[i] = 0; + //classes = NIL; + //hashSanity(); } void ppModules ( void ) @@ -894,10 +1669,12 @@ void ppModules ( void ) Int i; fflush(stderr); fflush(stdout); printf ( "begin MODULES\n" ); - for (i = moduleHw-1; i >= MODMIN; i--) - printf ( " %2d: %16s\n", - i-MODMIN, textToStr(module(i).text) - ); + for (i = MODULE_BASE_ADDR+tabModuleSz-1; + i >= MODULE_BASE_ADDR; i--) + if (tabModule[i-MODULE_BASE_ADDR].inUse) + printf ( " %2d: %16s\n", + i-MODULE_BASE_ADDR, textToStr(module(i).text) + ); printf ( "end MODULES\n" ); fflush(stderr); fflush(stdout); } @@ -906,9 +1683,11 @@ void ppModules ( void ) Module findModule(t) /* locate Module in module table */ Text t; { Module m; - for(m=MODMIN; m 0) - memcpy ( tab2, tab, elemSize * *currSize ); - *currSize = size2; - if (tab) free ( tab ); - return tab2; -} - -void addOTabName ( Module m, char* nm, void* ad ) -{ - module(m).oTab - = genericExpand ( module(m).oTab, - &module(m).sizeoTab, - module(m).usedoTab, - 8, sizeof(OSym) ); - - module(m).oTab[ module(m).usedoTab ].nm = nm; - module(m).oTab[ module(m).usedoTab ].ad = ad; - module(m).usedoTab++; -} - - -void addDLSect ( Module m, void* start, void* end, DLSect sect ) -{ - module(m).dlTab - = genericExpand ( module(m).dlTab, - &module(m).sizedlTab, - module(m).useddlTab, - 4, sizeof(DLTabEnt) ); - module(m).dlTab[ module(m).useddlTab ].start = start; - module(m).dlTab[ module(m).useddlTab ].end = end; - module(m).dlTab[ module(m).useddlTab ].sect = sect; - module(m).useddlTab++; -} - - -void* lookupOTabName ( Module m, char* nm ) -{ - int i; - for (i = 0; i < module(m).usedoTab; i++) - if (0==strcmp(nm,module(m).oTab[i].nm)) - return module(m).oTab[i].ad; - return NULL; -} - - char* nameFromOPtr ( void* p ) { int i; Module m; - for (m=MODMIN; m= 0; i--) - printf ( " %2d: %16s tH=%d mH=%d yH=%d " - "nH=%d cH=%d iH=%d nnS=%d,%d\n", - i, textToStr(scripts[i].file), - scripts[i].textHw, scripts[i].moduleHw, - scripts[i].tyconHw, scripts[i].nameHw, - scripts[i].classHw, scripts[i].instHw, - scripts[i].nextNewText, scripts[i].nextNewDText - ); - printf ( "end SCRIPTS\n" ); - fflush(stderr); fflush(stdout); -} - -Script startNewScript(f) /* start new script, keeping record */ -String f; { /* of status for later restoration */ - if (scriptHw >= NUM_SCRIPTS) { - ERRMSG(0) "Too many script files in use" - EEND; - } -#ifdef DEBUG_SHOWUSE - showUse("Text", textHw, NUM_TEXT); - showUse("Module", moduleHw-MODMIN, NUM_MODULE); - showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON); - showUse("Name", nameHw-NAMEMIN, NUM_NAME); - showUse("Class", classHw-CLASSMIN, NUM_CLASSES); - showUse("Inst", instHw-INSTMIN, NUM_INSTS); -#if TREX - showUse("Ext", extHw-EXTMIN, NUM_EXT); -#endif -#endif - scripts[scriptHw].file = findText( f ? f : "" ); - scripts[scriptHw].textHw = textHw; - scripts[scriptHw].nextNewText = nextNewText; - scripts[scriptHw].nextNewDText = nextNewDText; - scripts[scriptHw].moduleHw = moduleHw; - scripts[scriptHw].tyconHw = tyconHw; - scripts[scriptHw].nameHw = nameHw; - scripts[scriptHw].classHw = classHw; - scripts[scriptHw].instHw = instHw; -#if TREX - scripts[scriptHw].extHw = extHw; -#endif - return scriptHw++; -} - -Bool isPreludeScript() { /* Test whether this is the Prelude*/ - return (scriptHw==0); -} - -Bool moduleThisScript(m) /* Test if given module is defined */ -Module m; { /* in current script file */ - return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw; -} - -Module lastModule() { /* Return module in current script file */ - return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude); + ObjectCode* oc; + Module m; + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) { + if (tabModule[m-MODULE_BASE_ADDR].inUse) + for (oc = module(m).objectExtras; oc; oc=oc->next) { + void* ad = ocLookupSym ( oc, sym ); + if (ad) return ad; + } + } + return NULL; } -#define scriptThis(nm,t,tag) Script nm(x) \ - t x; { \ - Script s=0; \ - while (s=scripts[s].tag) \ - s++; \ - return s; \ - } -scriptThis(scriptThisName,Name,nameHw) -scriptThis(scriptThisTycon,Tycon,tyconHw) -scriptThis(scriptThisInst,Inst,instHw) -scriptThis(scriptThisClass,Class,classHw) -#undef scriptThis -Module moduleOfScript(s) -Script s; { - return (s==0) ? modulePrelude : scripts[s-1].moduleHw; -} - -String fileOfModule(m) -Module m; { - Script s; - if (m == modulePrelude) { - return STD_PRELUDE; - } - for(s=0; snext) { + sect = ocLookupSection ( oc, ad ); + if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) + return sect; + } + } + } + return HUGS_SECTIONKIND_OTHER; } -Script scriptThisFile(f) -Text f; { - Script s; - for (s=0; s < scriptHw; ++s) { - if (scripts[s].file == f) { - return s+1; - } - } - if (f == findText(STD_PRELUDE)) { - return 0; - } - return (-1); -} - -Void dropScriptsFrom(sno) /* Restore storage to state prior */ -Script sno; { /* to reading script sno */ - if (sno= scripts[sno].moduleHw; --i) { - if (module(i).objectFile) { - printf("[bogus] closing objectFile for module %d\n",i); - /*dlclose(module(i).objectFile);*/ - } - } - moduleHw = scripts[sno].moduleHw; -#endif - for (i=0; i=BCSTAG) { + else if (isNull(fst(c)) || isTagPtr(fst(c))) { + STACK_CHECK markSnd(c); } @@ -1425,7 +1978,7 @@ ma: t = c; /* Keep pointer to original pair */ fst(c) = markCell(fst(c)); goto ma; } - else if (isNull(fst(c)) || fst(c)>=BCSTAG) + else if (isNull(fst(c)) || isTagPtr(fst(c))) goto ma; return; } @@ -1441,13 +1994,16 @@ Cell n; { /* it was a cell ref, but don't */ } Void garbageCollect() { /* Run garbage collector ... */ - Bool breakStat = breakOn(FALSE); /* disable break checking */ + /* disable break checking */ Int i,j; register Int mask; register Int place; Int recovered; - jmp_buf regs; /* save registers on stack */ + HugsBreakAction oldBrk + = setBreakAction ( HugsIgnoreBreak ); +fprintf ( stderr, "wa-hey! garbage collection! too difficult! bye!\n" ); +exit(0); setjmp(regs); gcStarted(); @@ -1479,7 +2035,7 @@ Void garbageCollect() { /* Run garbage collector ... */ } gcRecovered(recovered); - breakOn(breakStat); /* restore break trapping if nec. */ + setBreakAction ( oldBrk ); everybody(GCDONE); @@ -1505,14 +2061,14 @@ static Cell lastExprSaved; /* last expression to be saved */ Void setLastExpr(e) /* save expression for later recall*/ Cell e; { lastExprSaved = NIL; /* in case attempt to save fails */ - savedText = NUM_TEXT; + savedText = TEXT_SIZE; lastExprSaved = lowLevelLastIn(e); } static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */ Cell c; { /* acyclic graph) for later recall */ if (isPair(c)) { /* Duplicating any text strings */ - if (isBoxTag(fst(c))) /* in case these are lost at some */ + if (isTagNonPtr(fst(c))) /* in case these are lost at some */ switch (fst(c)) { /* point before the expr is reused */ case VARIDCELL : case VAROPCELL : @@ -1540,7 +2096,7 @@ Cell getLastExpr() { /* recover previously saved expr */ static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */ Cell c; { /* except that Cells refering to */ if (isPair(c)) { /* Text values are restored to */ - if (isBoxTag(fst(c))) /* appropriate values */ + if (isTagNonPtr(fst(c))) /* appropriate values */ switch (fst(c)) { case VARIDCELL : case VAROPCELL : @@ -1565,24 +2121,49 @@ Cell c; { /* except that Cells refering to */ * Miscellaneous operations on heap cells: * ------------------------------------------------------------------------*/ -/* Profiling suggests that the number of calls to whatIs() is typically */ -/* rather high. The recoded version below attempts to improve the average */ -/* performance for whatIs() using a binary search for part of the analysis */ +Cell whatIs ( register Cell c ) +{ + if (isPair(c)) { + register Cell fstc = fst(c); + return isTag(fstc) ? fstc : AP; + } + if (isOffset(c)) return OFFSET; + if (isChar(c)) return CHARCELL; + if (isInt(c)) return INTCELL; + if (isName(c)) return NAME; + if (isTycon(c)) return TYCON; + if (isTuple(c)) return TUPLE; + if (isClass(c)) return CLASS; + if (isInst(c)) return INSTANCE; + if (isModule(c)) return MODULE; + if (isText(c)) return TEXTCELL; + if (isInventedVar(c)) return INVAR; + if (isInventedDictVar(c)) return INDVAR; + if (isSpec(c)) return c; + if (isNull(c)) return c; + fprintf ( stderr, "whatIs: unknown %d\n", c ); + internal("whatIs"); +} + +#if 0 Cell whatIs(c) /* identify type of cell */ register Cell c; { if (isPair(c)) { register Cell fstc = fst(c); return isTag(fstc) ? fstc : AP; } - if (c=INTMIN) return INTCELL; if (c>=NAMEMIN){if (c>=CLASSMIN) {if (c>=CHARMIN) return CHARCELL; else return CLASS;} else if (c>=INSTMIN) return INSTANCE; else return NAME;} - else if (c>=MODMIN) {if (c>=TYCMIN) return TYCON; + else if (c>=MODMIN) {if (c>=TYCMIN) return isTuple(c) ? TUPLE : TYCON; else return MODULE;} else if (c>=OFFMIN) return OFFSET; #if TREX @@ -1592,6 +2173,7 @@ register Cell c; { else return TUPLE; #endif + /* if (isPair(c)) { register Cell fstc = fst(c); return isTag(fstc) ? fstc : AP; @@ -1610,25 +2192,41 @@ register Cell c; { if (c>=TUPMIN) return TUPLE; return c;*/ } +#endif + -#if DEBUG_PRINTER /* A very, very simple printer. * Output is uglier than from printExp - but the printer is more * robust and can be used on any data structure irrespective of * its type. */ -Void print Args((Cell, Int)); -Void print(c, depth) -Cell c; -Int depth; { +Void print ( Cell c, Int depth ) +{ if (0 == depth) { Printf("..."); -#if 0 /* Not in this version of Hugs */ - } else if (isPair(c) && !isGenPair(c)) { - extern Void printEvalCell Args((Cell, Int)); - printEvalCell(c,depth); -#endif - } else { + } + else if (isNull(c)) { + Printf("NIL"); + } + else if (isTagPtr(c)) { + Printf("TagP(%d)", c); + } + else if (isTagNonPtr(c)) { + Printf("TagNP(%d)", c); + } + else if (isSpec(c)) { + Printf("TagS(%d)", c); + } + else if (isText(c)) { + Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c)); + } + else if (isInventedVar(c)) { + Printf("invented(%d)", c-INVAR_BASE_ADDR); + } + else if (isInventedDictVar(c)) { + Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR); + } + else { Int tag = whatIs(c); switch (tag) { case AP: @@ -1654,33 +2252,29 @@ Int depth; { Printf("ptr(%p)",ptrOf(c)); break; case CLASS: - Printf("class(%d)", c-CLASSMIN); - if (CLASSMIN <= c && c < classHw) { - Printf("=\"%s\"", textToStr(cclass(c).text)); - } + Printf("class(%d)", c-CCLASS_BASE_ADDR); + Printf("=\"%s\"", textToStr(cclass(c).text)); break; case INSTANCE: - Printf("instance(%d)", c - INSTMIN); + Printf("instance(%d)", c - INST_BASE_ADDR); break; case NAME: - Printf("name(%d)", c-NAMEMIN); - if (NAMEMIN <= c && c < nameHw) { - Printf("=\"%s\"", textToStr(name(c).text)); - } + Printf("name(%d)", c-NAME_BASE_ADDR); + Printf("=\"%s\"", textToStr(name(c).text)); break; case TYCON: - Printf("tycon(%d)", c-TYCMIN); - if (TYCMIN <= c && c < tyconHw) - Printf("=\"%s\"", textToStr(tycon(c).text)); + Printf("tycon(%d)", c-TYCON_BASE_ADDR); + Printf("=\"%s\"", textToStr(tycon(c).text)); break; case MODULE: - Printf("module(%d)", c - MODMIN); + Printf("module(%d)", c - MODULE_BASE_ADDR); + Printf("=\"%s\"", textToStr(module(c).text)); break; case OFFSET: Printf("Offset %d", offsetOf(c)); break; case TUPLE: - Printf("Tuple %d", tupleOf(c)); + Printf("%s", textToStr(ghcTupleText(c))); break; case POLYTYPE: Printf("Polytype"); @@ -1700,9 +2294,6 @@ Int depth; { } Printf(")"); break; - case NIL: - Printf("NIL"); - break; case WILDCARD: Printf("_"); break; @@ -1721,6 +2312,14 @@ Int depth; { case CONOPCELL: Printf("{id %s}",textToStr(textOf(c))); break; +#if IPARAM + case IPCELL : + Printf("{ip %s}",textToStr(textOf(c))); + break; + case IPVAR : + Printf("?%s",textToStr(textOf(c))); + break; +#endif case QUALIDENT: Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c))); break; @@ -1794,11 +2393,42 @@ Int depth; { print(snd(snd(c)),depth-1); Putchar(')'); break; + case DICTAP: + Printf("(DICTAP,"); + print(snd(c),depth-1); + Putchar(')'); + break; + case UNBOXEDTUP: + Printf("(UNBOXEDTUP,"); + print(snd(c),depth-1); + Putchar(')'); + break; + case ZTUP2: + Printf("'); + break; + case ZTUP3: + Printf("'); + break; + case BANG: + Printf("(BANG,"); + print(snd(c),depth-1); + Putchar(')'); + break; default: - if (isBoxTag(tag)) { - Printf("Tag(%d)=%d", c, tag); - } else if (isConTag(tag)) { - Printf("%d@(%d,",c,tag); + if (isTagNonPtr(tag)) { + Printf("(TagNP=%d,%d)", c, tag); + } else if (isTagPtr(tag)) { + Printf("(TagP=%d,",tag); print(snd(c), depth-1); Putchar(')'); break; @@ -1812,7 +2442,7 @@ Int depth; { } FlushStdout(); } -#endif + Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */ Cell c; { /* also recognises DICTVAR cells */ @@ -1856,6 +2486,16 @@ Cell c; { return isPair(c) && (fst(c)==QUALIDENT); } +Bool eqQualIdent ( QualId c1, QualId c2 ) +{ + assert(isQualIdent(c1)); + if (!isQualIdent(c2)) { + assert(isQualIdent(c2)); + } + return qmodOf(c1)==qmodOf(c2) && + qtextOf(c1)==qtextOf(c2); +} + Bool isIdent(c) /* is cell an identifier? */ Cell c; { if (!isPair(c)) return FALSE; @@ -1878,20 +2518,22 @@ Cell c; { Int intOf(c) /* find integer value of cell? */ Cell c; { - if (!isInt(c)) { - assert(isInt(c)); } - return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO); + assert(isInt(c)); + return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO); } Cell mkInt(n) /* make cell representing integer */ Int n; { - return (MINSMALLINT <= n && n <= MAXSMALLINT) - ? INTZERO+n + return (SMALL_INT_MIN <= SMALL_INT_ZERO+n && + SMALL_INT_ZERO+n <= SMALL_INT_MAX) + ? SMALL_INT_ZERO+n : pair(INTCELL,n); } -#if SIZEOF_INTP == SIZEOF_INT +#if SIZEOF_VOID_P == SIZEOF_INT + typedef union {Int i; Ptr p;} IntOrPtr; + Cell mkPtr(p) Ptr p; { @@ -1908,6 +2550,7 @@ Cell c; x.i = snd(c); return x.p; } + Cell mkCPtr(p) Ptr p; { @@ -1924,8 +2567,11 @@ Cell c; x.i = snd(c); return x.p; } -#elif SIZEOF_INTP == 2*SIZEOF_INT + +#elif SIZEOF_VOID_P == 2*SIZEOF_INT + typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr; + Cell mkPtr(p) Ptr p; { @@ -1943,23 +2589,32 @@ Cell c; x.i.i2 = intOf(snd(snd(c))); return x.p; } -#else -#warning "type Addr not supported on this architecture - don't use it" -Cell mkPtr(p) + +Cell mkCPtr(p) Ptr p; { - ERRMSG(0) "mkPtr: type Addr not supported on this architecture" - EEND; + IntOrPtr x; + x.p = p; + return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2))); } -Ptr ptrOf(c) +Ptr cptrOf(c) Cell c; { - ERRMSG(0) "ptrOf: type Addr not supported on this architecture" - EEND; + IntOrPtr x; + assert(fst(c) == CPTRCELL); + x.i.i1 = intOf(fst(snd(c))); + x.i.i2 = intOf(snd(snd(c))); + return x.p; } + +#else + +#error "Can't implement mkPtr/ptrOf on this architecture." + #endif + String stringNegate( s ) String s; { @@ -2033,6 +2688,15 @@ List xs, ys; { /* list xs onto list ys... */ return ys; } +QualId qualidIsMember ( QualId q, List xs ) +{ + for (; nonNull(xs); xs=tl(xs)) { + if (eqQualIdent(q, hd(xs))) + return hd(xs); + } + return NIL; +} + Cell varIsMember(t,xs) /* Test if variable is a member of */ Text t; /* given list of variables */ List xs; { @@ -2186,6 +2850,78 @@ List xs; { /* non destructive */ return outs; } + +/* -------------------------------------------------------------------------- + * Tagged tuples (experimental) + * ------------------------------------------------------------------------*/ + +static void z_tag_check ( Cell x, int tag, char* caller ) +{ + char buf[100]; + if (isNull(x)) { + sprintf(buf,"z_tag_check(%s): null\n", caller); + internal(buf); + } + if (whatIs(x) != tag) { + sprintf(buf, + "z_tag_check(%s): tag was %d, expected %d\n", + caller, whatIs(x), tag ); + internal(buf); + } +} + +Cell zpair ( Cell x1, Cell x2 ) +{ return ap(ZTUP2,ap(x1,x2)); } +Cell zfst ( Cell zpair ) +{ z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); } +Cell zsnd ( Cell zpair ) +{ z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); } + +Cell ztriple ( Cell x1, Cell x2, Cell x3 ) +{ return ap(ZTUP3,ap(x1,ap(x2,x3))); } +Cell zfst3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); } +Cell zsnd3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); } +Cell zthd3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); } + +Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 ) +{ return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); } +Cell zsel14 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); } +Cell zsel24 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); } +Cell zsel34 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); } +Cell zsel44 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); } + +Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 ) +{ return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); } +Cell zsel15 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); } +Cell zsel25 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); } +Cell zsel35 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); } +Cell zsel45 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); } +Cell zsel55 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); } + + +Cell unap ( int tag, Cell c ) +{ + char buf[100]; + if (whatIs(c) != tag) { + sprintf(buf, "unap: specified %d, actual %d\n", + tag, whatIs(c) ); + internal(buf); + } + return snd(c); +} + /* -------------------------------------------------------------------------- * Operations on applications: * ------------------------------------------------------------------------*/ @@ -2237,113 +2973,154 @@ List args; { return f; } - /* -------------------------------------------------------------------------- - * plugin support + * debugging support * ------------------------------------------------------------------------*/ -/*--------------------------------------------------------------------------- - * GreenCard entry points - * - * GreenCard generated code accesses Hugs data structures and functions - * (only) via these functions (which are stored in the virtual function - * table hugsAPI1. - *-------------------------------------------------------------------------*/ - -#if GREENCARD - -static Cell makeTuple Args((Int)); -static Cell makeInt Args((Int)); -static Cell makeChar Args((Char)); -static Char CharOf Args((Cell)); -static Cell makeFloat Args((FloatPro)); -static Void* derefMallocPtr Args((Cell)); -static Cell* Fst Args((Cell)); -static Cell* Snd Args((Cell)); - -static Cell makeTuple(n) Int n; { return mkTuple(n); } -static Cell makeInt(n) Int n; { return mkInt(n); } -static Cell makeChar(n) Char n; { return mkChar(n); } -static Char CharOf(n) Cell n; { return charOf(n); } -static Cell makeFloat(n) FloatPro n; { return mkFloat(n); } -static Void* derefMallocPtr(n) Cell n; { return derefMP(n); } -static Cell* Fst(n) Cell n; { return (Cell*)&fst(n); } -static Cell* Snd(n) Cell n; { return (Cell*)&snd(n); } - -HugsAPI1* hugsAPI1() { - static HugsAPI1 api; - static Bool initialised = FALSE; - if (!initialised) { - api.nameTrue = nameTrue; - api.nameFalse = nameFalse; - api.nameNil = nameNil; - api.nameCons = nameCons; - api.nameJust = nameJust; - api.nameNothing = nameNothing; - api.nameLeft = nameLeft; - api.nameRight = nameRight; - api.nameUnit = nameUnit; - api.nameIORun = nameIORun; - api.makeInt = makeInt; - api.makeChar = makeChar; - api.CharOf = CharOf; - api.makeFloat = makeFloat; - api.makeTuple = makeTuple; - api.pair = pair; - api.mkMallocPtr = mkMallocPtr; - api.derefMallocPtr = derefMallocPtr; - api.mkStablePtr = mkStablePtr; - api.derefStablePtr = derefStablePtr; - api.freeStablePtr = freeStablePtr; - api.eval = eval; - api.evalWithNoError = evalWithNoError; - api.evalFails = evalFails; - api.whnfArgs = &whnfArgs; - api.whnfHead = &whnfHead; - api.whnfInt = &whnfInt; - api.whnfFloat = &whnfFloat; - api.garbageCollect = garbageCollect; - api.stackOverflow = hugsStackOverflow; - api.internal = internal; - api.registerPrims = registerPrims; - api.addPrimCfun = addPrimCfun; - api.inventText = inventText; - api.Fst = Fst; - api.Snd = Snd; - api.cellStack = cellStack; - api.sp = &sp; - } - return &api; -} - -#endif /* GREENCARD */ +static String maybeModuleStr ( Module m ) +{ + if (isModule(m)) return textToStr(module(m).text); else return "??"; +} + +static String maybeNameStr ( Name n ) +{ + if (isName(n)) return textToStr(name(n).text); else return "??"; +} + +static String maybeTyconStr ( Tycon t ) +{ + if (isTycon(t)) return textToStr(tycon(t).text); else return "??"; +} + +static String maybeClassStr ( Class c ) +{ + if (isClass(c)) return textToStr(cclass(c).text); else return "??"; +} + +static String maybeText ( Text t ) +{ + if (isNull(t)) return "(nil)"; + return textToStr(t); +} + +static void print100 ( Int x ) +{ + print ( x, 100); printf("\n"); +} + +void dumpTycon ( Int t ) +{ + if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR; + if (!isTycon(t)) { + printf ( "dumpTycon %d: not a tycon\n", t); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(tycon(t).text) ); + printf ( " line: %d\n", tycon(t).line ); + printf ( " mod: %s\n", maybeModuleStr(tycon(t).mod)); + printf ( " tuple: %d\n", tycon(t).tuple); + printf ( " arity: %d\n", tycon(t).arity); + printf ( " kind: "); print100(tycon(t).kind); + printf ( " what: %d\n", tycon(t).what); + printf ( " defn: "); print100(tycon(t).defn); + printf ( " cToT: %d %s\n", tycon(t).conToTag, + maybeNameStr(tycon(t).conToTag)); + printf ( " tToC: %d %s\n", tycon(t).tagToCon, + maybeNameStr(tycon(t).tagToCon)); + printf ( " itbl: %p\n", tycon(t).itbl); + printf ( " nextTH: %d %s\n", tycon(t).nextTyconHash, + maybeTyconStr(tycon(t).nextTyconHash)); + printf ( "}\n" ); +} + +void dumpName ( Int n ) +{ + if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR; + if (!isName(n)) { + printf ( "dumpName %d: not a name\n", n); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(name(n).text) ); + printf ( " line: %d\n", name(n).line ); + printf ( " mod: %s\n", maybeModuleStr(name(n).mod)); + printf ( " syntax: %d\n", name(n).syntax ); + printf ( " parent: %d\n", name(n).parent ); + printf ( " arity: %d\n", name(n).arity ); + printf ( " number: %d\n", name(n).number ); + printf ( " type: "); print100(name(n).type); + printf ( " defn: %d\n", name(n).defn ); + printf ( " stgVar: "); print100(name(n).stgVar); + printf ( " cconv: %d\n", name(n).callconv ); + printf ( " primop: %p\n", name(n).primop ); + printf ( " itbl: %p\n", name(n).itbl ); + printf ( " nextNH: %d\n", name(n).nextNameHash ); + printf ( "}\n" ); +} + + +void dumpClass ( Int c ) +{ + if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR; + if (!isClass(c)) { + printf ( "dumpClass %d: not a class\n", c); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(cclass(c).text) ); + printf ( " line: %d\n", cclass(c).line ); + printf ( " mod: %s\n", maybeModuleStr(cclass(c).mod)); + printf ( " arity: %d\n", cclass(c).arity ); + printf ( " level: %d\n", cclass(c).level ); + printf ( " kinds: "); print100( cclass(c).kinds ); + printf ( " fds: %d\n", cclass(c).fds ); + printf ( " xfds: %d\n", cclass(c).xfds ); + printf ( " head: "); print100( cclass(c).head ); + printf ( " dcon: "); print100( cclass(c).dcon ); + printf ( " supers: "); print100( cclass(c).supers ); + printf ( " #supers: %d\n", cclass(c).numSupers ); + printf ( " dsels: "); print100( cclass(c).dsels ); + printf ( " members: "); print100( cclass(c).members ); + printf ( "#members: %d\n", cclass(c).numMembers ); + printf ( "defaults: "); print100( cclass(c).defaults ); + printf ( " insts: "); print100( cclass(c).instances ); + printf ( "}\n" ); +} + + +void dumpInst ( Int i ) +{ + if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR; + if (!isInst(i)) { + printf ( "dumpInst %d: not an instance\n", i); + return; + } + printf ( "{\n" ); + printf ( " class: %s\n", maybeClassStr(inst(i).c) ); + printf ( " line: %d\n", inst(i).line ); + printf ( " mod: %s\n", maybeModuleStr(inst(i).mod)); + printf ( " kinds: "); print100( inst(i).kinds ); + printf ( " head: "); print100( inst(i).head ); + printf ( " specs: "); print100( inst(i).specifics ); + printf ( " #specs: %d\n", inst(i).numSpecifics ); + printf ( " impls: "); print100( inst(i).implements ); + printf ( " builder: %s\n", maybeNameStr( inst(i).builder ) ); + printf ( "}\n" ); +} /* -------------------------------------------------------------------------- * storage control: * ------------------------------------------------------------------------*/ -#if DYN_TABLES -static void far* safeFarCalloc Args((Int,Int)); -static void far* safeFarCalloc(n,s) /* allocate table storage and check*/ -Int n, s; { /* for non-null return */ - void far* tab = farCalloc(n,s); - if (tab==0) { - ERRMSG(0) "Cannot allocate run-time tables" - EEND; - } - return tab; -} -#define TABALLOC(v,t,n) v=(t far*)safeFarCalloc(n,sizeof(t)); -#else -#define TABALLOC(v,t,n) -#endif - Void storage(what) Int what; { Int i; switch (what) { + case POSTPREL: break; + case RESET : clearStack(); /* the next 2 statements are particularly important @@ -2357,56 +3134,77 @@ Int what; { lsave = NIL; rsave = NIL; if (isNull(lastExprSaved)) - savedText = NUM_TEXT; + savedText = TEXT_SIZE; break; case MARK : start(); - for (i=NAMEMIN; i