* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.15 $
- * $Date: 2000/01/05 13:53:36 $
+ * $Revision: 1.36 $
+ * $Date: 2000/03/10 14:53:00 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "object.h"
-#define DEBUG_IFACE
+/*#define DEBUG_IFACE*/
#define VERBOSE FALSE
-extern void print ( Cell, Int );
-
/* --------------------------------------------------------------------------
* (This comment is now out of date. JRS, 991216).
* The "addGHC*" functions act as "impedence matchers" between GHC
static Void startGHCSynonym Args((Int,Cell,List,Type));
static Void finishGHCSynonym Args((Tycon));
-static Void startGHCClass Args((Int,List,Cell,List,List));
-static Void finishGHCClass Args((Class));
+static Void startGHCClass Args((Int,List,Cell,List,List));
+static Class finishGHCClass Args((Class));
static Inst startGHCInstance Args((Int,List,Pair,VarId));
static Void finishGHCInstance Args((Inst));
static Void startGHCExports Args((ConId,List));
static Void finishGHCExports Args((ConId,List));
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
+
static Void finishGHCModule Args((Cell));
static Void startGHCModule Args((Text, Int, Text));
static Void startGHCDataDecl Args((Int,List,Cell,List,List));
-static Void finishGHCDataDecl ( ConId tyc );
+static List finishGHCDataDecl ( ConId tyc );
static Void startGHCNewType Args((Int,List,Cell,List,Cell));
static Void finishGHCNewType ( ConId tyc );
* ------------------------------------------------------------------------*/
/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
-ConVarId getIEntityName ( Cell c )
+static ConVarId getIEntityName ( Cell c )
{
switch (whatIs(c)) {
case I_IMPORT: return NIL;
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) )
+static Cell filterInterface ( Cell root,
+ Bool (*pred)(Cell,Cell),
+ Cell extraArgs,
+ Void (*dumpAction)(Cell) )
{
List tops;
Cell iface = unap(I_INTERFACE,root);
ConId m_to_imp = zfst(imp_decl);
if (textOf(m_to_imp) != findText("PrelGHC")) {
imports = cons(m_to_imp,imports);
- /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "add iface %s\n",
+ textToStr(textOf(m_to_imp)));
+# endif
}
}
return zpair(iface,imports);
}
+/* Does t start with "$dm" ? */
+static Bool isIfaceDefaultMethodName ( Text t )
+{
+ String s = textToStr(t);
+ return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
+}
+
static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
{
/* ife :: I_IMPORT..I_VALUE */
/* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
- Text tnm;
- List exlist;
- List t;
+ Text tnm;
+ List exlist;
+ List t;
+ String s;
ConVarId ife_id = getIEntityName ( ife );
tnm = textOf(ife_id);
+ /* Don't junk default methods, even tho the export list doesn't
+ mention them.
+ */
+ if (isIfaceDefaultMethodName(tnm)) goto retain;
+
/* for each export list ... */
for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
exlist = hd(exlist_list);
}
}
+# ifdef DEBUG_IFACE
fprintf ( stderr, " dump %s\n", textToStr(tnm) );
+# endif
return FALSE;
retain:
+# ifdef DEBUG_IFACE
fprintf ( stderr, " retain %s\n", textToStr(tnm) );
+# endif
return TRUE;
}
List exlist_list = NIL;
List t;
+# ifdef DEBUG_IFACE
fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
+# endif
exlist_list = getExportDeclsInIFace ( root );
/* exlist_list :: [I_EXPORT] */
/* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
-List addTyconsAndClassesFromIFace ( Cell root, List aktys )
+static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
{
Cell iface = unap(I_INTERFACE,root);
Text mname = textOf(zfst(iface));
}
-Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
+static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
{
ConVarId id = getIEntityName ( entity );
+# ifdef DEBUG_IFACE
fprintf ( stderr,
"dumping %s because of unknown type(s)\n",
isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
+# endif
}
+
/* 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 )
+static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
{
List t, u;
List aktys = zfst ( aktys_mod );
}
-#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 )
+static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
{
List t, u;
List aktys = zfst ( aktys_mod );
}
}
-Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
+
+static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
{
ConVarId id = getIEntityName ( entity );
assert (whatIs(entity)==I_TYPE);
assert (isCon(id));
+# ifdef DEBUG_IFACE
fprintf ( stderr,
"dumping type %s because of unknown tycon(s)\n",
textToStr(textOf(id)) );
+# endif
}
/* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
*/
-List abstractifyExDecl ( Cell root, ConId toabs )
+static List abstractifyExDecl ( Cell root, ConId toabs )
{
ZPair exdecl = unap(I_EXPORT,root);
List exlist = zsnd(exdecl);
}
-Void ppModule ( Text modt )
+static Void ppModule ( Text modt )
{
+# ifdef DEBUG_IFACE
fflush(stderr); fflush(stdout);
fprintf(stderr, "---------------- MODULE %s ----------------\n",
textToStr(modt) );
+# endif
+}
+
+
+static void* ifFindItblFor ( Name n )
+{
+ /* n is a constructor for which we want to find the GHC info table.
+ First look for a _con_info symbol. If that doesn't exist, _and_
+ this is a nullary constructor, then it's safe to look for the
+ _static_info symbol instead.
+ */
+ void* p;
+ char buf[1000];
+ Text t;
+
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
+ textToStr( module(name(n).mod).text ),
+ textToStr( name(n).text ) );
+ t = enZcodeThenFindText(buf);
+ p = lookupOTabName ( name(n).mod, textToStr(t) );
+
+ if (p) return p;
+
+ if (name(n).arity == 0) {
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
+ textToStr( module(name(n).mod).text ),
+ textToStr( name(n).text ) );
+ t = enZcodeThenFindText(buf);
+ p = lookupOTabName ( name(n).mod, textToStr(t) );
+ if (p) return p;
+ }
+
+ ERRMSG(0) "Can't find info table %s", textToStr(t)
+ EEND;
+}
+
+
+void ifLinkConstrItbl ( Name n )
+{
+ /* name(n) is either a constructor or a field name.
+ If the latter, ignore it. If it is a non-nullary constructor,
+ find its info table in the object code. If it's nullary,
+ we can skip the info table, since all accesses will go via
+ the _closure label.
+ */
+ if (islower(textToStr(name(n).text)[0])) return;
+ if (name(n).arity == 0) return;
+ name(n).itbl = ifFindItblFor(n);
+}
+
+
+static void ifSetClassDefaultsAndDCon ( Class c )
+{
+ char buf[100];
+ char buf2[1000];
+ String s;
+ Name n;
+ Text t;
+ void* p;
+ List defs; /* :: [Name] */
+ List mems; /* :: [Name] */
+ Module m;
+ assert(isNull(cclass(c).defaults));
+
+ /* Create the defaults list by more-or-less cloning the members list. */
+ defs = NIL;
+ for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
+ strcpy(buf, "$dm");
+ s = textToStr( name(hd(mems)).text );
+ assert(strlen(s) < 95);
+ strcat(buf, s);
+ n = findNameInAnyModule(findText(buf));
+ assert (nonNull(n));
+ defs = cons(n,defs);
+ }
+ defs = rev(defs);
+ cclass(c).defaults = defs;
+
+ /* Create a name table entry for the dictionary datacon.
+ Interface files don't mention them, so it had better not
+ already be present.
+ */
+ strcpy(buf, ":D");
+ s = textToStr( cclass(c).text );
+ assert( strlen(s) < 96 );
+ strcat(buf, s);
+ t = findText(buf);
+ n = findNameInAnyModule(t);
+ assert(isNull(n));
+
+ m = cclass(c).mod;
+ n = newName(t,NIL);
+ name(n).mod = m;
+ name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
+ name(n).number = cfunNo(0);
+ cclass(c).dcon = n;
+
+ /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
+ Because this happens right at the end of loading, we know
+ that we should actually be able to find the symbol in this
+ module's object symbol table. Except that if the dictionary
+ has arity 1, we don't bother, since it will be represented as
+ a newtype and not as a data, so its itbl can remain NULL.
+ */
+ if (name(n).arity == 1) {
+ name(n).itbl = NULL;
+ name(n).defn = nameId;
+ } else {
+ p = ifFindItblFor ( n );
+ name(n).itbl = p;
+ }
}
/* ifaces_outstanding holds a list of parsed interfaces
for which we need to load objects and create symbol
table entries.
+
+ Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
*/
-Void processInterfaces ( void )
+Bool processInterfaces ( void )
{
List tmp;
List xs;
Module mod;
List all_known_types;
Int num_known_types;
+ Bool didPrelude;
+ List cls_list; /* :: List Class */
+ List constructor_list; /* :: List Name */
List ifaces = NIL; /* :: List I_INTERFACE */
List iface_sizes = NIL; /* :: List Int */
List iface_onames = NIL; /* :: List Text */
+ if (isNull(ifaces_outstanding)) return FALSE;
+
+# ifdef DEBUG_IFACE
fprintf ( stderr,
"processInterfaces: %d interfaces to process\n",
length(ifaces_outstanding) );
-
+# endif
/* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
/* Have we reached a fixed point? */
i = length(all_known_types);
- printf ( "\n============= %d known types =============\n", i );
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "\n============= %d known types =============\n", i );
+# endif
if (num_known_types == i) break;
num_known_types = i;
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;
+ if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
}
else if (whatIs(ent)==I_NEWTYPE) {
Cell newty = unap(I_NEWTYPE,ent);
if (!allKnown) {
absify = cons ( getIEntityName(ent), absify );
+# ifdef DEBUG_IFACE
fprintf ( stderr,
"abstractifying %s because it uses an unknown type\n",
textToStr(textOf(getIEntityName(ent))) );
+# endif
}
}
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))) );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "abstractify data %s\n",
+ textToStr(textOf(getIEntityName(ent))) );
+# endif
}
else if (whatIs(ent)==I_NEWTYPE
&& isExportedAbstractly ( getIEntityName(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))) );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "abstractify newtype %s\n",
+ textToStr(textOf(getIEntityName(ent))) );
+# endif
}
}
be value defns, classes and instances which refer to unknown types.
Delete iteratively until a fixed point is reached.
*/
-printf("\n");
-
+# ifdef DEBUG_IFACE
+ fprintf(stderr,"\n");
+# endif
num_known_types = 999999999;
while (TRUE) {
Int i;
/* Have we reached a fixed point? */
i = length(all_known_types);
- printf ( "\n------------- %d known types -------------\n", i );
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,
+ "\n------------- %d known types -------------\n", i );
+# endif
if (num_known_types == i) break;
num_known_types = i;
}
}
- fprintf(stderr, "\n=========================================================\n");
- fprintf(stderr, "=========================================================\n");
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n============================"
+ "=============================\n");
+ fprintf(stderr, "=============================="
+ "===========================\n");
+# endif
/* Traverse again the decl lists of the modules, this time
calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
+ didPrelude = FALSE;
+ cls_list = NIL;
+ constructor_list = NIL;
for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
setCurrModule(mod);
ppModule ( module(mod).text );
+ if (mname == textPrelude) didPrelude = TRUE;
+
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
switch(whatIs(decl)) {
break;
}
case I_FIXDECL: {
+ Cell fixdecl = unap(I_FIXDECL,decl);
+ finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
break;
}
case I_INSTANCE: {
break;
}
case I_DATA: {
- Cell ddecl = unap(I_DATA,decl);
- finishGHCDataDecl ( zsel35(ddecl) );
+ Cell ddecl = unap(I_DATA,decl);
+ List constrs = finishGHCDataDecl ( zsel35(ddecl) );
+ constructor_list = appendOnto ( constrs, constructor_list );
break;
}
case I_NEWTYPE: {
break;
}
case I_CLASS: {
- Cell klass = unap(I_CLASS,decl);
- finishGHCClass ( zsel35(klass) );
+ Cell klass = unap(I_CLASS,decl);
+ Class cls = finishGHCClass ( zsel35(klass) );
+ cls_list = cons(cls,cls_list);
break;
}
case I_VALUE: {
}
}
}
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\n+++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++++\n");
+ fprintf(stderr, "+++++++++++++++++++++++++++++++"
+ "++++++++++++++++++++++++++\n");
+# endif
- 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
for (xs = ifaces; nonNull(xs); xs = tl(xs))
finishGHCModule(hd(xs));
+ mapProc(visitClass,cls_list);
+ mapProc(ifSetClassDefaultsAndDCon,cls_list);
+ mapProc(ifLinkConstrItbl,constructor_list);
+
/* Finished! */
ifaces_outstanding = NIL;
+
+ return didPrelude;
}
* Modules
* ------------------------------------------------------------------------*/
-void startGHCModule_errMsg ( char* msg )
+static void startGHCModule_errMsg ( char* msg )
{
fprintf ( stderr, "object error: %s\n", msg );
}
-void* startGHCModule_clientLookup ( char* sym )
+static void* startGHCModule_clientLookup ( char* sym )
{
+# ifdef DEBUG_IFACE
/* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
+# endif
return lookupObjName ( sym );
}
-ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
+static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
{
ObjectCode* oc
= ocNew ( startGHCModule_errMsg,
ERRMSG(0) "Validation of object file \"%s\" failed", objNm
EEND;
}
- if (!ocGetNames(oc,0||VERBOSE)) {
+ if (!ocGetNames(oc,VERBOSE)) {
ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
EEND;
}
return oc;
}
-Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
{
List xts;
Module m = findModule(mname);
if (isNull(m)) {
m = newModule(mname);
+# ifdef DEBUG_IFACE
fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
textToStr(mname), sizeObj );
+# endif
} else {
if (module(m).fake) {
module(m).fake = FALSE;
*/
-Void finishGHCModule ( Cell root )
+static Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
Cell iface = unap(I_INTERFACE,root);
List t;
ObjectCode* oc;
+# ifdef DEBUG_IFACE
fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
+# endif
if (isNull(mod)) internal("finishExports(1)");
setCurrModule(mod);
q = mkQualId(exmod,ex);
c = findQualNameWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
break;
case CONIDCELL: /* non data tycon */
q = mkQualId(exmod,ex);
c = findQualTyconWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
- module(mod).exports = cons(c, module(mod).exports);
+# endif
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
break;
case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
c = findQualTyconWithoutConsultingExportList ( q );
if (nonNull(c)) { /* data */
- fprintf(stderr, " data/newtype %s = { ", textToStr(textOf(ex)) );
+# ifdef DEBUG_IFACE
+ fprintf(stderr, " data/newtype %s = { ",
+ textToStr(textOf(ex)) );
+# endif
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
original (defining) module.
*/
if (abstract) {
- module(mod).exports = cons ( ex, module(mod).exports );
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
+# ifdef DEBUG_IFACE
fprintf ( stderr, "(abstract) ");
+# endif
} else {
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addTycon(c);
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 );
+# ifdef DEBUG_IFACE
fprintf(stderr, "%s ", textToStr(name(c).text));
+# endif
assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
}
}
+# ifdef DEBUG_IFACE
fprintf(stderr, "}\n" );
+# endif
} else { /* class */
q = mkQualId(exmod,ex);
c = findQualClassWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addClass(c);
for (; nonNull(subents); subents = tl(subents)) {
Cell ent2 = hd(subents);
assert(isVar(ent2));
q = mkQualId(exmod,ent2);
c = findQualNameWithoutConsultingExportList ( q );
+# ifdef DEBUG_IFACE
fprintf(stderr, "%s ", textToStr(name(c).text));
+# endif
if (isNull(c)) goto notfound;
- module(mod).exports = cons(c, module(mod).exports);
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
}
+# ifdef DEBUG_IFACE
fprintf(stderr, "}\n" );
+# endif
}
break;
notfound:
/* q holds what ain't found */
assert(whatIs(q)==QUALIDENT);
+# ifdef DEBUG_IFACE
fprintf( stderr, " ------ IGNORED: %s.%s\n",
textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
+# endif
continue;
}
}
+#if 0
if (preludeLoaded) {
/* do the implicit 'import Prelude' thing */
List pxs = module(modulePrelude).exports;
}
}
}
+#endif
/* Last, but by no means least ... */
- if (!ocResolve(module(mod).object,0||VERBOSE))
+ if (!ocResolve(module(mod).object,VERBOSE))
internal("finishGHCModule: object resolution failed");
for (oc=module(mod).objectExtras; oc; oc=oc->next) {
- if (!ocResolve(oc, 0||VERBOSE))
+ if (!ocResolve(oc, VERBOSE))
internal("finishGHCModule: extra object resolution failed");
}
}
* Exports
* ------------------------------------------------------------------------*/
-Void startGHCExports ( ConId mn, List exlist )
+static Void startGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("startGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCExports ( ConId mn, List exlist )
+static Void finishGHCExports ( ConId mn, List exlist )
{
# ifdef DEBUG_IFACE
- printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
* Imports
* ------------------------------------------------------------------------*/
-Void startGHCImports ( ConId mn, List syms )
+static Void startGHCImports ( ConId mn, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("startGHCImports %s\n", textToStr(textOf(mn)) );
+ fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
# endif
/* Nothing to do. */
}
-Void finishGHCImports ( ConId nm, List syms )
+static Void finishGHCImports ( ConId nm, List syms )
/* nm the module to import from */
/* syms [ConId | VarId] -- the names to import */
{
# ifdef DEBUG_IFACE
- printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
+ fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
# endif
/* Nothing to do. */
}
/* --------------------------------------------------------------------------
+ * Fixity decls
+ * ------------------------------------------------------------------------*/
+
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
+{
+ Int p = intOf(prec);
+ Int a = intOf(assoc);
+ Name n = findName(textOf(name));
+ assert (nonNull(n));
+ name(n).syntax = mkSyntax ( a, p );
+}
+
+
+/* --------------------------------------------------------------------------
* Vars (values)
* ------------------------------------------------------------------------*/
-void startGHCValue ( Int line, VarId vid, Type ty )
+/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
+ { C1 a } -> { C2 b } -> T into
+ ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
+*/
+static Type dictapsToQualtype ( Type ty )
+{
+ List pieces = NIL;
+ List preds, dictaps;
+
+ /* break ty into pieces at the top-level arrows */
+ while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
+ pieces = cons ( arg(fun(ty)), pieces );
+ ty = arg(ty);
+ }
+ pieces = cons ( ty, pieces );
+ pieces = reverse ( pieces );
+
+ dictaps = NIL;
+ while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
+ dictaps = cons ( hd(pieces), dictaps );
+ pieces = tl(pieces);
+ }
+
+ /* dictaps holds the predicates, backwards */
+ /* pieces holds the remainder of the type, forwards */
+ assert(nonNull(pieces));
+ pieces = reverse(pieces);
+ ty = hd(pieces);
+ pieces = tl(pieces);
+ for (; nonNull(pieces); pieces=tl(pieces))
+ ty = fn(hd(pieces),ty);
+
+ preds = NIL;
+ for (; nonNull(dictaps); dictaps=tl(dictaps)) {
+ Cell da = hd(dictaps);
+ QualId cl = fst(unap(DICTAP,da));
+ Cell arg = snd(unap(DICTAP,da));
+ preds = cons ( pair(cl,arg), preds );
+ }
+
+ if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
+ return ty;
+}
+
+
+
+static void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
List tmp, tvs;
Text v = textOf(vid);
# ifdef DEBUG_IFACE
- printf("begin startGHCValue %s\n", textToStr(v));
+ fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
# endif
+ line = intOf(line);
n = findName(v);
- if (nonNull(n)) {
- ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
+ if (nonNull(n) && name(n).defn != PREDEFINED) {
+ ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
EEND;
}
- n = newName(v,NIL);
+ if (isNull(n)) n = newName(v,NIL);
+
+ ty = dictapsToQualtype(ty);
tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
name(n).type = ty;
name(n).arity = arityInclDictParams(ty);
name(n).line = line;
+ name(n).defn = NIL;
}
-void finishGHCValue ( VarId vid )
+static void finishGHCValue ( VarId vid )
{
Name n = findName ( textOf(vid) );
Int line = name(n).line;
# endif
assert(currentModule == name(n).mod);
name(n).type = conidcellsToTycons(line,name(n).type);
+
+ if (isIfaceDefaultMethodName(name(n).text)) {
+ /* ... we need to set .parent to point to the class
+ ... once we figure out what the class actually is :-)
+ */
+ Type t = name(n).type;
+ assert(isPolyType(t));
+ if (isPolyType(t)) t = monotypeOf(t);
+ assert(isQualType(t));
+ t = fst(snd(t)); /* t :: [(Class,Offset)] */
+ assert(nonNull(t));
+ assert(nonNull(hd(t)));
+ assert(isPair(hd(t)));
+ t = fst(hd(t)); /* t :: Class */
+ assert(isClass(t));
+
+ name(n).parent = t; /* phew! */
+ }
}
* Type synonyms
* ------------------------------------------------------------------------*/
-Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
+static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
{
/* tycon :: ConId */
/* tvs :: [((VarId,Kind))] */
# ifdef DEBUG_IFACE
fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
# endif
+ line = intOf(line);
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
* Data declarations
* ------------------------------------------------------------------------*/
-Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
+static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
Int line;
List ctx0; /* [((QConId,VarId))] */
Cell tycon; /* ConId */
fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
# endif
+ line = intOf(line);
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
/* make resTy the result type of the constr, T v1 ... vn */
resTy = tycon;
for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,fst(hd(tmp)));
+ resTy = ap(resTy,zfst(hd(tmp)));
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
}
-static Void finishGHCDataDecl ( ConId tyc )
+static List finishGHCDataDecl ( ConId tyc )
{
List nms;
Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
+ fprintf ( stderr, "begin finishGHCDataDecl %s\n",
+ textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCDataDecl");
Name n = hd(nms);
Int line = name(n).line;
assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).type = conidcellsToTycons(line,name(n).type);
+ name(n).parent = tc; //---????
}
+
+ return tycon(tc).defn;
}
* Newtype decls
* ------------------------------------------------------------------------*/
-Void startGHCNewType ( Int line, List ctx0,
- ConId tycon, List tvs, Cell constr )
+static Void startGHCNewType ( Int line, List ctx0,
+ ConId tycon, List tvs, Cell constr )
{
/* ctx0 :: [((QConId,VarId))] */
/* tycon :: ConId */
# ifdef DEBUG_IFACE
fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
# endif
+
+ line = intOf(line);
+
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
{
Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
+ fprintf ( stderr, "begin finishGHCNewType %s\n",
+ textToStr(textOf(tyc)) );
# endif
if (isNull(tc)) internal("finishGHCNewType");
* Class declarations
* ------------------------------------------------------------------------*/
-Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
+static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
Int line;
List ctxt; /* [((QConId, VarId))] */
ConId tc_name; /* ConId */
List mems; /* [((VarId, Type))] */
List tvsInT; /* [VarId] and then [((VarId,Kind))] */
List tvs; /* [((VarId,Kind))] */
+ List ns; /* [Name] */
+ Int mno;
ZPair kinded_tv = hd(kinded_tvs);
Text ct = textOf(tc_name);
Pair newCtx = pair(tc_name, zfst(kinded_tv));
# ifdef DEBUG_IFACE
- printf ( "begin startGHCClass %s\n", textToStr(ct) );
+ fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
# endif
+ line = intOf(line);
if (length(kinded_tvs) != 1) {
ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
EEND;
cclass(nw).line = line;
cclass(nw).arity = 1;
cclass(nw).head = ap(nw,mkOffset(0));
- cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
- cclass(nw).instances = NIL; /* what the kind should be */
+ cclass(nw).kinds = singleton( zsnd(kinded_tv) );
+ cclass(nw).instances = NIL;
cclass(nw).numSupers = length(ctxt);
/* Kludge to map the single tyvar in the context to Offset 0.
Need to do something better for multiparam type classes.
-
- cclass(nw).supers = tvsToOffsets(line,ctxt,
- singleton(pair(tv,STAR)));
*/
cclass(nw).supers = tvsToOffsets(line,ctxt,
singleton(kinded_tv));
Name mn;
/* Stick the new context on the member type */
+ memT = dictapsToQualtype(memT);
if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
if (whatIs(memT)==QUAL) {
memT = pair(QUAL,
tvsInT = ifTyvarsIn(memT);
/* tvsInT :: [VarId] */
- /* ToDo: maximally bogus */
- for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
- hd(tvs) = zpair(hd(tvs),STAR);
- /* tvsIntT :: [((VarId,STAR))] */
+ /* ToDo: maximally bogus. We allow the class tyvar to
+ have the kind as supplied by the parser, but we just
+ assume that all others have kind *. It's a kludge.
+ */
+ for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
+ Kind k;
+ if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
+ k = zsnd(kinded_tv); else
+ k = STAR;
+ hd(tvs) = zpair(hd(tvs),k);
+ }
+ /* tvsIntT :: [((VarId,Kind))] */
memT = mkPolyType(tvsToKind(tvsInT),memT);
memT = tvsToOffsets(line,memT,tvsInT);
cclass(nw).members = mems0;
cclass(nw).numMembers = length(mems0);
- /* (ADR) ToDo:
- * cclass(nw).dsels = ?;
- * cclass(nw).dbuild = ?;
- * cclass(nm).dcon = ?;
- * cclass(nm).defaults = ?;
- */
+ ns = NIL;
+ for (mno=0; mno<cclass(nw).numSupers; mno++) {
+ ns = cons(newDSel(nw,mno),ns);
+ }
+ cclass(nw).dsels = rev(ns);
}
}
-static Void finishGHCClass ( Tycon cls_tyc )
+static Class finishGHCClass ( Tycon cls_tyc )
{
List mems;
Int line;
Int ctr;
Class nw = findClass ( textOf(cls_tyc) );
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
+ fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
# endif
if (isNull(nw)) internal("finishGHCClass");
line = cclass(nw).line;
- ctr = - length(cclass(nw).members);
+ ctr = -2;
assert (currentModule == cclass(nw).mod);
- cclass(nw).level = 0; /* (ADR) ToDo: 1 + max (map level supers) */
+ cclass(nw).level = 0;
cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
Type ty = snd(mem);
Name n = findName(txt);
assert(nonNull(n));
+ name(n).text = txt;
name(n).line = cclass(nw).line;
name(n).type = ty;
- name(n).number = ctr++;
+ name(n).number = ctr--;
+ name(n).arity = arityInclDictParams(name(n).type);
+ name(n).parent = nw;
hd(mems) = n;
}
+
+ return nw;
}
* Instances
* ------------------------------------------------------------------------*/
-Inst startGHCInstance (line,ktyvars,cls,var)
+static Inst startGHCInstance (line,ktyvars,cls,var)
Int line;
List ktyvars; /* [((VarId,Kind))] */
Type cls; /* Type */
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "begin startGHCInstance\n" );
+ fprintf ( stderr, "begin startGHCInstance\n" );
# endif
+ line = intOf(line);
+
tvs = ifTyvarsIn(cls); /* :: [VarId] */
/* tvs :: [VarId].
The order of tvs is important for tvsToOffsets.
inst(in).c = cl;
}
-#if 0
- Is this still needed?
{
- Name b = newName(inventText(),NIL);
+ Name b = newName( /*inventText()*/ textOf(var),NIL);
name(b).line = line;
- name(b).arity = length(ctxt); /* unused? */
+ name(b).arity = length(spec); /* unused? */ /* and surely wrong */
name(b).number = DFUNNAME;
+ name(b).parent = in;
inst(in).builder = b;
- bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
}
-#endif
+
return in;
}
Type cls;
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCInstance\n" );
+ fprintf ( stderr, "begin finishGHCInstance\n" );
# endif
assert (nonNull(in));
case QUAL:
return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
conidcellsToTycons(line,snd(snd(type)))));
- case DICTAP: /* :: ap(DICTAP, pair(Class,[Type]))
+ case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
Not sure if this is really the right place to
convert it to the form Hugs wants, but will do so anyway.
*/
{
Class cl = fst(unap(DICTAP,type));
List args = snd(unap(DICTAP,type));
- if (length(args) != 1)
- internal("conidcellsToTycons: DICTAP: multiparam ap");
return
- conidcellsToTycons(line,pair(cl,hd(args)));
+ conidcellsToTycons(line,pair(cl,args));
}
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
case QUALIDENT:
if (isNull(qualidIsMember(type,aktys))) goto missing;
return TRUE;
+ case TYCON:
+ return TRUE;
default:
fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
return TRUE; /*notreached*/
}
missing:
- printf ( "allTypesKnown: unknown " ); print(type,10); printf("\n");
+# ifdef DEBUG_IFACE
+ fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
+ fprintf(stderr,"\n");
+# endif
return FALSE;
}
* General object symbol query stuff
* ------------------------------------------------------------------------*/
-#define EXTERN_SYMS \
+#define EXTERN_SYMS_ALLPLATFORMS \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
Sym(stg_gc_d1) \
+ Sym(stg_gc_f1) \
Sym(stg_chk_0) \
Sym(stg_chk_1) \
Sym(stg_gen_chk) \
Sym(__ap_4_upd_info) \
Sym(__ap_5_upd_info) \
Sym(__ap_6_upd_info) \
+ Sym(__ap_7_upd_info) \
+ Sym(__ap_8_upd_info) \
Sym(__sel_0_upd_info) \
Sym(__sel_1_upd_info) \
Sym(__sel_2_upd_info) \
Sym(waitReadzh_fast) \
Sym(waitWritezh_fast) \
Sym(CHARLIKE_closure) \
+ Sym(INTLIKE_closure) \
Sym(suspendThread) \
Sym(resumeThread) \
Sym(stackOverflow) \
Sym(__int_encodeDouble) \
Sym(mpz_cmp_si) \
Sym(mpz_cmp) \
+ Sym(__mpn_gcd_1) \
+ Sym(gcdIntegerzh_fast) \
Sym(newArrayzh_fast) \
Sym(unsafeThawArrayzh_fast) \
Sym(newDoubleArrayzh_fast) \
Sym(newCharArrayzh_fast) \
Sym(newMutVarzh_fast) \
Sym(quotRemIntegerzh_fast) \
+ Sym(quotIntegerzh_fast) \
+ Sym(remIntegerzh_fast) \
+ Sym(divExactIntegerzh_fast) \
Sym(divModIntegerzh_fast) \
Sym(timesIntegerzh_fast) \
Sym(minusIntegerzh_fast) \
Sym(prog_argv) \
Sym(prog_argc) \
Sym(resetNonBlockingFd) \
+ Sym(getStablePtr) \
+ Sym(stable_ptr_table) \
+ Sym(createAdjThunk) \
+ Sym(shutdownHaskellAndExit) \
+ Sym(stg_enterStackTop) \
+ Sym(CAF_UNENTERED_entry) \
+ Sym(stg_yield_to_Hugs) \
+ Sym(StgReturn) \
\
/* needed by libHS_cbits */ \
SymX(malloc) \
- Sym(__errno_location) \
SymX(close) \
- Sym(__xstat) \
- Sym(__fxstat) \
- Sym(__lxstat) \
Sym(mkdir) \
SymX(close) \
Sym(opendir) \
SymX(getcwd) \
SymX(free) \
SymX(strcpy) \
- SymX(select) \
Sym(fcntl) \
- SymX(stderr) \
SymX(fprintf) \
SymX(exit) \
Sym(open) \
SymX(chdir) \
Sym(localtime) \
Sym(strftime) \
- SymX(vfork) \
SymX(execl) \
- SymX(_exit) \
Sym(waitpid) \
- Sym(tzname) \
Sym(timezone) \
Sym(mktime) \
Sym(gmtime) \
+ SymX(getenv)
+
+#define EXTERN_SYMS_cygwin32 \
+ SymX(GetCurrentProcess) \
+ SymX(GetProcessTimes) \
+ Sym(__udivdi3) \
+ SymX(bzero) \
+ Sym(select) \
+ SymX(_impure_ptr) \
+ Sym(lstat) \
+ Sym(setmode) \
+ SymX(system) \
+ SymX(sleep) \
+ Sym(__imp__tzname) \
+ Sym(__imp__timezone) \
+ Sym(tzset) \
+ Sym(log) \
+ Sym(exp) \
+ Sym(sqrt) \
+ Sym(sin) \
+ Sym(cos) \
+ Sym(tan) \
+ Sym(asin) \
+ Sym(acos) \
+ Sym(atan) \
+ Sym(sinh) \
+ Sym(cosh) \
+ Sym(tanh) \
+ Sym(pow) \
+ Sym(__errno) \
+ Sym(stat) \
+ Sym(fstat)
+
+#define EXTERN_SYMS_linux \
+ Sym(__errno_location) \
+ Sym(__xstat) \
+ Sym(__fxstat) \
+ Sym(__lxstat) \
+ SymX(select) \
+ SymX(stderr) \
+ SymX(vfork) \
+ SymX(_exit) \
+ Sym(tzname) \
+
+
+
+#if defined(linux_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
+#endif
+
+#if defined(solaris2_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
+#endif
+
+#if defined(cygwin32_TARGET_OS)
+#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
+#endif
+
+
/* entirely bogus claims about types of these symbols */
-#define Sym(vvv) extern int vvv;
-#define SymX(vvv) /* nothing */
-EXTERN_SYMS
+#define Sym(vvv) extern void (vvv);
+#define SymX(vvv) /**/
+EXTERN_SYMS_ALLPLATFORMS
+EXTERN_SYMS_THISPLATFORM
#undef Sym
#undef SymX
-#define Sym(vvv) { #vvv, &vvv },
-#define SymX(vvv) { #vvv, &vvv },
+
+#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ &(vvv) },
+#define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ &(vvv) },
OSym rtsTab[]
= {
- EXTERN_SYMS
+ EXTERN_SYMS_ALLPLATFORMS
+ EXTERN_SYMS_THISPLATFORM
{0,0}
};
#undef Sym
#undef SymX
-void* lookupObjName ( char* nm )
+
+/* A kludge to assist Win32 debugging. */
+char* nameFromStaticOPtr ( void* ptr )
+{
+ int k;
+ for (k = 0; rtsTab[k].nm; k++)
+ if (ptr == rtsTab[k].ad)
+ return rtsTab[k].nm;
+ return NULL;
+}
+
+
+static void* lookupObjName ( char* nm )
{
int k;
char* pp;
Text t;
Module m;
char nm2[200];
+ int first_real_char;
nm2[199] = 0;
strncpy(nm2,nm,200);
/* if not an RTS name, look in the
relevant module's object symbol table
*/
- pp = strchr(nm2, '_');
- if (!pp || !isupper(nm2[0])) goto not_found;
+# if LEADING_UNDERSCORE
+ first_real_char = 1;
+# else
+ first_real_char = 0;
+# endif
+ pp = strchr(nm2+first_real_char, '_');
+ if (!pp || !isupper(nm2[first_real_char])) goto not_found;
*pp = 0;
- t = unZcodeThenFindText(nm2);
+ t = unZcodeThenFindText(nm2+first_real_char);
m = findModule(t);
if (isNull(m)) goto not_found;