diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 34b9d214d6e13920ffcdcbba98330c85a2c9810e..865a30a70bd5f2c881138a7e65fb261f188637c6 100644
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/12/10 15:59:46 $
+ * $Revision: 1.11 $
+ * $Date: 1999/12/16 16:34:40 $
* ------------------------------------------------------------------------*/
/* ToDo:
@@ -83,7 +83,7 @@ static Void finishGHCSynonym Args((Tycon));
static Void startGHCClass Args((Int,List,Cell,List,List));
static Void finishGHCClass Args((Class));
-static Void startGHCInstance Args((Int,List,Pair,VarId));
+static Inst startGHCInstance Args((Int,List,Pair,VarId));
static Void finishGHCInstance Args((Inst));
static Void startGHCImports Args((ConId,List));
@@ -92,7 +92,7 @@ static Void finishGHCImports Args((ConId,List));
static Void startGHCExports Args((ConId,List));
static Void finishGHCExports Args((ConId,List));
-static Void finishGHCModule Args((Module));
+static Void finishGHCModule Args((Cell));
static Void startGHCModule Args((Text, Int, Text));
static Void startGHCDataDecl Args((Int,List,Cell,List,List));
@@ -106,16 +106,13 @@ static Void finishGHCNewType ( ConId tyc );
static List startGHCConstrs Args((Int,List,List));
static Name startGHCSel Args((Int,Pair));
static Name startGHCConstr Args((Int,Int,Triple));
-static Void finishGHCConstr Args((Name));
-
-static Void loadSharedLib Args((String));
static Kinds tvsToKind Args((List));
static Int arityFromType Args((Type));
static Int arityInclDictParams Args((Type));
-
+static Bool allTypesKnown ( Type type, List aktys /* [QualId] */, ConId thisMod );
static List ifTyvarsIn Args((Type));
@@ -136,6 +133,77 @@ static void* lookupObjName ( char* );
* Top-level interface processing
* ------------------------------------------------------------------------*/
+/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
+ConVarId getIEntityName ( Cell c )
+{
+ switch (whatIs(c)) {
+ case I_IMPORT: return NIL;
+ case I_INSTIMPORT: return NIL;
+ case I_EXPORT: return NIL;
+ case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
+ case I_INSTANCE: return NIL;
+ case I_TYPE: return zsel24(unap(I_TYPE,c));
+ case I_DATA: return zsel35(unap(I_DATA,c));
+ case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
+ case I_CLASS: return zsel35(unap(I_CLASS,c));
+ case I_VALUE: return zsnd3(unap(I_VALUE,c));
+ default: internal("getIEntityName");
+ }
+}
+
+
+/* Filter the contents of an interface, using the supplied predicate.
+ For flexibility, the predicate is passed as a second arg the value
+ extraArgs. This is a hack to get round the lack of partial applications
+ in C. Pred should not have any side effects. The dumpaction param
+ gives us the chance to print a message or some such for dumped items.
+ When a named entity is deleted, filterInterface also deletes the name
+ in the export lists.
+*/
+Cell filterInterface ( Cell root,
+ Bool (*pred)(Cell,Cell),
+ Cell extraArgs,
+ Void (*dumpAction)(Cell) )
+{
+ List tops;
+ Cell iface = unap(I_INTERFACE,root);
+ List tops2 = NIL;
+ List deleted_ids = NIL; /* :: [ConVarId] */
+
+ for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
+ if (pred(hd(tops),extraArgs)) {
+ tops2 = cons( hd(tops), tops2 );
+ } else {
+ ConVarId deleted_id = getIEntityName ( hd(tops) );
+ if (nonNull(deleted_id))
+ deleted_ids = cons ( deleted_id, deleted_ids );
+ if (dumpAction)
+ dumpAction ( hd(tops) );
+ }
+ }
+ tops2 = reverse(tops2);
+
+ /* Clean up the export list now. */
+ for (tops=tops2; nonNull(tops); tops=tl(tops)) {
+ if (whatIs(hd(tops))==I_EXPORT) {
+ Cell exdecl = unap(I_EXPORT,hd(tops));
+ List exlist = zsnd(exdecl);
+ List exlist2 = NIL;
+ for (; nonNull(exlist); exlist=tl(exlist)) {
+ Cell ex = hd(exlist);
+ ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
+ assert (isCon(exid) || isVar(exid));
+ if (!varIsMember(textOf(exid),deleted_ids))
+ exlist2 = cons(ex, exlist2);
+ }
+ hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
+ }
+ }
+
+ return ap(I_INTERFACE, zpair(zfst(iface),tops2));
+}
+
+
ZPair readInterface(String fname, Long fileSize)
{
List tops;
@@ -143,7 +211,7 @@ ZPair readInterface(String fname, Long fileSize)
ZPair iface = parseInterface(fname,fileSize);
assert (whatIs(iface)==I_INTERFACE);
- for (tops = zsnd(snd(iface)); nonNull(tops); tops=tl(tops))
+ for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
if (whatIs(hd(tops)) == I_IMPORT) {
ZPair imp_decl = unap(I_IMPORT,hd(tops));
ConId m_to_imp = zfst(imp_decl);
@@ -156,59 +224,97 @@ ZPair readInterface(String fname, Long fileSize)
}
-static Bool elemExportList ( VarId nm, List exlist_list )
+/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
+static List getExportDeclsInIFace ( Cell root )
+{
+ Cell iface = unap(I_INTERFACE,root);
+ List decls = zsnd(iface);
+ List exports = NIL;
+ List ds;
+ for (ds=decls; nonNull(ds); ds=tl(ds))
+ if (whatIs(hd(ds))==I_EXPORT)
+ exports = cons(hd(ds), exports);
+ return exports;
+}
+
+
+
+static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
{
+ /* ife :: I_IMPORT..I_VALUE */
/* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
- Text tnm = textOf(nm);
- Int tlen = strlen(textToStr(tnm));
+ Text tnm;
List exlist;
List t;
- Cell c;
+
+ ConVarId ife_id = getIEntityName ( ife );
+
+ if (isNull(ife_id)) return TRUE;
+
+ tnm = textOf(ife_id);
/* for each export list ... */
for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
exlist = hd(exlist_list);
/* for each entity in an export list ... */
- for (t=exlist; nonNull(t); c=tl(t)) {
+ for (t=exlist; nonNull(t); t=tl(t)) {
if (isZPair(hd(t))) {
/* A pair, which means an export entry
of the form ClassName(foo,bar). */
- List subents = zsnd(hd(t));
+ List subents = cons(zfst(hd(t)),zsnd(hd(t)));
for (; nonNull(subents); subents=tl(subents))
- if (textOf(hd(subents)) == tnm) return TRUE;
+ if (textOf(hd(subents)) == tnm) goto retain;
} else {
/* Single name in the list. */
- if (textOf(hd(t)) == tnm) return TRUE;
+ if (textOf(hd(t)) == tnm) goto retain;
}
}
}
- /* fprintf ( stderr, "elemExportList %s\n", textToStr(textOf(nm)) ); */
+ fprintf ( stderr, " dump %s\n", textToStr(tnm) );
return FALSE;
+
+ retain:
+ fprintf ( stderr, " retain %s\n", textToStr(tnm) );
+ return TRUE;
}
-/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
-static List getExportDeclsInIFace ( Cell root )
+static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
{
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- List decls = zsnd(iface);
- List exports = NIL;
- List ds;
- for (ds=decls; nonNull(ds); ds=tl(ds))
- if (whatIs(hd(ds))==I_EXPORT)
- exports = cons(hd(ds), exports);
- return exports;
+ /* ife_id :: ConId */
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+ Text tnm;
+ List exlist;
+ List t;
+
+ assert (isCon(ife_id));
+ tnm = textOf(ife_id);
+
+ /* for each export list ... */
+ for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
+ exlist = hd(exlist_list);
+
+ /* for each entity in an export list ... */
+ for (t=exlist; nonNull(t); t=tl(t)) {
+ if (isZPair(hd(t))) {
+ /* A pair, which means an export entry
+ of the form ClassName(foo,bar). */
+ if (textOf(zfst(hd(t))) == tnm) return FALSE;
+ } else {
+ if (textOf(hd(t)) == tnm) return TRUE;
+ }
+ }
+ }
+ internal("isExportedAbstractly");
+ return FALSE; /*notreached*/
}
-/* Remove value bindings not mentioned in any of the export lists. */
-static Cell cleanIFace ( Cell root )
+/* Remove entities not mentioned in any of the export lists. */
+static Cell deleteUnexportedIFaceEntities ( Cell root )
{
- Cell c;
- Cell entity;
Cell iface = unap(I_INTERFACE,root);
ConId iname = zfst(iface);
List decls = zsnd(iface);
@@ -216,7 +322,7 @@ static Cell cleanIFace ( Cell root )
List exlist_list = NIL;
List t;
- fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+ fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
exlist_list = getExportDeclsInIFace ( root );
/* exlist_list :: [I_EXPORT] */
@@ -230,23 +336,193 @@ static Cell cleanIFace ( Cell root )
EEND;
}
- decls2 = NIL;
- for (; nonNull(decls); decls=tl(decls)) {
- entity = hd(decls);
- if (whatIs(entity) != I_VALUE) {
- decls2 = cons(entity, decls2);
- } else
- if (elemExportList(zsnd3(unap(I_VALUE,entity)), exlist_list)) {
- decls2 = cons(entity, decls2);
- fprintf ( stderr, " retain %s\n",
- textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
+ return filterInterface ( root, isExportedIFaceEntity,
+ exlist_list, NULL );
+}
+
+
+/* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
+List addTyconsAndClassesFromIFace ( Cell root, List aktys )
+{
+ Cell iface = unap(I_INTERFACE,root);
+ Text mname = textOf(zfst(iface));
+ List defns = zsnd(iface);
+ for (; nonNull(defns); defns = tl(defns)) {
+ Cell defn = hd(defns);
+ Cell what = whatIs(defn);
+ if (what==I_TYPE || what==I_DATA
+ || what==I_NEWTYPE || what==I_CLASS) {
+ QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
+ if (!qualidIsMember ( q, aktys ))
+ aktys = cons ( q, aktys );
+ }
+ }
+ return aktys;
+}
+
+
+Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
+{
+ ConVarId id = getIEntityName ( entity );
+ fprintf ( stderr,
+ "dumping %s because of unknown type(s)\n",
+ isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
+}
+
+/* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
+/* mod is the current module being processed -- so we can qualify unqual'd
+ names. Strange calling convention for aktys and mod is so we can call this
+ from filterInterface.
+*/
+Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
+{
+ List t, u;
+ List aktys = zfst ( aktys_mod );
+ ConId mod = zsnd ( aktys_mod );
+ switch (whatIs(entity)) {
+ case I_IMPORT:
+ case I_INSTIMPORT:
+ case I_EXPORT:
+ case I_FIXDECL:
+ return TRUE;
+ case I_INSTANCE: {
+ Cell inst = unap(I_INSTANCE,entity);
+ List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
+ Type cls = zsel35 ( inst ); /* :: Type */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ if (!allTypesKnown(cls, aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_TYPE:
+ return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
+ case I_DATA: {
+ Cell data = unap(I_DATA,entity);
+ List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
+ List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ for (t = constrs; nonNull(t); t=tl(t))
+ for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
+ if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_NEWTYPE: {
+ Cell newty = unap(I_NEWTYPE,entity);
+ List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
+ ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ if (nonNull(constr)
+ && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_CLASS: {
+ Cell klass = unap(I_CLASS,entity);
+ List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
+ List sigs = zsel55(klass); /* :: [((VarId,Type))] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
+ for (t = sigs; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
+ return TRUE;
+ }
+ case I_VALUE:
+ return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
+ default:
+ internal("ifentityAllTypesKnown");
+ }
+}
+
+
+#if 0
+I hope this can be nuked.
+/* Kludge. Stuff imported from PrelGHC isn't referred to in a
+ qualified way, so arrange it so it is.
+*/
+QualId magicRequalify ( ConId id )
+{
+ Text tid;
+ Text tmid;
+ assert(isCon(id));
+ tid = textOf(id);
+
+ fprintf ( stderr, "$--$--$--$--$--$ magicRequalify: %s",
+ textToStr(tid) );
+
+ if (tid == findText("[]")) {
+ tmid = findText("PrelList");
+ } else
+ if (tid == findText("Ratio")) {
+ tmid = findText("PrelNum");
+ } else
+ if (tid == findText("Char")) {
+ tmid = findText("PrelGHC");
+ } else {
+ fprintf(stderr, "??? \n");
+ return id;
+ }
+
+ fprintf ( stderr, " -> %s.%s\n",
+ textToStr(tmid), textToStr(tid) );
+ return mkQualId ( mkCon(tmid), id );
+}
+#endif
+
+
+/* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
+/* mod is the current module being processed -- so we can qualify unqual'd
+ names. Strange calling convention for aktys and mod is so we can call this
+ from filterInterface.
+*/
+Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
+{
+ List t, u;
+ List aktys = zfst ( aktys_mod );
+ ConId mod = zsnd ( aktys_mod );
+ if (whatIs(entity) != I_TYPE) {
+ return TRUE;
+ } else {
+ return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
+ }
+}
+
+Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
+{
+ ConVarId id = getIEntityName ( entity );
+ assert (whatIs(entity)==I_TYPE);
+ assert (isCon(id));
+ fprintf ( stderr,
+ "dumping type %s because of unknown tycon(s)\n",
+ textToStr(textOf(id)) );
+}
+
+
+/* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
+*/
+List abstractifyExDecl ( Cell root, ConId toabs )
+{
+ ZPair exdecl = unap(I_EXPORT,root);
+ List exlist = zsnd(exdecl);
+ List res = NIL;
+ for (; nonNull(exlist); exlist = tl(exlist)) {
+ if (isZPair(hd(exlist))
+ && textOf(toabs) == textOf(zfst(hd(exlist)))) {
+ /* it's toabs, exported non-abstractly */
+ res = cons ( zfst(hd(exlist)), res );
} else {
- fprintf ( stderr, " dump %s\n",
- textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
+ res = cons ( hd(exlist), res );
}
}
+ return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
+}
- return ap(I_INTERFACE, zpair(iname, reverse(decls2)));
+
+Void ppModule ( Text modt )
+{
+ fflush(stderr); fflush(stdout);
+ fprintf(stderr, "---------------- MODULE %s ----------------\n",
+ textToStr(modt) );
}
@@ -265,47 +541,223 @@ Void processInterfaces ( void )
Text mname;
List decls;
Module mod;
+ List all_known_types;
+ Int num_known_types;
+
+ List ifaces = NIL; /* :: List I_INTERFACE */
+ List iface_sizes = NIL; /* :: List Int */
+ List iface_onames = NIL; /* :: List Text */
fprintf ( stderr,
"processInterfaces: %d interfaces to process\n",
length(ifaces_outstanding) );
- /* Clean up interfaces -- dump useless value bindings */
- tmp = NIL;
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = zfst3(tr);
- nameObj = zsnd3(tr);
- sizeObj = zthd3(tr);
- tmp = cons( ztriple(cleanIFace(iface),nameObj,sizeObj), tmp );
+ /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
+ for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
+ ifaces = cons ( zfst3(hd(xs)), ifaces );
+ iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
+ iface_sizes = cons ( zthd3(hd(xs)), iface_sizes );
}
- ifaces_outstanding = reverse(tmp);
- tmp = NIL;
- /* Allocate module table entries and read in object code. */
+ ifaces = reverse(ifaces);
+ iface_onames = reverse(iface_onames);
+ iface_sizes = reverse(iface_sizes);
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
- nameObj = zsnd3(tr);
- sizeObj = zthd3(tr);
- mname = textOf(zfst(iface));
- startGHCModule ( mname, intOf(sizeObj), nameObj );
+ /* Clean up interfaces -- dump non-exported value, class, type decls */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs))
+ hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
+
+
+ /* Iteratively delete any type declarations which refer to unknown
+ tycons.
+ */
+ num_known_types = 999999999;
+ while (TRUE) {
+ Int i;
+
+ /* Construct a list of all known tycons. This is a list of QualIds.
+ Unfortunately it also has to contain all known class names, since
+ allTypesKnown cannot distinguish between tycons and classes -- a
+ deficiency of the iface abs syntax.
+ */
+ all_known_types = getAllKnownTyconsAndClasses();
+ for (xs = ifaces; nonNull(xs); xs=tl(xs))
+ all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
+
+ /* Have we reached a fixed point? */
+ i = length(all_known_types);
+ printf ( "\n============= %d known types =============\n", i );
+ if (num_known_types == i) break;
+ num_known_types = i;
+
+ /* Delete all entities which refer to unknown tycons. */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
+ assert(nonNull(mod));
+ hd(xs) = filterInterface ( hd(xs),
+ ifTypeDoesntRefUnknownTycon,
+ zpair(all_known_types,mod),
+ ifTypeDoesntRefUnknownTycon_dumpmsg );
+ }
+ }
+
+ /* Now abstractify any datas and newtypes which refer to unknown tycons
+ -- including, of course, the type decls just deleted.
+ */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ List absify = NIL; /* :: [ConId] */
+ ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
+ ConId mod = zfst(iface);
+ List aktys = all_known_types; /* just a renaming */
+ List es,t,u;
+ List exlist_list;
+
+ /* Compute into absify the list of all ConIds (tycons) we need to
+ abstractify.
+ */
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ Cell ent = hd(es);
+ Bool allKnown = TRUE;
+
+ if (whatIs(ent)==I_DATA) {
+ Cell data = unap(I_DATA,ent);
+ List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
+ List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
+ for (t = constrs; nonNull(t); t=tl(t))
+ for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
+ if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
+ }
+ else if (whatIs(ent)==I_NEWTYPE) {
+ Cell newty = unap(I_NEWTYPE,ent);
+ List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
+ ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
+ for (t = ctx; nonNull(t); t=tl(t))
+ if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
+ if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
+ }
+
+ if (!allKnown) {
+ absify = cons ( getIEntityName(ent), absify );
+ fprintf ( stderr,
+ "abstractifying %s because it uses an unknown type\n",
+ textToStr(textOf(getIEntityName(ent))) );
+ }
+ }
+
+ /* mark in exports as abstract all names in absify (modifies iface) */
+ for (; nonNull(absify); absify=tl(absify)) {
+ ConId toAbs = hd(absify);
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ if (whatIs(hd(es)) != I_EXPORT) continue;
+ hd(es) = abstractifyExDecl ( hd(es), toAbs );
+ }
+ }
+
+ /* For each data/newtype in the export list marked as abstract,
+ remove the constructor lists. This catches all abstractification
+ caused by the code above, and it also catches tycons which really
+ were exported abstractly.
+ */
+
+ exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
+ /* exlist_list :: [I_EXPORT] */
+ for (t=exlist_list; nonNull(t); t=tl(t))
+ hd(t) = zsnd(unap(I_EXPORT,hd(t)));
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+
+ for (es = zsnd(iface); nonNull(es); es=tl(es)) {
+ Cell ent = hd(es);
+ if (whatIs(ent)==I_DATA
+ && isExportedAbstractly ( getIEntityName(ent),
+ exlist_list )) {
+ Cell data = unap(I_DATA,ent);
+ data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
+ zsel45(data), NIL /* the constr list */ );
+ hd(es) = ap(I_DATA,data);
+fprintf(stderr, "abstractify data %s\n", textToStr(textOf(getIEntityName(ent))) );
+ }
+ else if (whatIs(ent)==I_NEWTYPE
+ && isExportedAbstractly ( getIEntityName(ent),
+ exlist_list )) {
+ Cell data = unap(I_NEWTYPE,ent);
+ data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
+ zsel45(data), NIL /* the constr-type pair */ );
+ hd(es) = ap(I_NEWTYPE,data);
+fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent))) );
+ }
+ }
+
+ /* We've finally finished mashing this iface. Update the iface list. */
+ hd(xs) = ap(I_INTERFACE,iface);
}
+
+ /* At this point, the interfaces are cleaned up so that no type, data or
+ newtype defn refers to a non-existant type. However, there still may
+ be value defns, classes and instances which refer to unknown types.
+ Delete iteratively until a fixed point is reached.
+ */
+printf("\n");
+
+ num_known_types = 999999999;
+ while (TRUE) {
+ Int i;
+
+ /* Construct a list of all known tycons. This is a list of QualIds.
+ Unfortunately it also has to contain all known class names, since
+ allTypesKnown cannot distinguish between tycons and classes -- a
+ deficiency of the iface abs syntax.
+ */
+ all_known_types = getAllKnownTyconsAndClasses();
+ for (xs = ifaces; nonNull(xs); xs=tl(xs))
+ all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
+
+ /* Have we reached a fixed point? */
+ i = length(all_known_types);
+ printf ( "\n------------- %d known types -------------\n", i );
+ if (num_known_types == i) break;
+ num_known_types = i;
+
+ /* Delete all entities which refer to unknown tycons. */
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
+ assert(nonNull(mod));
+
+ hd(xs) = filterInterface ( hd(xs),
+ ifentityAllTypesKnown,
+ zpair(all_known_types,mod),
+ ifentityAllTypesKnown_dumpmsg );
+ }
+ }
+
+
+ /* Allocate module table entries and read in object code. */
+ for (xs=ifaces;
+ nonNull(xs);
+ xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
+ startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
+ intOf(hd(iface_sizes)),
+ hd(iface_onames) );
+ }
+ assert (isNull(iface_sizes));
+ assert (isNull(iface_onames));
+
+
/* Now work through the decl lists of the modules, and call the
startGHC* functions on the entities. This creates names in
various tables but doesn't bind them to anything.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
mod = findModule(mname);
if (isNull(mod)) internal("processInterfaces(4)");
setCurrModule(mod);
+ ppModule ( module(mod).text );
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
@@ -324,9 +776,16 @@ Void processInterfaces ( void )
break;
}
case I_INSTANCE: {
+ /* Trying to find the instance table location allocated by
+ startGHCInstance in subsequent processing is a nightmare, so
+ cache it on the tree.
+ */
Cell instance = unap(I_INSTANCE,decl);
- startGHCInstance ( zsel14(instance), zsel24(instance),
- zsel34(instance), zsel44(instance) );
+ Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
+ zsel35(instance), zsel45(instance) );
+ hd(decls) = ap(I_INSTANCE,
+ z5ble( zsel15(instance), zsel25(instance),
+ zsel35(instance), zsel45(instance), in ));
break;
}
case I_TYPE: {
@@ -366,19 +825,20 @@ Void processInterfaces ( void )
}
}
- fprintf(stderr, "frambozenvla\n" );exit(1);
+ fprintf(stderr, "\n=========================================================\n");
+ fprintf(stderr, "=========================================================\n");
/* Traverse again the decl lists of the modules, this time
- calling the finishGHC* functions. But don't try process
+ calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
- tr = hd(xs);
- iface = unap(I_INTERFACE,zfst3(tr));
+ for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
+ iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
mod = findModule(mname);
if (isNull(mod)) internal("processInterfaces(3)");
setCurrModule(mod);
+ ppModule ( module(mod).text );
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
@@ -394,7 +854,7 @@ Void processInterfaces ( void )
}
case I_INSTANCE: {
Cell instance = unap(I_INSTANCE,decl);
- finishGHCInstance ( zsel34(instance) );
+ finishGHCInstance ( zsel55(instance) );
break;
}
case I_TYPE: {
@@ -428,12 +888,14 @@ Void processInterfaces ( void )
}
}
+ fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
+ fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
/* Build the module(m).export lists for each module, by running
through the export lists in the iface. Also, do the implicit
'import Prelude' thing. And finally, do the object code
linking.
*/
- for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs))
+ for (xs = ifaces; nonNull(xs); xs = tl(xs))
finishGHCModule(hd(xs));
/* Finished! */
@@ -452,12 +914,16 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
Module m = findModule(mname);
if (isNull(m)) {
- m = newModule(mname);
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
+ m = newModule(mname);
+ fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
textToStr(mname), sizeObj );
- } else if (m != modulePrelude) {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
- EEND;
+ } else {
+ if (module(m).fake) {
+ module(m).fake = FALSE;
+ } else {
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
+ EEND;
+ }
}
img = malloc ( sizeObj );
@@ -497,7 +963,8 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
/* For the module mod, augment both the export environment (.exports)
and the eval environment (.names, .tycons, .classes)
with the symbols mentioned in exlist. We don't actually need
- to touch the eval environment, since previous processing of the
+ to modify the names, tycons, classes or instances in the eval
+ environment, since previous processing of the
top-level decls in the iface should have done this already.
mn is the module mentioned in the export list; it is the "original"
@@ -506,20 +973,28 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
refer to the original module in which a symbol was defined, rather
than to some module it has been imported into and then re-exported.
- Also do an implicit 'import Prelude' thingy for the module.
+ We take the policy that if something mentioned in an export list
+ can't be found in the symbol tables, it is simply ignored. After all,
+ previous processing of the iface syntax trees has already removed
+ everything which Hugs can't handle, so if there is mention of these
+ things still lurking in export lists somewhere, about the only thing
+ to do is to ignore it.
+
+ Also do an implicit 'import Prelude' thingy for the module,
+ if appropriate.
*/
+
+
Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
Cell iface = unap(I_INTERFACE,root);
ConId iname = zfst(iface);
- List decls = zsnd(iface);
Module mod = findModule(textOf(iname));
- List decls2 = NIL;
List exlist_list = NIL;
List t;
- fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+ fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
if (isNull(mod)) internal("finishExports(1)");
setCurrModule(mod);
@@ -527,65 +1002,86 @@ Void finishGHCModule ( Cell root )
exlist_list = getExportDeclsInIFace ( root );
/* exlist_list :: [I_EXPORT] */
- for (t=exlist_list; nonNull(t); t=tl(t))
- hd(t) = zsnd(unap(I_EXPORT,hd(t)));
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
-
for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
- List exlist = hd(exlist_list);
+ ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
+ ConId exmod = zfst(exdecl);
+ List exlist = zsnd(exdecl);
/* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
+
for (; nonNull(exlist); exlist=tl(exlist)) {
- List subents;
- Cell c;
- Cell ex = hd(exlist);
+ Bool abstract;
+ List subents;
+ Cell c;
+ QualId q;
+ Cell ex = hd(exlist);
switch (whatIs(ex)) {
case VARIDCELL: /* variable */
- c = findName ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "var %s\n", textToStr(textOf(ex)) );
+ q = mkQualId(exmod,ex);
+ c = findQualNameWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+ fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
module(mod).exports = cons(c, module(mod).exports);
break;
case CONIDCELL: /* non data tycon */
- c = findTycon ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "non data tycon %s\n", textToStr(textOf(ex)) );
+ q = mkQualId(exmod,ex);
+ c = findQualTyconWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+ fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
module(mod).exports = cons(c, module(mod).exports);
break;
case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
subents = zsnd(ex); /* :: [ConVarId] */
ex = zfst(ex); /* :: ConId */
- c = findTycon ( textOf(ex) );
+ q = mkQualId(exmod,ex);
+ c = findQualTyconWithoutConsultingExportList ( q );
if (nonNull(c)) { /* data */
- fprintf(stderr, "data %s = ", textToStr(textOf(ex)) );
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isCon(ent2));
- c = findName ( textOf(ent2) );
- fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
+ fprintf(stderr, " data/newtype %s = { ", textToStr(textOf(ex)) );
+ assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
+ abstract = isNull(tycon(c).defn);
+ /* This data/newtype could be abstract even tho the export list
+ says to export it non-abstractly. That happens if it was
+ imported from some other module and is now being re-exported,
+ and previous cleanup phases have abstractified it in the
+ original (defining) module.
+ */
+ if (abstract) {
+ module(mod).exports = cons ( ex, module(mod).exports );
+ fprintf ( stderr, "(abstract) ");
+ } else {
+ module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ for (; nonNull(subents); subents = tl(subents)) {
+ Cell ent2 = hd(subents);
+ assert(isCon(ent2) || isVar(ent2));
+ /* isVar since could be a field name */
+ q = mkQualId(exmod,ent2);
+ c = findQualNameWithoutConsultingExportList ( q );
+ fprintf(stderr, "%s ", textToStr(name(c).text));
+ assert(nonNull(c));
+ module(mod).exports = cons(c, module(mod).exports);
+ }
}
- fprintf(stderr, "\n" );
+ fprintf(stderr, "}\n" );
} else { /* class */
- c = findClass ( textOf(ex) );
- assert(nonNull(c));
- fprintf(stderr, "class %s where ", textToStr(textOf(ex)) );
+ q = mkQualId(exmod,ex);
+ c = findQualClassWithoutConsultingExportList ( q );
+ if (isNull(c)) goto notfound;
+ fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
for (; nonNull(subents); subents = tl(subents)) {
Cell ent2 = hd(subents);
assert(isVar(ent2));
- c = findName ( textOf(ent2) );
+ q = mkQualId(exmod,ent2);
+ c = findQualNameWithoutConsultingExportList ( q );
fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
+ if (isNull(c)) goto notfound;
module(mod).exports = cons(c, module(mod).exports);
}
- fprintf(stderr, "\n" );
+ fprintf(stderr, "}\n" );
}
break;
@@ -593,6 +1089,14 @@ Void finishGHCModule ( Cell root )
internal("finishExports(2)");
} /* switch */
+ continue; /* so notfound: can be placed after this */
+
+ notfound:
+ /* q holds what ain't found */
+ assert(whatIs(q)==QUALIDENT);
+ fprintf( stderr, " ------ IGNORED: %s.%s\n",
+ textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
+ continue;
}
}
@@ -686,7 +1190,7 @@ void startGHCValue ( Int line, VarId vid, Type ty )
Text v = textOf(vid);
# ifdef DEBUG_IFACE
- printf("\nbegin startGHCValue %s\n", textToStr(v));
+ printf("begin startGHCValue %s\n", textToStr(v));
# endif
n = findName(v);
@@ -703,14 +1207,9 @@ void startGHCValue ( Int line, VarId vid, Type ty )
ty = mkPolyType(tvsToKind(tvs),ty);
ty = tvsToOffsets(line,ty,tvs);
-
- /* prepare for finishGHCValue */
name(n).type = ty;
name(n).arity = arityInclDictParams(ty);
name(n).line = line;
-# ifdef DEBUG_IFACE
- printf("end startGHCValue %s\n", textToStr(v));
-# endif
}
@@ -718,16 +1217,11 @@ void finishGHCValue ( VarId vid )
{
Name n = findName ( textOf(vid) );
Int line = name(n).line;
- Type ty = name(n).type;
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin finishGHCValue %s\n", textToStr(name(n).text) );
+ fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
# endif
assert(currentModule == name(n).mod);
- //setCurrModule(name(n).mod);
- name(n).type = conidcellsToTycons(line,ty);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end finishGHCValue %s\n", textToStr(name(n).text) );
-# endif
+ name(n).type = conidcellsToTycons(line,name(n).type);
}
@@ -742,7 +1236,7 @@ Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
/* ty :: Type */
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCSynonym %s\n", textToStr(t) );
+ fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
# endif
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
@@ -758,9 +1252,6 @@ Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
/* prepare for finishGHCSynonym */
tycon(tc).defn = tvsToOffsets(line,ty,tvs);
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCSynonym %s\n", textToStr(t) );
-# endif
}
@@ -768,6 +1259,9 @@ static Void finishGHCSynonym ( ConId tyc )
{
Tycon tc = findTycon(textOf(tyc));
Int line = tycon(tc).line;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
+# endif
assert (currentModule == tycon(tc).mod);
// setCurrModule(tycon(tc).mod);
@@ -808,8 +1302,9 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCDataDecl %s\n",textToStr(t));
+ fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
# endif
+
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
@@ -861,7 +1356,6 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
if (whatIs(tycon(tc).kind) != STAR)
selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
selTy = tvsToOffsets(line,selTy, ktyvars);
-
sels = cons( zpair(conArgNm,selTy), sels);
}
}
@@ -882,7 +1376,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
/* stick the tycon's kind on, if not simply STAR */
if (whatIs(tycon(tc).kind) != STAR)
- ty = pair(POLYTYPE,zpair(tycon(tc).kind, ty));
+ ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
ty = tvsToOffsets(line,ty, ktyvars);
@@ -898,9 +1392,6 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
*/
tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCDataDecl %s\n",textToStr(t));
-# endif
}
@@ -910,7 +1401,7 @@ static List startGHCConstrs ( Int line, List cons, List sels )
/* sels :: [((VarId,Type))] */
/* returns [Name] */
List cs, ss;
- Int conNo = 0; /* or maybe 1? */
+ Int conNo = length(cons)>1 ? 1 : 0;
for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
Name c = startGHCConstr(line,conNo,hd(cs));
hd(cs) = c;
@@ -978,7 +1469,7 @@ static Void finishGHCDataDecl ( ConId tyc )
List nms;
Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
+ printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCDataDecl");
@@ -988,9 +1479,6 @@ static Void finishGHCDataDecl ( ConId tyc )
assert(currentModule == name(n).mod);
name(n).type = conidcellsToTycons(line,name(n).type);
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
-# endif
}
@@ -1001,15 +1489,15 @@ static Void finishGHCDataDecl ( ConId tyc )
Void startGHCNewType ( Int line, List ctx0,
ConId tycon, List tvs, Cell constr )
{
- /* ctx0 :: [((QConId,VarId))] */
- /* tycon :: ConId */
- /* tvs :: [((VarId,Kind))] */
- /* constr :: ((ConId,Type)) */
+ /* ctx0 :: [((QConId,VarId))] */
+ /* tycon :: ConId */
+ /* tvs :: [((VarId,Kind))] */
+ /* constr :: ((ConId,Type)) or NIL if abstract */
List tmp;
Type resTy;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin startGHCNewType %s\n", textToStr(t) );
+ fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
# endif
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
@@ -1023,59 +1511,61 @@ Void startGHCNewType ( Int line, List ctx0,
tycon(tc).kind = tvsToKind(tvs);
/* can't really do this until I've read in all synonyms */
- {
- /* constr :: ((ConId,Type)) */
- Text con = textOf(zfst(constr));
- Type type = zsnd(constr);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = 1; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(0);
- name(n).defn = nameId;
- tycon(tc).defn = singleton(n);
-
- /* make resTy the result type of the constr, T v1 ... vn */
- resTy = tycon;
- for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,zfst(hd(tmp)));
- type = fn(type,resTy);
- if (nonNull(ctx0))
- type = ap(QUAL,pair(ctx0,type));
- type = tvsToOffsets(line,type,tvs);
- name(n).type = type;
+ if (isNull(constr)) {
+ tycon(tc).defn = NIL;
+ } else {
+ /* constr :: ((ConId,Type)) */
+ Text con = textOf(zfst(constr));
+ Type type = zsnd(constr);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = 1; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(0);
+ name(n).defn = nameId;
+ tycon(tc).defn = singleton(n);
+
+ /* make resTy the result type of the constr, T v1 ... vn */
+ resTy = tycon;
+ for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
+ resTy = ap(resTy,zfst(hd(tmp)));
+ type = fn(type,resTy);
+ if (nonNull(ctx0))
+ type = ap(QUAL,pair(ctx0,type));
+ type = tvsToOffsets(line,type,tvs);
+ name(n).type = type;
}
}
-# ifdef DEBUG_IFACE
- fprintf(stderr, "end startGHCNewType %s\n", textToStr(t) );
-# endif
}
static Void finishGHCNewType ( ConId tyc )
{
- Tycon tc = findTycon(tyc);
+ Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
+ printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCNewType");
- if (length(tycon(tc).defn) != 1) internal("finishGHCNewType(2)");
- {
+
+ if (isNull(tycon(tc).defn)) {
+ /* it's an abstract type */
+ }
+ else if (length(tycon(tc).defn) == 1) {
+ /* As we expect, has a single constructor */
Name n = hd(tycon(tc).defn);
Int line = name(n).line;
assert(currentModule == name(n).mod);
name(n).type = conidcellsToTycons(line,name(n).type);
+ } else {
+ internal("finishGHCNewType(2)");
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCNewType %s\n", textToStr(textOf(tyc)) );
-# endif
}
@@ -1098,7 +1588,7 @@ List mems0; { /* [((VarId, Type))] */
Text ct = textOf(tc_name);
Pair newCtx = pair(tc_name, zfst(kinded_tv));
# ifdef DEBUG_IFACE
- printf ( "\nbegin startGHCclass %s\n", textToStr(ct) );
+ printf ( "begin startGHCClass %s\n", textToStr(ct) );
# endif
if (length(kinded_tvs) != 1) {
@@ -1163,7 +1653,7 @@ List mems0; { /* [((VarId, Type))] */
memT = tvsToOffsets(line,memT,tvsInT);
/* Park the type back on the member */
- snd(mem) = memT;
+ mem = zpair(zfst(mem),memT);
/* Bind code to the member */
mn = findName(mnt);
@@ -1174,6 +1664,8 @@ List mems0; { /* [((VarId, Type))] */
EEND;
}
mn = newName(mnt,NIL);
+
+ hd(mems) = mem;
}
cclass(nw).members = mems0;
@@ -1186,9 +1678,6 @@ List mems0; { /* [((VarId, Type))] */
* cclass(nm).defaults = ?;
*/
}
-# ifdef DEBUG_IFACE
- printf ( "end startGHCclass %s\n", textToStr(ct) );
-# endif
}
@@ -1199,7 +1688,7 @@ static Void finishGHCClass ( Tycon cls_tyc )
Int ctr;
Class nw = findClass ( textOf(cls_tyc) );
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
+ printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
# endif
if (isNull(nw)) internal("finishGHCClass");
@@ -1223,9 +1712,6 @@ static Void finishGHCClass ( Tycon cls_tyc )
name(n).number = ctr++;
hd(mems) = n;
}
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCclass %s\n", textToStr(cclass(nw).text) );
-# endif
}
@@ -1233,15 +1719,15 @@ static Void finishGHCClass ( Tycon cls_tyc )
* Instances
* ------------------------------------------------------------------------*/
-Void startGHCInstance (line,ctxt0,cls,var)
+Inst startGHCInstance (line,ctxt0,cls,var)
Int line;
-List ctxt0; /* [(QConId, VarId)] */
+List ctxt0; /* [((QConId, VarId))] */
Type cls; /* Type */
VarId var; { /* VarId */
List tmp, tvs, ks;
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "\nbegin startGHCInstance\n" );
+ printf ( "begin startGHCInstance\n" );
# endif
/* Make tvs into a list of tyvars with bogus kinds. */
@@ -1254,13 +1740,25 @@ VarId var; { /* VarId */
ks = cons(STAR,ks);
}
/* tvs :: [((VarId,STAR))] */
-
inst(in).line = line;
inst(in).implements = NIL;
inst(in).kinds = ks;
inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
inst(in).numSpecifics = length(ctxt0);
inst(in).head = tvsToOffsets(line,cls,tvs);
+
+ /* Figure out the name of the class being instanced, and store it
+ at inst(in).c. finishGHCInstance will resolve it to a real Class. */
+ {
+ Cell cl = inst(in).head;
+ while (isAp(cl)) cl = arg(cl);
+ assert(whatIs(cl)==DICTAP);
+ cl = unap(DICTAP,cl);
+ cl = fst(cl);
+ assert ( isQCon(cl) );
+ inst(in).c = cl;
+ }
+
#if 0
Is this still needed?
{
@@ -1272,51 +1770,37 @@ VarId var; { /* VarId */
bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
}
#endif
-# ifdef DEBUG_IFACE
- printf ( "end startGHCInstance\n" );
-# endif
+ return in;
}
-static Void finishGHCInstance ( Type cls )
+static Void finishGHCInstance ( Inst in )
{
- /* Cls is the { C1 a1 } -> ... -> { Cn an }, where
- an isn't a type variable -- it's a data or tuple. */
- Inst in;
- Int line;
- Cell cl;
- Class c;
- ConId conid_cls;
- ConId conid_ty;
+ Int line;
+ Class c;
+ Type cls;
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCInstance\n" );
+ printf ( "begin finishGHCInstance\n" );
# endif
- cls = snd(cls); /* { Cn an } */
- conid_cls = fst(cls);
- conid_ty = snd(cls);
-
- if (whatIs(conid_cls) != CONIDCELL ||
- whatIs(conid_ty ) != CONIDCELL) internal("finishGHCInstance");
-
- in = findSimpleInstance ( conid_cls, conid_ty );
+ assert (nonNull(in));
line = inst(in).line;
- cl = fst(inst(in).head);
-
assert (currentModule==inst(in).mod);
- c = findClass(textOf(cl));
- if (isNull(c)) {
- ERRMSG(line) "Unknown class \"%s\" in instance",
- textToStr(textOf(cl))
- EEND;
- }
+
+ /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
+ since beginGHCInstance couldn't possibly have resolved it to
+ a Class at that point. We convert it to a Class now.
+ */
+ c = inst(in).c;
+ assert(isQCon(c));
+ c = findQualClassWithoutConsultingExportList(c);
+ assert(nonNull(c));
+ inst(in).c = c;
+
inst(in).head = conidcellsToTycons(line,inst(in).head);
inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
cclass(c).instances = cons(in,cclass(c).instances);
-# ifdef DEBUG_IFACE
- printf ( "end finishGHCInstance\n" );
-# endif
}
@@ -1330,14 +1814,14 @@ static Void finishGHCInstance ( Type cls )
The Offset for a type variable is determined by its place in the list
passed as the second arg; the associated kinds are irrelevant.
- ((t1,t2)) denotes the typed (z-)pair type of t1 and t2.
+ ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
*/
/* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
static Type tvsToOffsets(line,type,ktyvars)
Int line;
Type type;
-List ktyvars; { /* [(VarId,Kind)] */
+List ktyvars; { /* [((VarId,Kind))] */
switch (whatIs(type)) {
case NIL:
case TUPLE:
@@ -1372,7 +1856,7 @@ List ktyvars; { /* [(VarId,Kind)] */
for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
Cell varid;
Text tt;
-assert(isZPair(hd(ktyvars)));
+ assert(isZPair(hd(ktyvars)));
varid = zfst(hd(ktyvars));
tt = textOf(varid);
if (tv == tt) return mkOffset(i);
@@ -1391,16 +1875,6 @@ assert(isZPair(hd(ktyvars)));
return NIL; /* NOTREACHED */
}
-/* ToDo: nuke this */
-static Text kludgeGHCPrelText ( Text m )
-{
- return m;
-#if 0
- if (strncmp(textToStr(m), "Prel", 4)==0)
- return textPrelude; else return m;
-#endif
-}
-
/* This is called from the finishGHC* functions. It traverses a structure
and converts conidcells, ie, type constructors parsed by the interface
@@ -1410,22 +1884,21 @@ static Text kludgeGHCPrelText ( Text m )
Tycons or Classes have been loaded into the symbol tables and can be
looked up.
*/
-static Type conidcellsToTycons(line,type)
-Int line;
-Type type; {
+static Type conidcellsToTycons ( Int line, Type type )
+{
switch (whatIs(type)) {
case NIL:
case OFFSET:
case TYCON:
case CLASS:
case VARIDCELL:
+ case TUPLE:
+ case STAR:
return type;
case QUALIDENT:
- { List t;
- Text m = kludgeGHCPrelText(qmodOf(type));
- Text v = qtextOf(type);
+ { Cell t; /* Tycon or Class */
+ Text m = qmodOf(type);
Module mod = findModule(m);
- //printf ( "lookup qualident " ); print(type,100); printf("\n");
if (isNull(mod)) {
ERRMSG(line)
"Undefined module in qualified name \"%s\"",
@@ -1433,10 +1906,10 @@ Type type; {
EEND;
return NIL;
}
- for (t=module(mod).tycons; nonNull(t); t=tl(t))
- if (v == tycon(hd(t)).text) return hd(t);
- for (t=module(mod).classes; nonNull(t); t=tl(t))
- if (v == cclass(hd(t)).text) return hd(t);
+ t = findQualTyconWithoutConsultingExportList(type);
+ if (nonNull(t)) return t;
+ t = findQualClassWithoutConsultingExportList(type);
+ if (nonNull(t)) return t;
ERRMSG(line)
"Undefined qualified class or type \"%s\"",
identToStr(type)
@@ -1446,10 +1919,14 @@ Type type; {
case CONIDCELL:
{ Tycon tc;
Class cl;
- tc = findQualTycon(type);
- if (nonNull(tc)) return tc;
cl = findQualClass(type);
if (nonNull(cl)) return cl;
+ if (textOf(type)==findText("[]"))
+ /* a hack; magically qualify [] into PrelBase.[] */
+ return conidcellsToTycons(line,
+ mkQualId(mkCon(findText("PrelBase")),type));
+ tc = findQualTycon(type);
+ if (nonNull(tc)) return tc;
ERRMSG(line)
"Undefined class or type constructor \"%s\"",
identToStr(type)
@@ -1459,6 +1936,10 @@ Type type; {
case AP:
return ap( conidcellsToTycons(line,fun(type)),
conidcellsToTycons(line,arg(type)) );
+ case ZTUP2: /* convert to std pair */
+ return ap( conidcellsToTycons(line,zfst(type)),
+ conidcellsToTycons(line,zsnd(type)) );
+
case POLYTYPE:
return mkPolyType (
polySigOf(type),
@@ -1472,6 +1953,8 @@ Type type; {
return ap(DICTAP, conidcellsToTycons(line, snd(type)));
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
+ case BANG:
+ return ap(BANG, conidcellsToTycons(line, snd(type)));
default:
fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
whatIs(type));
@@ -1484,6 +1967,50 @@ Type type; {
}
+/* Find out if a type mentions a type constructor not present in
+ the supplied list of qualified tycons.
+*/
+static Bool allTypesKnown ( Type type,
+ List aktys /* [QualId] */,
+ ConId thisMod )
+{
+ switch (whatIs(type)) {
+ case NIL:
+ case OFFSET:
+ case VARIDCELL:
+ case TUPLE:
+ return TRUE;
+ case AP:
+ return allTypesKnown(fun(type),aktys,thisMod)
+ && allTypesKnown(arg(type),aktys,thisMod);
+ case ZTUP2:
+ return allTypesKnown(zfst(type),aktys,thisMod)
+ && allTypesKnown(zsnd(type),aktys,thisMod);
+ case DICTAP:
+ return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
+
+ case CONIDCELL:
+ if (textOf(type)==findText("[]"))
+ /* a hack; magically qualify [] into PrelBase.[] */
+ type = mkQualId(mkCon(findText("PrelBase")),type); else
+ type = mkQualId(thisMod,type);
+ /* fall through */
+ case QUALIDENT:
+ if (isNull(qualidIsMember(type,aktys))) goto missing;
+ return TRUE;
+
+ default:
+ fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
+ print(type,10);printf("\n");
+ internal("allTypesKnown");
+ return TRUE; /*notreached*/
+ }
+ missing:
+ printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
+ return FALSE;
+}
+
+
/* --------------------------------------------------------------------------
* Utilities
*
@@ -1992,9 +2519,10 @@ void* lookupObjName ( char* nm )
pp = strchr(nm2, '_');
if (!pp) goto not_found;
*pp = 0;
- t = kludgeGHCPrelText( unZcodeThenFindText(nm2) );
+ t = unZcodeThenFindText(nm2);
m = findModule(t);
if (isNull(m)) goto not_found;
+fprintf(stderr, " %%%% %s\n", nm );
a = lookupOTabName ( m, nm );
if (a) return a;
diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index dbab049b3512b510e73e725f07a0a846dfa7ad5d..47d1e59e25094ce91f01fb8ffa919086d6cff4cf 100644
--- a/ghc/interpreter/link.c
+++ b/ghc/interpreter/link.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/12/10 15:59:48 $
+ * $Revision: 1.22 $
+ * $Date: 1999/12/16 16:34:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -496,16 +496,39 @@ break;
case PREPREL :
- modulePrelude = newModule(textPrelude);
- setCurrModule(modulePrelude);
-
- for (i=0; i<NUM_TUPLES; ++i) {
- allocTupleTycon(i);
- }
-
if (combined) {
+
+ nameMkC = addWiredInBoxingTycon("PrelBase","Char", "C#",1,0,CHAR_REP );
+ nameMkI = addWiredInBoxingTycon("PrelBase","Int", "I#",1,0,INT_REP );
+ nameMkW = addWiredInBoxingTycon("PrelAddr","Word", "W#",1,0,WORD_REP );
+ nameMkA = addWiredInBoxingTycon("PrelAddr","Addr", "A#",1,0,ADDR_REP );
+ nameMkF = addWiredInBoxingTycon("PrelBase","Float", "F#",1,0,FLOAT_REP );
+ nameMkD = addWiredInBoxingTycon("PrelBase","Double","D#",1,0,DOUBLE_REP);
+ nameMkInteger
+ = addWiredInBoxingTycon("PrelBase","Integer","Integer#",1,0,0);
+ nameMkPrimByteArray
+ = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",1,0,0);
+
+ for (i=0; i<NUM_TUPLES; ++i) {
+ addTupleTycon(i);
+ }
+ addWiredInEnumTycon("PrelBase","Bool",
+ doubleton(findText("False"),findText("True")));
+
+ //nameMkThreadId
+ // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
+ // ,1,0,THREADID_REP);
+
} else {
+ modulePrelude = newModule(textPrelude);
+ setCurrModule(modulePrelude);
+
+ for (i=0; i<NUM_TUPLES; ++i) {
+ addTupleTycon(i);
+ }
+ setCurrModule(modulePrelude);
+
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
2,DATATYPE,NIL);
diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y
index 47b1ff47b064027cf7df5d7f7291938b447cd931..694dd169ba56a00c329b311443c44f94d676e098 100644
--- a/ghc/interpreter/parser.y
+++ b/ghc/interpreter/parser.y
@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.18 $
- * $Date: 1999/12/10 15:59:49 $
+ * $Revision: 1.19 $
+ * $Date: 1999/12/16 16:34:42 $
* ------------------------------------------------------------------------*/
%{
@@ -150,7 +150,7 @@ ifTopDecl
| TINSTANCE ifCtxInst ifInstHdL '=' ifVar
{$$=gc5(ap(I_INSTANCE,
- z4ble($1,$2,$3,$5)));}
+ z5ble($1,$2,$3,$5,NIL)));}
| NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
{$$=gc6(ap(I_TYPE,
@@ -236,7 +236,7 @@ ifInstHd /* { Class aType } :: (ConId, Type) */
ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
: ifInstHd ARROW ifInstHdL {$$=gc3(fn($1,$3));}
- | ifInstHd {$$=gc1(NIL);}
+ | ifInstHd {$$=gc1($1);}
;
ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
@@ -265,36 +265,36 @@ ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
mkInt(2) indicates unpacked -- a GHC extension.
*/
-ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,VarId,Int)])] */
+ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
: {$$ = gc0(NIL);}
| '=' ifConstrL {$$ = gc2($2);}
;
-ifConstrL /* [(ConId,[(Type,VarId,Int)])] */
+ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
: ifConstr {$$ = gc1(singleton($1));}
| ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
;
-ifConstr /* (ConId,[(Type,VarId,Int)]) */
+ifConstr /* ((ConId,[((Type,VarId,Int))])) */
: ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
| ifConData '{' ifDataNamedFieldL '}'
{$$ = gc4(zpair($1,$3));}
;
-ifDataAnonFieldL /* [(Type,VarId,Int)] */
+ifDataAnonFieldL /* [((Type,VarId,Int))] */
: {$$=gc0(NIL);}
| ifDataAnonField ifDataAnonFieldL
{$$=gc2(cons($1,$2));}
;
-ifDataNamedFieldL /* [(Type,VarId,Int)] */
+ifDataNamedFieldL /* [((Type,VarId,Int))] */
: {$$=gc0(NIL);}
| ifDataNamedField {$$=gc1(cons($1,NIL));}
| ifDataNamedField ',' ifDataNamedFieldL
{$$=gc3(cons($1,$3));}
;
-ifDataAnonField /* (Type,VarId,Int) */
+ifDataAnonField /* ((Type,VarId,Int)) */
: ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
| '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
| '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
;
-ifDataNamedField /* (Type,VarId,Int) */
+ifDataNamedField /* ((Type,VarId,Int)) */
: ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
| ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
| ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
@@ -302,15 +302,15 @@ ifDataNamedField /* (Type,VarId,Int) */
/*- Interface class declarations - methods ----------------*/
-ifCmeths /* [(VarId,Type)] */
+ifCmeths /* [((VarId,Type))] */
: { $$ = gc0(NIL); }
| WHERE '{' ifCmethL '}' { $$ = gc4($3); }
;
-ifCmethL /* [(VarId,Type)] */
+ifCmethL /* [((VarId,Type))] */
: ifCmeth { $$ = gc1(singleton($1)); }
| ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
;
-ifCmeth /* (VarId,Type) */
+ifCmeth /* ((VarId,Type)) */
: ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
| ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
/* has default method */
@@ -318,7 +318,7 @@ ifCmeth /* (VarId,Type) */
/*- Interface newtype declararions ------------------------*/
-ifNewTypeConstr /* (ConId,Type) */
+ifNewTypeConstr /* ((ConId,Type)) */
: '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
;
@@ -356,7 +356,8 @@ ifAType : ifQTCName { $$ = gc1($1); }
| ifTyvar { $$ = gc1($1); }
| '(' ')' { $$ = gc2(typeUnit); }
| '(' ifTypeL2 ')' { $$ = gc3(buildTuple($2)); }
- | '[' ifType ']' { $$ = gc3(ap(typeList,$2));}
+ | '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
+ $2));}
| '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP,
pair($2,$3))); }
| '(' ifType ')' { $$ = gc3($2); }
diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index ec0bbc9535d62917937f530bb30fefddeddb1008..a8318ca35ee4f1772a0408957c9cc65cba324bc0 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.25 $
- * $Date: 1999/12/10 15:59:53 $
+ * $Revision: 1.26 $
+ * $Date: 1999/12/16 16:34:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -581,18 +581,20 @@ List ts; { /* Null pattern matches every tycon*/
Text ghcTupleText_n ( Int n )
{
Int i;
- char buf[103];
+ char buf[104];
if (n < 0 || n >= 100) internal("ghcTupleText_n");
buf[0] = '(';
for (i = 1; i <= n; i++) buf[i] = ',';
- buf[i] = ')';
- buf[i+1] = 0;
+ buf[n+1] = ')';
+ buf[n+2] = 0;
return findText(buf);
}
Text ghcTupleText(tup)
Tycon tup; {
- assert(isTuple(tup));
+ if (!isTuple(tup)) {
+ assert(isTuple(tup));
+ }
return ghcTupleText_n ( tupleOf(tup) );
}
@@ -607,23 +609,6 @@ Tycon mkTuple ( Int n )
internal("mkTuple: request for non-existent tuple");
}
-Void allocTupleTycon ( Int n )
-{
- Int i;
- Kind k;
- Tycon t;
- for (i = TYCMIN; i < tyconHw; i++)
- if (tycon(i).tuple == n) return;
-
- //t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL);
-
- 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;
-}
/* --------------------------------------------------------------------------
* Name storage:
@@ -771,6 +756,95 @@ void* getHugs_AsmObject_for ( char* s )
* 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 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;
+
+ 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;
+ 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;
@@ -1052,20 +1126,123 @@ Type tc; {
|| typeInvolves(arg(ty),tc)));
}
-Inst findSimpleInstance ( ConId klass, ConId dataty )
+
+/* 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 )
{
- Inst in;
- for (in = INSTMIN; in < instHw; in++) {
- Cell head = inst(in).head;
- if (isClass(fun(head))
- && cclass(fun(head)).text==textOf(klass)
- && typeInvolves(arg(head), findTycon(textOf(dataty)) )
- )
- return in;
+ 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;
}
+
+/* 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:
*
@@ -1153,6 +1330,7 @@ Text t; {
}
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;
@@ -1306,7 +1484,7 @@ void* lookupOTabName ( Module m, char* nm )
{
int i;
for (i = 0; i < module(m).usedoTab; i++) {
- if (1)
+ if (0)
fprintf ( stderr,
"lookupOTabName: request %s, table has %s\n",
nm, module(m).oTab[i].nm );
@@ -1969,7 +2147,7 @@ Int depth; {
Printf("Offset %d", offsetOf(c));
break;
case TUPLE:
- Printf("%s", textToStr(ghcTupleText(tupleOf(c))));
+ Printf("%s", textToStr(ghcTupleText(c)));
break;
case POLYTYPE:
Printf("Polytype");
@@ -2103,8 +2281,20 @@ Int depth; {
break;
case ZTUP2:
Printf("<ZPair ");
- print(snd(c),depth-1);
+ 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);
@@ -2172,6 +2362,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;
@@ -2349,6 +2549,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; {
diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 5fc03507b7741e8708fcedc29b53e16b5e4d33fa..74f368c37b9389c7ff7786d8bceb19c912e5b0e2 100644
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.20 $
- * $Date: 1999/12/10 15:59:54 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/16 16:34:45 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
@@ -49,6 +49,8 @@ typedef Cell Ext; /* extension label */
typedef Cell ConId;
typedef Cell VarId;
+typedef Cell QualId;
+typedef Cell ConVarId;
/* --------------------------------------------------------------------------
* Text storage:
@@ -177,6 +179,7 @@ extern Cell whatIs Args((Cell));
#define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
#define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
#define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
+#define mkQualId(m,t) ap(QUALIDENT,pair(m,t))
#define intValOf(c) (snd(c))
#define inventVar() mkVar(inventText())
#define mkDictVar(t) ap(DICTVAR,t)
@@ -196,6 +199,7 @@ extern Bool isCon Args((Cell));
extern Bool isQVar Args((Cell));
extern Bool isQCon Args((Cell));
extern Bool isQualIdent Args((Cell));
+extern Bool eqQualIdent ( QualId c1, QualId c2 );
extern Bool isIdent Args((Cell));
extern String stringNegate Args((String));
extern Text textOf Args((Cell));
@@ -318,63 +322,67 @@ extern Ptr cptrOf Args((Cell));
type <a> = ZList a
type ExportListEntry = ConVarId | (ConId, <ConVarId>)
type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
- type Constr = (ConId, <(Type,VarId,Int)>)
- (constr name, list of (type, field name if any, strictness))
+ type Constr = ((ConId, [((Type,VarId,Int))]))
+ ((constr name, [((type, field name if any, strictness))]))
strictness: 0 => none, 1 => !, 2 => !! (unpacked)
All 2/3/4/5 tuples in the interface abstract syntax are done with
z-tuples.
*/
-#define I_INTERFACE 109 /* snd :: (ConId, <I_IMPORT..I_VALUE>)
+#define I_INTERFACE 109 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
interface name, list of iface entities */
-#define I_IMPORT 110 /* snd :: (ConId, <ConVarId>)
+#define I_IMPORT 110 /* snd :: ((ConId, [ConVarId]))
module name, list of entities */
#define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */
-#define I_EXPORT 112 /* snd :: (ConId, <ExportListEntry>
+#define I_EXPORT 112 /* snd :: ((ConId, [ExportListEntry]))
this module name?, entities to export */
-#define I_FIXDECL 113 /* snd :: (NIL|Int, Associativity, ConVarId)
+#define I_FIXDECL 113 /* snd :: ((NIL|Int, Associativity, ConVarId))
fixity, associativity, name */
-#define I_INSTANCE 114 /* snd :: (Line, <(QConId,VarId)>, Type, VarId)
+#define I_INSTANCE 114 /* snd :: ((Line, [((QConId,VarId))],
+ Type, VarId, Inst))
lineno,
forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>),
other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
- name of dictionary builder */
+ name of dictionary builder,
+ (after startGHCInstance) the instance table location */
-#define I_TYPE 115 /* snd :: (Line, ConId, <(VarId,Kind)>, Type)
+#define I_TYPE 115 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
lineno, tycon, kinded tyvars, the type expr */
-#define I_DATA 116 /* snd :: (Line, <(QConId,VarId)>, ConId,
- <(VarId,Kind)>, <Constr>)
- lineno, context, tycon, kinded tyvars, constrs */
+#define I_DATA 116 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], [Constr])
+ lineno, context, tycon, kinded tyvars, constrs
+ An empty constr list means exported abstractly. */
-#define I_NEWTYPE 117 /* snd :: (Line, <(QConId,VarId)>, ConId,
- <(VarId,Kind)>, (ConId,Type))
- lineno, context, tycon, kinded tyvars, constr */
+#define I_NEWTYPE 117 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], ((ConId,Type)) ))
+ lineno, context, tycon, kinded tyvars, constr
+ constr==NIL means exported abstractly. */
-#define I_CLASS 118 /* snd :: (Line, <(QConId,VarId)>, ConId,
- <(VarId,Kind)>, <(VarId,Type)>)
+#define I_CLASS 118 /* snd :: ((Line, [((QConId,VarId))], ConId,
+ [((VarId,Kind))], [((VarId,Type))]))
lineno, context, classname,
kinded tyvars, method sigs */
-#define I_VALUE 119 /* snd :: (Line, VarId, Type) */
+#define I_VALUE 119 /* snd :: ((Line, VarId, Type)) */
/* Generic syntax */
#if 0
-#define ZCONS 190 /* snd :: (Cell,Cell) */
+#define ZCONS 190 /* snd :: (Cell,Cell) */
#endif
-#define ZTUP2 192 /* snd :: (Cell,Cell) */
-#define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */
-#define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */
-#define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
+#define ZTUP2 192 /* snd :: (Cell,Cell) */
+#define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */
+#define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */
+#define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
/* Last constructor tag must be less than SPECMIN */
@@ -448,6 +456,14 @@ extern Ext mkExt Args((Text));
#define mkExt(t) NIL
#endif
+extern Module findFakeModule ( Text t );
+extern Tycon addTupleTycon ( Int n );
+extern Name addWiredInBoxingTycon
+ ( String modNm, String typeNm, String constrNm,
+ Int arity, Int no, Int rep );
+Tycon addWiredInEnumTycon ( String modNm, String typeNm,
+ List /*of Text*/ constrs );
+
/* --------------------------------------------------------------------------
* Offsets: (generic types/stack offsets)
* ------------------------------------------------------------------------*/
@@ -513,6 +529,9 @@ struct Module {
*/
List qualImports;
+ /* TRUE if module exists only via GHC primop defn; usually FALSE */
+ Bool fake;
+
/* ptr to malloc'd lump of memory holding the obj file */
void* oImage;
@@ -558,7 +577,6 @@ extern DLSect lookupDLSect Args((void*));
#define isTuple(c) (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple>=0)
#define tupleOf(n) (tabTycon[(n)-TYCMIN].tuple)
extern Tycon mkTuple ( Int );
-extern Void allocTupleTycon ( Int );
struct strTycon {
@@ -593,6 +611,7 @@ extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
#define monotypeOf(t) snd(snd(t))
#define bang(t) ap(BANG,t)
+extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Globally defined name values:
@@ -663,6 +682,8 @@ extern Int sfunPos Args((Name,Name));
extern Name nameFromStgVar Args((Cell));
extern Name jrsFindQualName Args((Text,Text));
+extern Name findQualNameWithoutConsultingExportList ( QualId q );
+
/* --------------------------------------------------------------------------
* Type class values:
* ------------------------------------------------------------------------*/
@@ -725,7 +746,8 @@ extern Class findQualClass Args((Cell));
extern Inst newInst Args((Void));
extern Inst findFirstInst Args((Tycon));
extern Inst findNextInst Args((Tycon,Inst));
-extern Inst findSimpleInstance ( ConId klass, ConId dataty );
+extern List getAllKnownTyconsAndClasses ( void );
+extern Class findQualClassWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Character values:
@@ -790,6 +812,7 @@ extern Cell cellRevAssoc Args((Cell,List));
extern Bool eqList Args((List,List));
extern Cell varIsMember Args((Text,List));
extern Name nameIsMember Args((Text,List));
+extern QualId qualidIsMember ( QualId, List );
extern Cell intIsMember Args((Int,List));
extern List replicate Args((Int,Cell));
extern List diffList Args((List,List)); /* destructive */
diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index bb7d86f38c503dd15f9e75ee3ddfc9f167af30fc..bd653fdc115d710dd2e936dccf9315af815cf339 100644
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.19 $
- * $Date: 1999/12/10 15:59:57 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/16 16:34:46 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -2801,6 +2801,32 @@ Int what; {
typeChecker(RESET);
if (combined) {
+ Module m = findFakeModule(findText("PrelBase"));
+ setCurrModule(m);
+
+ starToStar = simpleKind(1);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
+
+ listof = ap(typeList,aVar);
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
+
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
} else {
dummyVar = inventVar();