-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Primitives for manipulating global data structures
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * 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.2 $
- * $Date: 1998/12/02 13:22:41 $
+ * $Revision: 1.37 $
+ * $Date: 2000/01/11 14:51:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
+#include "backend.h"
#include "connect.h"
-#include "charset.h"
#include "errors.h"
-#include "link.h" /* for nameCons */
+#include "object.h"
#include <setjmp.h>
-#include "machdep.h" /* gc-related functions */
-
/*#define DEBUG_SHOWUSE*/
/* --------------------------------------------------------------------------
static Void local markSnd Args((Cell));
static Cell local lowLevelLastIn Args((Cell));
static Cell local lowLevelLastOut Args((Cell));
-static Module local moduleOfScript Args((Script));
-static Script local scriptThisFile Args((Text));
-
+ Module local moduleOfScript Args((Script));
+ Script local scriptThisFile Args((Text));
/* --------------------------------------------------------------------------
* Text storage:
String identToStr(v) /*find string corresp to given ident or qualified name*/
Cell v; {
- static char newVar[33];
-
- assert(isPair(v));
- switch (fst(v)) {
- case VARIDCELL :
- case VAROPCELL :
- case CONIDCELL :
- case CONOPCELL : return text+textOf(v);
-
- case QUALIDENT : sprintf(newVar,"%s.%s",
- text+qmodOf(v),text+qtextOf(v));
- return newVar;
+ if (!isPair(v)) {
+ internal("identToStr");
}
- internal("identToStr 2");
-}
-
-Syntax identSyntax(v) /* find syntax of ident or qualified ident */
-Cell v; {
- assert(isPair(v));
switch (fst(v)) {
case VARIDCELL :
case VAROPCELL :
case CONIDCELL :
- case CONOPCELL : return syntaxOf(textOf(v));
+ case CONOPCELL : return text+textOf(v);
- case QUALIDENT : return syntaxOf(qtextOf(v));
- }
- internal("identSyntax 2");
+ case QUALIDENT : { Text pos = textHw;
+ Text t = qmodOf(v);
+ while (pos+1 < savedText && text[t]!=0) {
+ text[pos++] = text[t++];
+ }
+ if (pos+1 < savedText) {
+ text[pos++] = '.';
+ }
+ t = qtextOf(v);
+ while (pos+1 < savedText && text[t]!=0) {
+ text[pos++] = text[t++];
+ }
+ text[pos] = '\0';
+ return text+textHw;
+ }
+ }
+ internal("identToStr2");
+ return 0; /* NOTREACHED */
}
Text inventText() { /* return new unused variable name */
return (t<0 || t>=NUM_TEXT);
}
+#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; {
int v, j = 3;
return savedText;
}
-/* --------------------------------------------------------------------------
- * Syntax storage:
- *
- * Operator declarations are stored in a table which associates Text values
- * with Syntax values.
- * ------------------------------------------------------------------------*/
-static Int syntaxHw; /* next unused syntax table entry */
-static struct strSyntax { /* table of Text <-> Syntax values */
- Text text;
- Syntax syntax;
-} DEFTABLE(tabSyntax,NUM_SYNTAX);
+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;
-Syntax defaultSyntax(t) /* Find default syntax of var named */
-Text t; { /* by t ... */
- String s = textToStr(t);
- return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
+ parse_error:
+ free(p);
+ fprintf ( stderr, "\nstring = `%s'\n", s );
+ internal ( "unZcodeThenFindText: parse error on above string");
+ return NIL; /*notreached*/
}
-Syntax syntaxOf(t) /* look up syntax of operator symbol*/
-Text t; {
- int i;
-
- for (i=0; i<syntaxHw; ++i)
- if (tabSyntax[i].text==t)
- return tabSyntax[i].syntax;
- return defaultSyntax(t);
-}
-
-Void addSyntax(line,t,sy) /* add (t,sy) to syntax table */
-Int line;
-Text t;
-Syntax sy; {
- int i;
-
- for (i=0; i<syntaxHw; ++i)
- if (tabSyntax[i].text==t) {
- /* There's no problem with multiple identical fixity declarations.
- * - but note that it's not allowed by the Haskell report. ADR
- */
- if (tabSyntax[i].syntax == sy) return;
- ERRMSG(line) "Attempt to redefine syntax of operator \"%s\"",
- textToStr(t)
- EEND;
- }
- if (syntaxHw>=NUM_SYNTAX) {
- ERRMSG(line) "Too many fixity declarations"
- EEND;
- }
-
- tabSyntax[syntaxHw].text = t;
- tabSyntax[syntaxHw].syntax = sy;
- syntaxHw++;
+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;
+ }
+ 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 )
+{
+ Bool ok =
+ (whatIs(c)==VARIDCELL
+ || whatIs(c)==CONIDCELL
+ || whatIs(c)==VAROPCELL
+ || whatIs(c)==CONOPCELL
+ || whatIs(c)==STRCELL
+ || whatIs(c)==DICTVAR
+ );
+ if (!ok) {
+ fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) );
+ internal("textOf: bad tag");
+ }
+ return snd(c);
}
/* --------------------------------------------------------------------------
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).what = NIL;
tycon(tyconHw).conToTag = NIL;
tycon(tyconHw).tagToCon = NIL;
+ tycon(tyconHw).tuple = -1;
tycon(tyconHw).mod = currentModule;
+ tycon(tyconHw).itbl = NULL;
module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
tycon(tyconHw).nextTyconHash = tyconHash[h];
tyconHash[h] = tyconHw;
Tycon tc = tyconHash[tHash(t)];
while (nonNull(tc) && tycon(tc).text!=t)
- tc = tycon(tc).nextTyconHash;
+ tc = tycon(tc).nextTyconHash;
return tc;
}
Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
Tycon tc; {
- Tycon oldtc = findTycon(tycon(tc).text);
+ Tycon oldtc;
+ assert(whatIs(tc)==TYCON || whatIs(tc)==TUPLE);
+ oldtc = findTycon(tycon(tc).text);
if (isNull(oldtc)) {
hashTycon(tc);
module(currentModule).tycons=cons(tc,module(currentModule).tycons);
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;
+ if (!(isTycon(tc) || isTuple(tc))) {
+ printf("\nbad stuff: " ); print(tc,10); printf("\n");
+ assert(isTycon(tc) || isTuple(tc));
+ }
+ if (1) {
+ Text t = tycon(tc).text;
+ Int h = tHash(t);
+ tycon(tc).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tc;
+ }
}
Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
Cell id; {
- assert(isPair(id));
+ if (!isPair(id)) internal("findQualTycon");
switch (fst(id)) {
case CONIDCELL :
case CONOPCELL :
Text t = qtextOf(id);
Module m = findQualifier(qmodOf(id));
List es = NIL;
- if (isNull(m))
- return NIL;
- if (m==currentModule) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- return findTycon(t);
- }
+ if (isNull(m)) return NIL;
for(es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
}
default : internal("findQualTycon2");
}
+ return NIL; /* NOTREACHED */
}
Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
-Text t;
-Kind kind;
-Int ar;
-Cell what;
-Cell defn; {
+Text t;
+Kind kind;
+Int ar;
+Cell what;
+Cell defn; {
Tycon tc = newTycon(t);
tycon(tc).line = 0;
tycon(tc).kind = kind;
return ts;
}
+Text ghcTupleText_n ( Int n )
+{
+ Int i;
+ char buf[104];
+ if (n < 0 || n >= 100) internal("ghcTupleText_n");
+ buf[0] = '(';
+ for (i = 1; i <= n; i++) buf[i] = ',';
+ buf[n+1] = ')';
+ buf[n+2] = 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 = TYCMIN; i < tyconHw; i++)
+ if (tycon(i).tuple == n) return i;
+ internal("mkTuple: request for non-existent tuple");
+}
+
+
/* --------------------------------------------------------------------------
* Name storage:
*
#define NAMEHSZ 256 /* Size of Name hash table */
#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */
-/*static*/Name nameHw; /* next unused name */
+ 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) /* add new name to name table */
-Text t; {
+Name newName(t,parent) /* Add new name to name table */
+Text t;
+Cell parent; {
+ 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).callconv = NIL;
name(nameHw).type = NIL;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
- hashName(nameHw);
+ name(nameHw).itbl = NULL;
module(currentModule).names=cons(nameHw,module(currentModule).names);
+ name(nameHw).nextNameHash = nameHash[h];
+ nameHash[h] = nameHw;
return nameHw++;
}
-Name findName(t) /* locate name in name table */
+Name findName(t) /* Locate name in name table */
Text t; {
Name n = nameHash[nHash(t)];
- while (nonNull(n) && name(n).text!=t) {
- n = name(n).nextNameHash;
- }
- assert(isNull(n) || (isName(n) && n < nameHw));
+ while (nonNull(n) && name(n).text!=t)
+ n = name(n).nextNameHash;
return n;
}
-Name addName(nm) /* Insert Name in name table - if no clash is caused */
-Name nm; {
- Name oldnm = findName(name(nm).text);
+Name addName(nm) /* Insert Name in name table - if */
+Name nm; { /* no clash is caused */
+ Name oldnm;
+ assert(whatIs(nm)==NAME);
+ oldnm = findName(name(nm).text);
if (isNull(oldnm)) {
hashName(nm);
module(currentModule).names=cons(nm,module(currentModule).names);
return nm;
- } else {
+ } else
return oldnm;
- }
}
-static Void local hashName(nm) /* Insert Name into hash table */
+static Void local hashName(nm) /* Insert Name into hash table */
Name nm; {
- Text t = name(nm).text;
- Int h = nHash(t);
+ Text t;
+ Int h;
+ assert(isName(nm));
+ t = name(nm).text;
+ h = nHash(t);
name(nm).nextNameHash = nameHash[h];
nameHash[h] = nm;
}
-Name findQualName(line,id) /* locate (possibly qualified) name in name table */
-Int line;
-Cell id; {
- assert(isPair(id));
+Name findQualName(id) /* Locate (possibly qualified) name*/
+Cell id; { /* in name table */
+ if (!isPair(id))
+ internal("findQualName");
switch (fst(id)) {
case VARIDCELL :
case VAROPCELL :
Module m = findQualifier(qmodOf(id));
List es = NIL;
if (isNull(m)) return NIL;
- if (m==currentModule) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- return findName(t);
- }
for(es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isName(e) && name(e).text==t)
List subentities = NIL;
Cell c = fst(e);
if (isTycon(c)
- && (tycon(c).what == DATATYPE
- || tycon(c).what == NEWTYPE))
+ && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
subentities = tycon(c).defn;
else if (isClass(c))
subentities = cclass(c).members;
for(; nonNull(subentities); subentities=tl(subentities)) {
- assert(isName(hd(subentities)));
+ if (!isName(hd(subentities)))
+ internal("findQualName3");
if (name(hd(subentities)).text == t)
return hd(subentities);
}
}
default : internal("findQualName2");
}
+ return 0; /* NOTREACHED */
+}
+
+
+Name nameFromStgVar ( StgVar v )
+{
+ Int n;
+ for (n = NAMEMIN; n < nameHw; n++)
+ 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 = NAMEMIN; n < nameHw; n++)
+ if (name(n).text == t) break;
+ if (n == nameHw) 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:
* ------------------------------------------------------------------------*/
-Name addPrimCfun(t,arity,no,rep) /* add primitive constructor func */
-Text t;
+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 arity, Int no, Int rep )
+{
+ 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 = arity;
+ name(n).number = cfunNo(no);
+ name(n).type = NIL;
+ name(n).primop = (void*)rep;
+
+ t = newTycon(typeT);
+ tycon(t).what = DATATYPE;
+ return n;
+}
+
+
+Tycon addTupleTycon ( Int n )
+{
+ Int i;
+ Kind k;
+ Tycon t;
+ Module m;
+ Name nm;
+
+ for (i = TYCMIN; i < tyconHw; i++)
+ if (tycon(i).tuple == n) return i;
+
+ if (combined)
+ m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
+ m = findModule(findText("Prelude"));
+
+ 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;
+ 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;
Int no;
Int rep; { /* Really AsmRep */
- Name n = newName(t);
+ Name n = newName(t,NIL);
name(n).arity = arity;
name(n).number = cfunNo(no);
name(n).type = NIL;
return n;
}
+
+Name addPrimCfun(t,arity,no,type) /* add primitive constructor func */
+Text t;
+Int arity;
+Int no;
+Cell type; {
+ Name n = newName(t,NIL);
+ name(n).arity = arity;
+ name(n).number = cfunNo(no);
+ name(n).type = type;
+ return n;
+}
+
+
Int sfunPos(s,c) /* Find position of field with */
Name s; /* selector s in constructor c. */
Name c; {
List cns;
cns = name(s).defn;
- for (; nonNull(cns); cns=tl(cns)) {
+ for (; nonNull(cns); cns=tl(cns))
if (fst(hd(cns))==c)
return intOf(snd(hd(cns)));
- }
internal("sfunPos");
- return 0;/*NOTREACHED*/
+ return 0;/* NOTREACHED */
}
static List local insertName(nm,ns) /* insert name nm into sorted list */
String pat; /* to list of names ns */
List ns; { /* Null pattern matches every name */
Name nm; /* (Names with NIL type, or hidden */
+#if 1
for (nm=NAMEMIN; nm<nameHw; ++nm) /* or invented names are excluded) */
if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
String str = textToStr(name(nm).text);
ns = insertName(nm,ns);
}
return ns;
+#else
+ List mns = module(currentModule).names;
+ for(; nonNull(mns); mns=tl(mns)) {
+ Name nm = hd(mns);
+ if (!inventedText(name(nm).text)) {
+ String str = textToStr(name(nm).text);
+ if (str[0]!='_' && (!pat || stringMatch(pat,str)))
+ ns = insertName(nm,ns);
+ }
+ }
+ return ns;
+#endif
}
/* --------------------------------------------------------------------------
static Class classHw; /* next unused class */
static List classes; /* list of classes in current scope */
static Inst instHw; /* next unused instance record */
-#if USE_DICTHW
-static Int dictHw; /* next unused dictionary number */
-#endif
struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records */
struct strInst far *tabInst; /* (pointer to) table of instances */
cclass(classHw).arity = 0;
cclass(classHw).kinds = NIL;
cclass(classHw).head = NIL;
+ cclass(classHw).fds = NIL;
+ cclass(classHw).xfds = 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);
for (cs=classes; nonNull(cs); cs=tl(cs)) {
cl=hd(cs);
if (cclass(cl).text==t)
- return cl;
+ return cl;
}
return NIL;
}
-Class addClass(c) /* Insert Class in class list - if no clash caused */
-Class c; {
- Class oldc = findClass(cclass(c).text);
+Class addClass(c) /* Insert Class in class list */
+Class c; { /* - if no clash caused */
+ 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);
return c;
- } else
+ }
+ else
return oldc;
}
-Class findQualClass(c) /* look for (possibly qualified) class in class list */
-Cell c; {
+Class findQualClass(c) /* Look for (possibly qualified) */
+Cell c; { /* class in class list */
if (!isQualIdent(c)) {
return findClass(textOf(c));
} else {
- Text t = qtextOf(c);
- Module m = findQualifier(qmodOf(c));
+ Text t = qtextOf(c);
+ Module m = findQualifier(qmodOf(c));
List es = NIL;
- if (isNull(m)) return NIL;
- for(es=module(m).exports; nonNull(es); es=tl(es)) {
+ if (isNull(m))
+ return NIL;
+ for (es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
return fst(e);
return NIL;
}
-Inst newInst() { /* add new instance to table */
+Inst newInst() { /* Add new instance to table */
if (instHw-INSTMIN >= NUM_INSTS) {
ERRMSG(0) "Instance storage space exhausted"
EEND;
return instHw++;
}
+#ifdef DEBUG_DICTS
+extern Void printInst Args((Inst));
+
+Void printInst(in)
+Inst in; {
+ Class cl = inst(in).c;
+ Printf("%s-", textToStr(cclass(cl).text));
+ printType(stdout,inst(in).t);
+}
+#endif /* DEBUG_DICTS */
+
Inst findFirstInst(tc) /* look for 1st instance involving */
Tycon tc; { /* the type constructor tc */
return findNextInst(tc,INSTMIN-1);
|| 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 = CLASSMIN; cl < classHw; cl++) {
+ 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 = TYCMIN; tc < tyconHw; tc++) {
+ 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;
+}
+
+Tycon findTyconInAnyModule ( Text t )
+{
+ Tycon tc;
+ for (tc = TYCMIN; tc < tyconHw; tc++)
+ if (tycon(tc).text == t) return tc;
+ return NIL;
+}
+
+Class findClassInAnyModule ( Text t )
+{
+ Class cc;
+ for (cc = CLASSMIN; cc < classHw; cc++)
+ if (cclass(cc).text == t) return cc;
+ return NIL;
+}
+
+Name findNameInAnyModule ( Text t )
+{
+ Name nm;
+ for (nm = NAMEMIN; nm < nameHw; nm++)
+ if (name(nm).text == t) return nm;
+ 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 = NAMEMIN; nm < nameHw; nm++) {
+ 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;
+}
+
+
+/* returns List of QualId */
+List getAllKnownTyconsAndClasses ( void )
+{
+ Tycon tc;
+ Class nw;
+ List xs = NIL;
+ for (tc = TYCMIN; tc < tyconHw; tc++) {
+ /* almost certainly undue paranoia about duplicate avoidance, but .. */
+ QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
+ if (!qualidIsMember(q,xs))
+ xs = cons ( q, xs );
+ }
+ for (nw = CLASSMIN; nw < classHw; nw++) {
+ QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
+ if (!qualidIsMember(q,xs))
+ xs = cons ( q, xs );
+ }
+ return xs;
+}
+
/* --------------------------------------------------------------------------
* Control stack:
*
Cell DEFTABLE(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<UPPER_DISP; i++) {
+ ERRTEXT "\nwhile evaluating: " ETHEN
+ ERREXPR(evalRoots[rootsp-i]);
+ }
+ ERRTEXT "\n..." ETHEN
+ for (i=LOWER_DISP-1; 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:
*
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).objectFile = 0;
+ module(moduleHw).text = t; /* clear new module record */
+ module(moduleHw).qualImports = NIL;
+ module(moduleHw).fake = FALSE;
+ module(moduleHw).exports = NIL;
+ module(moduleHw).tycons = NIL;
+ module(moduleHw).names = NIL;
+ module(moduleHw).classes = NIL;
+ module(moduleHw).object = NULL;
+ module(moduleHw).objectExtras = NULL;
+ module(moduleHw).objectExtraNames = NIL;
return moduleHw++;
}
+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)
+ );
+ printf ( "end MODULES\n" );
+ fflush(stderr); fflush(stdout);
+}
+
+
Module findModule(t) /* locate Module in module table */
Text t; {
Module m;
for(m=MODMIN; m<moduleHw; ++m) {
- if (module(m).text==t) {
+ if (module(m).text==t)
return m;
- }
}
return NIL;
}
case CONIDCELL : return findModule(textOf(c));
default : internal("findModid");
}
+ return NIL;/*NOTUSED*/
}
static local Module findQualifier(t) /* locate Module in import list */
Text t; {
Module ms;
- if (t==module(modulePreludeHugs).text) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- return modulePreludeHugs;
- }
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
- if (textOf(fst(hd(ms)))==t) {
+ if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
- }
}
+#if 1 /* mpj */
+ if (module(currentModule).text==t)
+ return currentModule;
+#endif
return NIL;
}
Void setCurrModule(m) /* set lookup tables for current module */
Module m; {
Int i;
+ assert(isModule(m));
if (m!=currentModule) {
currentModule = m; /* This is the only assignment to currentModule */
- for (i=0; i<TYCONHSZ; ++i) {
+ for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
- }
mapProc(hashTycon,module(m).tycons);
- for (i=0; i<NAMEHSZ; ++i) {
+ for (i=0; i<NAMEHSZ; ++i)
nameHash[i] = NIL;
- }
mapProc(hashName,module(m).names);
classes = module(m).classes;
}
}
+Name jrsFindQualName ( Text mn, Text sn )
+{
+ Module m;
+ List ns;
+
+ for (m=MODMIN; m<moduleHw; m++)
+ if (module(m).text == mn) break;
+ if (m == moduleHw) return NIL;
+
+ for (ns = module(m).names; nonNull(ns); ns=tl(ns))
+ if (name(hd(ns)).text == sn) return hd(ns);
+
+ return NIL;
+}
+
+
+char* nameFromOPtr ( void* p )
+{
+ int i;
+ Module m;
+ for (m=MODMIN; m<moduleHw; m++) {
+ if (module(m).object) {
+ char* nm = ocLookupAddr ( module(m).object, p );
+ if (nm) return nm;
+ }
+ }
+ return NULL;
+}
+
+
+void* lookupOTabName ( Module m, char* sym )
+{
+ return ocLookupSym ( module(m).object, sym );
+}
+
+
+void* lookupOExtraTabName ( char* sym )
+{
+ ObjectCode* oc;
+ Module m;
+ for (m = MODMIN; m < moduleHw; m++) {
+ for (oc = module(m).objectExtras; oc; oc=oc->next) {
+ void* ad = ocLookupSym ( oc, sym );
+ if (ad) return ad;
+ }
+ }
+ return NULL;
+}
+
+
+OSectionKind lookupSection ( void* ad )
+{
+ int i;
+ Module m;
+ ObjectCode* oc;
+ OSectionKind sect;
+
+ for (m=MODMIN; m<moduleHw; m++) {
+ if (module(m).object) {
+ sect = ocLookupSection ( module(m).object, ad );
+ if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+ return sect;
+ }
+ for (oc = module(m).objectExtras; oc; oc=oc->next) {
+ sect = ocLookupSection ( oc, ad );
+ if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+ return sect;
+ }
+ }
+ return HUGS_SECTIONKIND_OTHER;
+}
+
+
/* --------------------------------------------------------------------------
* Script file storage:
*
Text textHw;
Text nextNewText;
Text nextNewDText;
- Int syntaxHw;
Module moduleHw;
Tycon tyconHw;
Name nameHw;
Class classHw;
Inst instHw;
-#if USE_DICTHW
- Int dictHw;
-#endif
#if TREX
Ext extHw;
#endif
static Void local showUse(msg,val,mx)
String msg;
Int val, mx; {
- Printf("%6s : %d of %d (%d%%)\n",msg,val,mx,(100*val)/mx);
+ Printf("%6s : %5d of %5d (%2d%%)\n",msg,val,mx,(100*val)/mx);
}
#endif
static Script scriptHw; /* next unused script number */
static script scripts[NUM_SCRIPTS]; /* storage for script records */
+
+void ppScripts ( void )
+{
+ Int i;
+ fflush(stderr); fflush(stdout);
+ printf ( "begin SCRIPTS\n" );
+ for (i = scriptHw-1; i >= 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) {
}
#ifdef DEBUG_SHOWUSE
showUse("Text", textHw, NUM_TEXT);
- showUse("Syntax", syntaxHw, NUM_SYNTAX);
showUse("Module", moduleHw-MODMIN, NUM_MODULE);
showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON);
showUse("Name", nameHw-NAMEMIN, NUM_NAME);
showUse("Ext", extHw-EXTMIN, NUM_EXT);
#endif
#endif
-
scripts[scriptHw].file = findText( f ? f : "<nofile>" );
scripts[scriptHw].textHw = textHw;
scripts[scriptHw].nextNewText = nextNewText;
scripts[scriptHw].nextNewDText = nextNewDText;
- scripts[scriptHw].syntaxHw = syntaxHw;
scripts[scriptHw].moduleHw = moduleHw;
scripts[scriptHw].tyconHw = tyconHw;
scripts[scriptHw].nameHw = nameHw;
scripts[scriptHw].classHw = classHw;
scripts[scriptHw].instHw = instHw;
-#if USE_DICTHW
- scripts[scriptHw].dictHw = dictHw;
-#endif
#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);
+}
+
#define scriptThis(nm,t,tag) Script nm(x) \
t x; { \
Script s=0; \
scriptThis(scriptThisClass,Class,classHw)
#undef scriptThis
-Module lastModule() { /* Return module in current script file */
- return (moduleHw-1);
-}
-
-static Module local moduleOfScript(s)
+Module moduleOfScript(s)
Script s; {
- return scripts[s-1].moduleHw;
+ return (s==0) ? modulePrelude : scripts[s-1].moduleHw;
}
String fileOfModule(m)
Module m; {
Script s;
+ if (m == modulePrelude) {
+ return STD_PRELUDE;
+ }
for(s=0; s<scriptHw; ++s) {
if (scripts[s].moduleHw == m) {
return textToStr(scripts[s].file);
return 0;
}
-static Script local scriptThisFile(f)
+Script scriptThisFile(f)
Text f; {
Script s;
for (s=0; s < scriptHw; ++s) {
return s+1;
}
}
+ if (f == findText(STD_PRELUDE)) {
+ return 0;
+ }
return (-1);
}
textHw = scripts[sno].textHw;
nextNewText = scripts[sno].nextNewText;
nextNewDText = scripts[sno].nextNewDText;
- syntaxHw = scripts[sno].syntaxHw;
+ moduleHw = scripts[sno].moduleHw;
tyconHw = scripts[sno].tyconHw;
nameHw = scripts[sno].nameHw;
classHw = scripts[sno].classHw;
extHw = scripts[sno].extHw;
#endif
+#if 0
for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
if (module(i).objectFile) {
- printf("closing objectFile for module %d\n",i);
- dlclose(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<TEXTHSZ; ++i) {
int j = 0;
while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
Int heapSize = DEFAULTHEAP; /* number of cells in heap */
Heap heapFst; /* array of fst component of pairs */
Heap heapSnd; /* array of snd component of pairs */
+#ifndef GLOBALfst
Heap heapTopFst;
+#endif
+#ifndef GLOBALsnd
Heap heapTopSnd;
+#endif
Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
+Long numCells;
+Int numGcs; /* number of garbage collections */
Int cellsRecovered; /* number of cells recovered */
static Cell freeList; /* free list of unused cells */
#define startGC() \
if (gcMessages) { \
- printf("\n"); \
+ Printf("\n"); \
fflush(stdout); \
}
#define endGC() \
if (gcMessages) { \
- printf("\n"); \
+ Printf("\n"); \
fflush(stdout); \
}
#define start() markCount = 0
#define end(thing,rs) \
if (gcMessages) { \
- printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
+ Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
fflush(stdout); \
}
#define recordMark() markCount++
freeList = snd(freeList);
fst(c) = l;
snd(c) = r;
+ numCells++;
return c;
}
Void overwrite(dst,src) /* overwrite dst cell with src cell*/
-Pair dst, src; { /* both *MUST* be pairs */
- assert(isPair(dst) && isPair(src));
- fst(dst) = fst(src);
- snd(dst) = snd(src);
-}
-
-Void overwrite2(dst,src1,src2) /* overwrite dst cell with src cell*/
-Pair dst;
-Cell src1, src2; {
- assert(isPair(dst));
- fst(dst) = src1;
- snd(dst) = src2;
+Cell dst, src; { /* both *MUST* be pairs */
+ if (isPair(dst) && isPair(src)) {
+ fst(dst) = fst(src);
+ snd(dst) = snd(src);
+ }
+ else
+ internal("overwrite");
}
static Int *marks;
Cell c; { /* cells reachable from given root */
/* markCell(c) is only called if c */
/* is a pair */
- { register place = placeInSet(c);
- register mask = maskInSet(c);
+ { register int place = placeInSet(c);
+ register int mask = maskInSet(c);
if (marks[place]&mask)
return c;
else {
}
}
+ /* STACK_CHECK: Avoid stack overflows during recursive marking. */
if (isGenPair(fst(c))) {
+ STACK_CHECK
fst(c) = markCell(fst(c));
markSnd(c);
}
- else if (isNull(fst(c)) || fst(c)>=BCSTAG)
+ else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
+ STACK_CHECK
markSnd(c);
+ }
return c;
}
ma: t = c; /* Keep pointer to original pair */
c = snd(c);
-mb: if (!isPair(c))
+ if (!isPair(c))
return;
- { register place = placeInSet(c);
- register mask = maskInSet(c);
+ { register int place = placeInSet(c);
+ register int mask = maskInSet(c);
if (marks[place]&mask)
return;
else {
register Int mask;
register Int place;
Int recovered;
+
jmp_buf regs; /* save registers on stack */
setjmp(regs);
place = 0;
recovered = 0;
j = 0;
+
freeList = NIL;
for (i=1; i<=heapSize; i++) {
if ((marks[place] & mask) == 0) {
gcRecovered(recovered);
breakOn(breakStat); /* restore break trapping if nec. */
+ everybody(GCDONE);
+
/* can only return if freeList is nonempty on return. */
if (recovered<minRecovery || isNull(freeList)) {
ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
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 (isPair(c)) { /* Duplicating any text strings */
if (isBoxTag(fst(c))) /* in case these are lost at some */
switch (fst(c)) { /* point before the expr is reused */
case VARIDCELL :
}
else
return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
+ }
#if TREX
else if (isExt(c))
return pair(EXTCOPY,saveText(extText(c)));
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 (isPair(c)) { /* Text values are restored to */
if (isBoxTag(fst(c))) /* appropriate values */
switch (fst(c)) {
case VARIDCELL :
}
else
return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
+ }
else
return c;
}
* Miscellaneous operations on heap cells:
* ------------------------------------------------------------------------*/
-/* profiling suggests that the number of calls to whatIs() is typically */
+/* 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 */
register Cell fstc = fst(c);
return isTag(fstc) ? fstc : AP;
}
- if (c<TUPMIN) return c;
+ if (c<OFFMIN) return c;
+#if TREX
+ if (isExt(c)) return EXT;
+#endif
if (c>=INTMIN) return INTCELL;
- if (c>=NAMEMIN) if (c>=CLASSMIN) if (c>=CHARMIN) return CHARCELL;
- else return CLASS;
+ 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 return MODULE;
+ else return NAME;}
+ else if (c>=MODMIN) {if (c>=TYCMIN) return isTuple(c) ? TUPLE : TYCON;
+ else return MODULE;}
else if (c>=OFFMIN) return OFFSET;
#if TREX
- else if (c>=EXTMIN) return EXT;
+ else return (c>=EXTMIN) ?
+ EXT : TUPLE;
+#else
+ else return TUPLE;
#endif
- else return TUPLE;
/* if (isPair(c)) {
register Cell fstc = fst(c);
return isTag(fstc) ? fstc : AP;
}
+ if (c>=INTMIN) return INTCELL;
if (c>=CHARMIN) return CHARCELL;
if (c>=CLASSMIN) return CLASS;
if (c>=INSTMIN) return INSTANCE;
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 {
Int tag = whatIs(c);
switch (tag) {
Printf("Offset %d", offsetOf(c));
break;
case TUPLE:
- Printf("Tuple %d", tupleOf(c));
+ Printf("%s", textToStr(ghcTupleText(c)));
break;
case POLYTYPE:
Printf("Polytype");
print(snd(c),depth-1);
break;
+ case QUAL:
+ Printf("Qualtype");
+ print(snd(c),depth-1);
+ break;
case RANK2:
Printf("Rank2(");
if (isPair(snd(c)) && isInt(fst(snd(c)))) {
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;
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("<ZPair ");
+ print(zfst(c),depth-1);
+ Putchar(' ');
+ print(zsnd(c),depth-1);
+ Putchar('>');
+ break;
+ case ZTUP3:
+ Printf("<ZTriple ");
+ print(zfst3(c),depth-1);
+ Putchar(' ');
+ print(zsnd3(c),depth-1);
+ Putchar(' ');
+ print(zthd3(c),depth-1);
+ Putchar('>');
+ break;
+ case BANG:
+ Printf("(BANG,");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
default:
if (isBoxTag(tag)) {
Printf("Tag(%d)=%d", c, tag);
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;
Int intOf(c) /* find integer value of cell? */
Cell c; {
- assert(isInt(c));
+ if (!isInt(c)) {
+ assert(isInt(c)); }
return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
}
Cell mkInt(n) /* make cell representing integer */
Int n; {
- return isSmall(INTZERO+n) ? INTZERO+n : pair(INTCELL,n);
+ return (MINSMALLINT <= n && n <= MAXSMALLINT)
+ ? INTZERO+n
+ : pair(INTCELL,n);
}
-#if PTR_ON_HEAP
#if SIZEOF_INTP == SIZEOF_INT
typedef union {Int i; Ptr p;} IntOrPtr;
Cell mkPtr(p)
Cell c;
{
IntOrPtr x;
- assert(isPtr(c));
+ assert(fst(c) == PTRCELL);
x.i = snd(c);
return x.p;
}
+Cell mkCPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(CPTRCELL,x.i);
+}
+
+Ptr cptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(fst(c) == CPTRCELL);
+ x.i = snd(c);
+ return x.p;
+}
+#elif SIZEOF_INTP == 2*SIZEOF_INT
+typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
+Cell mkPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
+}
+
+Ptr ptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(fst(c) == PTRCELL);
+ x.i.i1 = intOf(fst(snd(c)));
+ x.i.i2 = intOf(snd(snd(c)));
+ return x.p;
+}
#else
-/* For 8 byte addresses (used on the Alpha), we'll have to work harder */
-#error "PTR_ON_HEAP not supported on this architecture"
-#endif
+#warning "type Addr not supported on this architecture - don't use it"
+Cell mkPtr(p)
+Ptr p;
+{
+ ERRMSG(0) "mkPtr: type Addr not supported on this architecture"
+ EEND;
+}
+
+Ptr ptrOf(c)
+Cell c;
+{
+ ERRMSG(0) "ptrOf: type Addr not supported on this architecture"
+ EEND;
+}
#endif
String stringNegate( s )
Int length(xs) /* calculate length of list xs */
List xs; {
Int n = 0;
- for (n=0; nonNull(xs); ++n)
+ for (; nonNull(xs); ++n)
xs = tl(xs);
return n;
}
}
}
-List revDupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
+List dupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
List xs;
List ys; {
- for( ; nonNull(xs); xs=tl(xs)) {
+ for (; nonNull(xs); xs=tl(xs))
ys = cons(hd(xs),ys);
- }
return ys;
}
List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
List xs;
List ys; {
- return revOnto(revDupOnto(xs,NIL),ys);
+ return revOnto(dupOnto(xs,NIL),ys);
+}
+
+List dupList(xs) /* Duplicate spine of list xs */
+List xs; {
+ List ys = NIL;
+ for (; nonNull(xs); xs=tl(xs))
+ ys = cons(hd(xs),ys);
+ return rev(ys);
}
List revOnto(xs,ys) /* Destructively reverse elements of*/
return ys;
}
-Bool eqList(as,bs)
-List as;
-List bs; {
- while (nonNull(as) && nonNull(bs) && hd(as)==hd(bs)) {
- as=tl(as);
- bs=tl(bs);
- }
- return (isNull(as) && isNull(bs));
-}
+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 */
return NIL;
}
+Name nameIsMember(t,ns) /* Test if name with text t is a */
+Text t; /* member of list of names xs */
+List ns; {
+ for (; nonNull(ns); ns=tl(ns))
+ if (t==name(hd(ns)).text)
+ return hd(ns);
+ return NIL;
+}
+
Cell intIsMember(n,xs) /* Test if integer n is member of */
Int n; /* given list of integers */
List xs; {
return NIL;
}
-List replicate(n,x) /* create list of n copies of x */
+List replicate(n,x) /* create list of n copies of x */
Int n;
Cell x; {
List xs=NIL;
- assert(n>=0);
- while (0<n--) {
+ while (0<n--)
xs = cons(x,xs);
- }
return xs;
}
-List diffList(xs,ys) /* list difference: xs\ys */
-List xs, ys; { /* result contains all elements of */
- List result = NIL; /* `xs' not appearing in `ys' */
- while (nonNull(xs)) {
- List next = tl(xs);
- if (!cellIsMember(hd(xs),ys)) {
- tl(xs) = result;
- result = xs;
+List diffList(from,take) /* list difference: from\take */
+List from, take; { /* result contains all elements of */
+ List result = NIL; /* `from' not appearing in `take' */
+
+ while (nonNull(from)) {
+ List next = tl(from);
+ if (!cellIsMember(hd(from),take)) {
+ tl(from) = result;
+ result = from;
}
- xs = next;
+ from = next;
}
return rev(result);
}
List xs; {
List ys = xs;
- assert(n>=0);
if (n==0)
return NIL;
while (1<n-- && nonNull(xs))
return ys;
}
-List splitAt(n,xs) /* drop n things from front of list */
+List splitAt(n,xs) /* drop n things from front of list*/
Int n;
List xs; {
- assert(n>=0);
for(; n>0; --n) {
xs = tl(xs);
}
return xs;
}
-Cell nth(n,xs) /* extract n'th element of list */
+Cell nth(n,xs) /* extract n'th element of list */
Int n;
List xs; {
- assert(n>=0);
for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
}
- assert(nonNull(xs));
+ if (isNull(xs))
+ internal("nth");
return hd(xs);
}
return xs; /* here if element not found */
}
+List nubList(xs) /* nuke dups in list */
+List xs; { /* non destructive */
+ List outs = NIL;
+ for (; nonNull(xs); xs=tl(xs))
+ if (isNull(cellIsMember(hd(xs),outs)))
+ outs = cons(hd(xs),outs);
+ outs = rev(outs);
+ return outs;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Strongly-typed lists (z-lists) and 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);
+ }
+}
+
+#if 0
+Cell zcons ( Cell x, Cell xs )
+{
+ if (!(isNull(xs) || whatIs(xs)==ZCONS))
+ internal("zcons: ill typed tail");
+ return ap(ZCONS,ap(x,xs));
+}
+
+Cell zhd ( Cell xs )
+{
+ if (isNull(xs)) internal("zhd: empty list");
+ z_tag_check(xs,ZCONS,"zhd");
+ return fst( snd(xs) );
+}
+
+Cell ztl ( Cell xs )
+{
+ if (isNull(xs)) internal("ztl: empty list");
+ z_tag_check(xs,ZCONS,"zhd");
+ return snd( snd(xs) );
+}
+
+Int zlength ( ZList xs )
+{
+ Int n = 0;
+ while (nonNull(xs)) {
+ z_tag_check(xs,ZCONS,"zlength");
+ n++;
+ xs = snd( snd(xs) );
+ }
+ return n;
+}
+
+ZList zreverse ( ZList xs )
+{
+ ZList rev = NIL;
+ while (nonNull(xs)) {
+ z_tag_check(xs,ZCONS,"zreverse");
+ rev = zcons(zhd(xs),rev);
+ xs = ztl(xs);
+ }
+ return rev;
+}
+
+Cell zsingleton ( Cell x )
+{
+ return zcons (x,NIL);
+}
+
+Cell zdoubleton ( Cell x, Cell y )
+{
+ return zcons(x,zcons(y,NIL));
+}
+#endif
+
+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:
* ------------------------------------------------------------------------*/
Cell nthArg(n,e) /* return nth arg in application */
Int n; /* of function to m args (m>=n) */
Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
- assert(n>=0);
for (n=numArgs(e)-n-1; n>0; n--)
e = fun(e);
return arg(e);
return f;
}
+
+/* --------------------------------------------------------------------------
+ * plugin 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 */
+
+
/* --------------------------------------------------------------------------
* storage control:
* ------------------------------------------------------------------------*/
Int i;
switch (what) {
+ case POSTPREL: break;
+
case RESET : clearStack();
+ /* the next 2 statements are particularly important
+ * if you are using GLOBALfst or GLOBALsnd since the
+ * corresponding registers may be reset to their
+ * uninitialised initial values by a longjump.
+ */
+ heapTopFst = heapFst + heapSize;
+ heapTopSnd = heapSnd + heapSize;
consGC = TRUE;
lsave = NIL;
rsave = NIL;
case MARK :
start();
for (i=NAMEMIN; i<nameHw; ++i) {
+ mark(name(i).parent);
mark(name(i).defn);
mark(name(i).stgVar);
mark(name(i).type);
- }
+ }
end("Names", nameHw-NAMEMIN);
start();
mark(module(i).classes);
mark(module(i).exports);
mark(module(i).qualImports);
+ mark(module(i).objectExtraNames);
}
end("Modules", moduleHw-MODMIN);
for (i=CLASSMIN; i<classHw; ++i) {
mark(cclass(i).head);
mark(cclass(i).kinds);
+ mark(cclass(i).fds);
+ mark(cclass(i).xfds);
mark(cclass(i).dsels);
mark(cclass(i).supers);
mark(cclass(i).members);
start();
for (i=INSTMIN; i<instHw; ++i) {
- mark(inst(i).kinds);
mark(inst(i).head);
+ mark(inst(i).kinds);
mark(inst(i).specifics);
mark(inst(i).implements);
}
break;
- case INSTALL : heapFst = heapAlloc(heapSize);
+ case PREPREL : heapFst = heapAlloc(heapSize);
heapSnd = heapAlloc(heapSize);
if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
}
snd(-heapSize) = NIL;
freeList = -1;
+ numGcs = 0;
consGC = TRUE;
lsave = NIL;
rsave = NIL;
}
TABALLOC(text, char, NUM_TEXT)
- TABALLOC(tabSyntax, struct strSyntax, NUM_SYNTAX)
TABALLOC(tyconHash, Tycon, TYCONHSZ)
TABALLOC(tabTycon, struct strTycon, NUM_TYCON)
TABALLOC(nameHash, Name, NAMEHSZ)
for (i=0; i<TEXTHSZ; ++i)
textHash[i][0] = NOTEXT;
- syntaxHw = 0;
moduleHw = MODMIN;
tyconHw = TYCMIN;
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
-
#if TREX
extHw = EXTMIN;
#endif
projects / ghc-hetmet.git / blobdiff