From 0c97d6499a6df25503df68181a18507bff234514 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Thu, 16 Dec 1999 16:34:46 +0000
Subject: [PATCH] [project @ 1999-12-16 16:34:40 by sewardj] Further major
improvements in interface processing, mostly in the handling of types.
Interfaces can contain references to unboxed types, and these need to
be handled carefully. The following is a summary of how the interface
loader now works. It is applied to groups of interfaces simultaneously,
viz, the entire Prelude at once:
1. Throw away any entity not mentioned in the export lists.
2. Delete type (not data or newtype) definitions which refer to
unknown types in their right hand sides. Because Hugs doesn't
know of any unboxed types, this has the side effect of removing
all type defns referring to unboxed types. Repeat step 2 until
a fixed point is reached.
3. Make abstract all data/newtype defns which refer to an unknown
type. eg, data Word = MkW Word# becomes data Word, because
Word# is unknown. Hugs is happy to know about abstract boxed
Words, but not about Word#s.
4. Step 2 could delete types referred to by values, instances and
classes. So filter all entities, and delete those referring to
unknown types _or_ classes. This could cause other entities
to become invalid, so iterate step 4 to a fixed point.
After step 4, the interfaces no longer contain anything
unpalatable to Hugs.
5. Steps 1-4 operate purely on the iface syntax trees. We now start
creating symbol table entries. First, create a module table
entry for each interface, and locate and read in the corresponding
object file.
6. Traverse all interfaces. For each entity, create an entry in
the name, tycon, class or instance table, and fill in relevant
fields, but do not attempt to link tycon/class/instance/name uses
to their symbol table entries.
7. Revisit all symbol table entries created in step 6. We should
now be able to replace all references to tycons/classes/instances/
names with the relevant symbol table entries.
8. Traverse all interfaces. For each iface, examine the export lists
and use it to build export lists in the module table. Do the
implicit 'import Prelude' thing if necessary. Finally, resolve
references in the object code for this module.
I'm sure the number of passes could be reduced. For the moment,
understandability is of much higher priority.
Hugs can now complete stages 1 through 8 for the whole GHC Prelude,
excepting doing the object linking, which needs further work.
---
ghc/interpreter/interface.c | 1048 ++++++++++++++++++++++++++---------
ghc/interpreter/link.c | 41 +-
ghc/interpreter/parser.y | 33 +-
ghc/interpreter/storage.c | 279 ++++++++--
ghc/interpreter/storage.h | 77 ++-
ghc/interpreter/type.c | 30 +-
6 files changed, 1159 insertions(+), 349 deletions(-)
diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 34b9d214d6e1..865a30a70bd5 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 dbab049b3512..47d1e59e2509 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 47b1ff47b064..694dd169ba56 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 ec0bbc9535d6..a8318ca35ee4 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 5fc03507b774..74f368c37b93 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 bb7d86f38c50..bd653fdc115d 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();
--
GitLab