From: sewardj Date: Tue, 8 Feb 2000 15:32:31 +0000 (+0000) Subject: [project @ 2000-02-08 15:32:29 by sewardj] X-Git-Tag: Approximately_9120_patches~5150 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ef37dc2d1bb5be7c864577c89cd26706a4db1b21;p=ghc-hetmet.git [project @ 2000-02-08 15:32:29 by sewardj] Many bug fixes for object loading: -- create class symbol table entries more correctly -- find GHC-created info tables for names which are constructors -- add debugging machinery: :d and symbol-table printers --- diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 76703b2..f442184 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.15 $ - * $Date: 2000/01/12 16:32:41 $ + * $Revision: 1.16 $ + * $Date: 2000/02/08 15:32:29 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -161,7 +161,8 @@ print(e,10);printf("\n"); pushVar(bco,name(e).stgVar); } else { Cell /*CPtr*/ addr = cptrFromName(e); - fprintf ( stderr, "nativeAtom: name %s\n", nameFromOPtr(cptrOf(addr)) ); + fprintf ( stderr, "nativeAtom: name %s\n", + nameFromOPtr(cptrOf(addr)) ); pushVar(bco,addr); } break; @@ -191,7 +192,7 @@ print(e,10);printf("\n"); asmConstAddr(bco,ptrOf(e)); break; default: - fprintf(stderr,"\nYoiks: "); printExp(stderr,e); + fprintf(stderr,"\nYoiks1: "); printExp(stderr,e); internal("pushAtom"); } } @@ -453,7 +454,7 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) break; } default: - fprintf(stderr,"\nYoiks: "); printExp(stderr,e); + fprintf(stderr,"\nYoiks2: "); printExp(stderr,e); internal("cgExpr"); } } @@ -470,6 +471,9 @@ static Void alloc( AsmBCO bco, StgVar v ) { StgRhs rhs = stgVarBody(v); assert(isStgVar(v)); +#if 0 + printf("alloc: ");ppStgExpr(v); +#endif switch (whatIs(rhs)) { case STGCON: { @@ -591,7 +595,10 @@ static Void build( AsmBCO bco, StgVar v ) * of this except "let x = x in ..." */ case NAME: - rhs = name(rhs).stgVar; + if (nonNull(name(rhs).stgVar)) + rhs = name(rhs).stgVar; else + rhs = cptrFromName(rhs); + /* fall thru */ case STGVAR: { AsmSp start = asmBeginMkAP(bco); diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 5ee1ae1..93c4b96 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.17 $ - * $Date: 2000/01/13 10:47:05 $ + * $Revision: 1.18 $ + * $Date: 2000/02/08 15:32:29 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -208,6 +208,9 @@ Triple tr; { /* triple of expressions. */ static Void local transAlt(e) /* Translate alt: */ Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */ +#if 0 + printf ( "transAlt: " );print(snd(e),100);printf("\n"); +#endif snd(e) = transRhs(snd(e)); } @@ -1620,6 +1623,9 @@ static Void local compileGenFunction(n) /* Produce code for internally */ Name n; { /* generated function */ List defs = name(n).defn; Int arity = length(fst(hd(defs))); +#if 0 + printf ( "compGenFn: " );print(defs,100);printf("\n"); +#endif compiler(RESET); currentName = n; mapProc(transAlt,defs); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index f15a624..cd1eff5 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.37 $ - * $Date: 2000/02/03 13:55:21 $ + * $Revision: 1.38 $ + * $Date: 2000/02/08 15:32:29 $ * ------------------------------------------------------------------------*/ #include @@ -40,6 +40,8 @@ Bool showInstRes = FALSE; Bool multiInstRes = FALSE; #endif +#define N_PRELUDE_SCRIPTS (combined ? 30 : 1) + /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ @@ -847,7 +849,7 @@ String s; { currProject = s; projInput(currProject); scriptFile = currProject; - forgetScriptsFrom(1); + forgetScriptsFrom(N_PRELUDE_SCRIPTS); while ((s=readFilename())!=0) addStackEntry(s); if (namesUpto<=1) { @@ -1124,7 +1126,7 @@ static Void local load() { /* read filenames from command line */ /* to be read */ while ((s=readFilename())!=0) addStackEntry(s); - readScripts(1); + readScripts(N_PRELUDE_SCRIPTS); } static Void local project() { /* read list of script names from */ @@ -1145,7 +1147,7 @@ static Void local project() { /* read list of script names from */ EEND; } loadProject(s); - readScripts(1); + readScripts(N_PRELUDE_SCRIPTS); } static Void local readScripts(n) /* Reread current list of scripts, */ @@ -1330,11 +1332,11 @@ ToDo: Fix! startNewScript(0); if (nonNull(c=findTycon(t=findText(nm)))) { if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) { - readScripts(1); + readScripts(N_PRELUDE_SCRIPTS); } } else if (nonNull(c=findName(t))) { if (startEdit(name(c).line,scriptName[scriptThisName(c)])) { - readScripts(1); + readScripts(N_PRELUDE_SCRIPTS); } } else { ERRMSG(0) "No current definition for name \"%s\"", nm @@ -1346,7 +1348,7 @@ ToDo: Fix! static Void local runEditor() { /* run editor on script lastEdit */ if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */ - readScripts(1); + readScripts(N_PRELUDE_SCRIPTS); } static Void local setLastEdit(fname,line)/* keep name of last file to edit */ @@ -1624,6 +1626,48 @@ Cell c; { extern Name nameHw; +static Void dumpStg ( void ) +{ + String s; + Int i; + setCurrModule(findEvalModule()); + startNewScript(0); + s = readFilename(); + + /* request to locate a symbol by name */ + if (s && (*s == '?')) { + Text t = findText(s+1); + locateSymbolByName(t); + return; + } + + /* request to dump a bit of the heap */ + if (s && (*s == '-' || isdigit(*s))) { + int i = atoi(s); + print(i,100); + printf("\n"); + return; + } + + /* request to dump a symbol table entry */ + if (!s + || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i') + || !isdigit(s[1])) { + fprintf(stderr, ":d -- bad request `%s'\n", s ); + return; + } + i = atoi(s+1); + switch (*s) { + case 't': dumpTycon(i); break; + case 'n': dumpName(i); break; + case 'c': dumpClass(i); break; + case 'i': dumpInst(i); break; + default: fprintf(stderr, ":d -- `%c' not implemented\n", *s ); + } +} + + +#if 0 static Void local dumpStg( void ) { /* print STG stuff */ String s; Text t; @@ -1671,6 +1715,7 @@ static Void local dumpStg( void ) { /* print STG stuff */ } } } +#endif static Void local info() { /* describe objects */ Int count = 0; /* or give menu of commands */ @@ -1992,14 +2037,14 @@ String argv[]; { case FIND : find(); break; case LOAD : clearProject(); - forgetScriptsFrom(1); + forgetScriptsFrom(N_PRELUDE_SCRIPTS); load(); break; case ALSO : clearProject(); forgetScriptsFrom(numScripts); load(); break; - case RELOAD : readScripts(1); + case RELOAD : readScripts(N_PRELUDE_SCRIPTS); break; case PROJECT: project(); break; diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 00348c4..993e640 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.27 $ - * $Date: 2000/02/04 13:41:00 $ + * $Revision: 1.28 $ + * $Date: 2000/02/08 15:32:30 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -143,7 +143,7 @@ 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 ); @@ -177,7 +177,7 @@ static void* lookupObjName ( char* ); * ------------------------------------------------------------------------*/ /* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */ -ConVarId getIEntityName ( Cell c ) +static ConVarId getIEntityName ( Cell c ) { switch (whatIs(c)) { case I_IMPORT: return NIL; @@ -203,10 +203,10 @@ ConVarId getIEntityName ( Cell c ) 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); @@ -281,14 +281,22 @@ static List getExportDeclsInIFace ( Cell root ) } +/* 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 ); @@ -296,6 +304,11 @@ static Bool isExportedIFaceEntity ( Cell ife, List exlist_list ) 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); @@ -385,7 +398,7 @@ static Cell deleteUnexportedIFaceEntities ( Cell root ) /* 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)); @@ -404,7 +417,7 @@ List addTyconsAndClassesFromIFace ( Cell root, List aktys ) } -Void ifentityAllTypesKnown_dumpmsg ( Cell entity ) +static Void ifentityAllTypesKnown_dumpmsg ( Cell entity ) { ConVarId id = getIEntityName ( entity ); fprintf ( stderr, @@ -412,12 +425,13 @@ Void ifentityAllTypesKnown_dumpmsg ( Cell entity ) 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 ) +static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod ) { List t, u; List aktys = zfst ( aktys_mod ); @@ -483,7 +497,7 @@ Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod ) 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 ); @@ -495,7 +509,8 @@ Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod ) } } -Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity ) + +static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity ) { ConVarId id = getIEntityName ( entity ); assert (whatIs(entity)==I_TYPE); @@ -508,7 +523,7 @@ Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity ) /* 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); @@ -526,7 +541,7 @@ List abstractifyExDecl ( Cell root, ConId toabs ) } -Void ppModule ( Text modt ) +static Void ppModule ( Text modt ) { fflush(stderr); fflush(stdout); fprintf(stderr, "---------------- MODULE %s ----------------\n", @@ -534,6 +549,115 @@ Void ppModule ( Text modt ) } +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, "%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) fprintf(stderr, "FOUND `%s'\n",textToStr(t)); + if (p) return p; + + if (name(n).arity == 0) { + sprintf ( buf, "%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) fprintf(stderr, "FOUND `%s'\n",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. Otherwise, find its info table + in the object code. + */ + if (!islower(textToStr(name(n).text)[0])) + 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. @@ -554,7 +678,8 @@ Bool processInterfaces ( void ) List all_known_types; Int num_known_types; Bool didPrelude; - List cls_list; + List cls_list; /* :: List Class */ + List constructor_list; /* :: List Name */ List ifaces = NIL; /* :: List I_INTERFACE */ List iface_sizes = NIL; /* :: List Int */ @@ -845,8 +970,9 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) calling the finishGHC* functions. But don't process the export lists; those must wait for later. */ - didPrelude = FALSE; - cls_list = NIL; + 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)); @@ -880,8 +1006,9 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) 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: { @@ -917,6 +1044,8 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) finishGHCModule(hd(xs)); mapProc(visitClass,cls_list); + mapProc(ifSetClassDefaultsAndDCon,cls_list); + mapProc(ifLinkConstrItbl,constructor_list); /* Finished! */ ifaces_outstanding = NIL; @@ -929,18 +1058,18 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent) * 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 ) { /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */ 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, @@ -966,7 +1095,7 @@ ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz ) 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); @@ -1032,7 +1161,7 @@ Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) */ -Void finishGHCModule ( Cell root ) +static Void finishGHCModule ( Cell root ) { /* root :: I_INTERFACE */ Cell iface = unap(I_INTERFACE,root); @@ -1199,7 +1328,7 @@ Void finishGHCModule ( Cell root ) * Exports * ------------------------------------------------------------------------*/ -Void startGHCExports ( ConId mn, List exlist ) +static Void startGHCExports ( ConId mn, List exlist ) { # ifdef DEBUG_IFACE printf("startGHCExports %s\n", textToStr(textOf(mn)) ); @@ -1207,7 +1336,7 @@ Void startGHCExports ( ConId mn, List exlist ) /* 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)) ); @@ -1220,7 +1349,7 @@ Void finishGHCExports ( ConId mn, List exlist ) * 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 */ { @@ -1231,7 +1360,7 @@ Void startGHCImports ( ConId mn, List syms ) } -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 */ { @@ -1292,7 +1421,7 @@ static Type dictapsToQualtype ( Type ty ) -void startGHCValue ( Int line, VarId vid, Type ty ) +static void startGHCValue ( Int line, VarId vid, Type ty ) { Name n; List tmp, tvs; @@ -1302,12 +1431,13 @@ void startGHCValue ( Int line, VarId vid, Type ty ) printf("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); @@ -1321,10 +1451,11 @@ void startGHCValue ( Int line, VarId vid, Type ty ) 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; @@ -1333,6 +1464,24 @@ void finishGHCValue ( VarId vid ) # 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! */ + } } @@ -1340,7 +1489,7 @@ void finishGHCValue ( VarId vid ) * 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))] */ @@ -1349,6 +1498,7 @@ Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty ) # 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) @@ -1390,7 +1540,7 @@ static Void finishGHCSynonym ( ConId tyc ) * 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 */ @@ -1416,6 +1566,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ 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) @@ -1575,7 +1726,7 @@ static Name startGHCConstr ( Int line, Int conNo, ZTriple constr ) } -static Void finishGHCDataDecl ( ConId tyc ) +static List finishGHCDataDecl ( ConId tyc ) { List nms; Tycon tc = findTycon(textOf(tyc)); @@ -1588,8 +1739,11 @@ static Void finishGHCDataDecl ( ConId tyc ) 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; } @@ -1597,8 +1751,8 @@ static Void finishGHCDataDecl ( ConId tyc ) * 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 */ @@ -1610,6 +1764,9 @@ Void startGHCNewType ( Int line, List ctx0, # 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) @@ -1684,7 +1841,7 @@ static Void finishGHCNewType ( ConId tyc ) * 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 */ @@ -1704,6 +1861,7 @@ List mems0; { /* [((VarId, Type))] */ printf ( "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; @@ -1723,10 +1881,12 @@ List mems0; { /* [((VarId, Type))] */ 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. @@ -1814,7 +1974,7 @@ static Class finishGHCClass ( Tycon cls_tyc ) ctr = - length(cclass(nw).members); 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); @@ -1825,10 +1985,13 @@ static Class finishGHCClass ( Tycon cls_tyc ) Type ty = snd(mem); Name n = findName(txt); assert(nonNull(n)); + name(n).text = txt; +fprintf(stderr, "TEXT IS `%s'\n", textToStr(name(n).text)); name(n).line = cclass(nw).line; name(n).type = ty; name(n).number = ctr++; name(n).arity = arityInclDictParams(name(n).type); + name(n).parent = nw; hd(mems) = n; } @@ -1840,7 +2003,7 @@ static Class finishGHCClass ( Tycon cls_tyc ) * Instances * ------------------------------------------------------------------------*/ -Inst startGHCInstance (line,ktyvars,cls,var) +static Inst startGHCInstance (line,ktyvars,cls,var) Int line; List ktyvars; /* [((VarId,Kind))] */ Type cls; /* Type */ @@ -1855,6 +2018,8 @@ VarId var; { /* VarId */ printf ( "begin startGHCInstance\n" ); # endif + line = intOf(line); + tvs = ifTyvarsIn(cls); /* :: [VarId] */ /* tvs :: [VarId]. The order of tvs is important for tvsToOffsets. @@ -1898,9 +2063,11 @@ VarId var; { /* VarId */ { Name b = newName( /*inventText()*/ textOf(var),NIL); +fprintf(stderr, "DICTIONARY NAME `%s'\n", textToStr(textOf(var)) ); name(b).line = line; 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)); */ } @@ -2407,7 +2574,7 @@ OSym rtsTab[] #undef Sym #undef SymX -void* lookupObjName ( char* nm ) +static void* lookupObjName ( char* nm ) { int k; char* pp; diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index a048123..2f61590 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -112,7 +112,7 @@ module Prelude ( -- This lot really shouldn't be exported, but are needed to -- implement various libs. - ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray + ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar @@ -632,7 +632,7 @@ instance Ord a => Ord [a] where compare [] (_:_) = LT compare [] [] = EQ compare (_:_) [] = GT - compare (x:xs) (y:ys) = primCompAux x y (compare xs ys) + compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys) instance Functor [] where fmap = map @@ -1545,8 +1545,8 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, -- Hooks for primitives: ----------------------------------------------------- -- Do not mess with these! -primCompAux :: Ord a => a -> a -> Ordering -> Ordering -primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT +hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering +hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT hugsprimEqChar :: Char -> Char -> Bool hugsprimEqChar c1 c2 = primEqChar c1 c2 diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index b1a3274..bb42e1c 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.39 $ - * $Date: 2000/02/03 13:55:21 $ + * $Revision: 1.40 $ + * $Date: 2000/02/08 15:32:30 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -525,16 +525,13 @@ Int what; { nameUnpackString = linkName("hugsprimUnpackString"); namePMFail = linkName("hugsprimPmFail"); - +assert(nonNull(namePMFail)); #define xyzzy(aaa,bbb) aaa = linkName(bbb) /* pmc */ xyzzy(nameSel, "_SEL"); - /* newtype and USE_NEWTYPE_FOR_DICTS */ - xyzzy(nameId, "id"); - /* strict constructors */ xyzzy(nameFlip, "flip" ); @@ -553,20 +550,26 @@ Int what; { xyzzy(nameLex, "lex"); xyzzy(nameComp, "."); xyzzy(nameAnd, "&&"); - xyzzy(nameCompAux, "primCompAux"); + xyzzy(nameCompAux, "hugsprimCompAux"); xyzzy(nameMap, "map"); /* implementTagToCon */ - xyzzy(nameError, "error"); + xyzzy(nameError, "hugsprimError"); typeStable = linkTycon("Stable"); typeRef = linkTycon("IORef"); // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ? + + ifLinkConstrItbl ( nameFalse ); + ifLinkConstrItbl ( nameTrue ); + ifLinkConstrItbl ( nameNil ); + ifLinkConstrItbl ( nameCons ); break; } case PREPREL : if (combined) { + Module modulePrelBase; modulePrelude = findFakeModule(textPrelude); module(modulePrelude).objectExtraNames @@ -603,6 +606,16 @@ Int what; { pFun(nameInd, "_indirect"); name(nameInd).number = DFUNNAME; + /* newtype and USE_NEWTYPE_FOR_DICTS */ + /* make a name entry for PrelBase.id _before_ loading Prelude + since ifSetClassDefaultsAndDCon() may need to refer to + nameId. + */ + modulePrelBase = findModule(findText("PrelBase")); + setCurrModule(modulePrelBase); + pFun(nameId, "id"); + setCurrModule(modulePrelude); + } else { modulePrelude = newModule(textPrelude); @@ -645,7 +658,7 @@ Int what; { pFun(nameLex, "lex"); pFun(nameComp, "."); pFun(nameAnd, "&&"); - pFun(nameCompAux, "primCompAux"); + pFun(nameCompAux, "hugsprimCompAux"); pFun(nameMap, "map"); /* implementTagToCon */ diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 783a669..fd465e4 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.21 $ - * $Date: 2000/01/05 18:05:34 $ + * $Revision: 1.22 $ + * $Date: 2000/02/08 15:32:30 $ * ------------------------------------------------------------------------*/ %{ @@ -380,7 +380,7 @@ ifKindedTyvar /* ((VarId,Kind)) */ | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); } ; ifKind : ifAKind { $$ = gc1($1); } - | ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); } + | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); } ; ifAKind : VAROP { $$ = gc1(STAR); } /* should be '*' */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 3443061..193613e 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.40 $ - * $Date: 2000/01/12 14:52:53 $ + * $Revision: 1.41 $ + * $Date: 2000/02/08 15:32:30 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -871,6 +871,7 @@ Tycon addWiredInEnumTycon ( String modNm, String typeNm, Name con = newName(conT,t); name(con).number = cfunNo(i); name(con).type = t; + name(con).parent = t; tycon(t).defn = cons(con, tycon(t).defn); } return t; @@ -1300,6 +1301,21 @@ List getAllKnownTyconsAndClasses ( void ) return xs; } +/* Purely for debugging. */ +void locateSymbolByName ( Text t ) +{ + Int i; + for (i = NAMEMIN; i < nameHw; i++) + if (name(i).text == t) + fprintf ( stderr, "name(%d)\n", i-NAMEMIN); + for (i = TYCMIN; i < tyconHw; i++) + if (tycon(i).text == t) + fprintf ( stderr, "tycon(%d)\n", i-TYCMIN); + for (i = CLASSMIN; i < classHw; i++) + if (cclass(i).text == t) + fprintf ( stderr, "class(%d)\n", i-CLASSMIN); +} + /* -------------------------------------------------------------------------- * Control stack: * @@ -1496,7 +1512,9 @@ char* nameFromOPtr ( void* p ) void* lookupOTabName ( Module m, char* sym ) { - return ocLookupSym ( module(m).object, sym ); + if (module(m).object) + return ocLookupSym ( module(m).object, sym ); + return NULL; } @@ -2411,8 +2429,7 @@ Cell c; { Int intOf(c) /* find integer value of cell? */ Cell c; { - if (!isInt(c)) { - assert(isInt(c)); } + assert(isInt(c)); return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO); } @@ -2906,6 +2923,132 @@ List args; { return f; } +/* -------------------------------------------------------------------------- + * debugging support + * ------------------------------------------------------------------------*/ + +static String maybeModuleStr ( Module m ) +{ + if (isModule(m)) return textToStr(module(m).text); else return "??"; +} + +static String maybeNameStr ( Name n ) +{ + if (isName(n)) return textToStr(name(n).text); else return "??"; +} + +static String maybeTyconStr ( Tycon t ) +{ + if (isTycon(t)) return textToStr(tycon(t).text); else return "??"; +} + +static String maybeText ( Text t ) +{ + if (isNull(t)) return "(nil)"; + return textToStr(t); +} + +static void print100 ( Int x ) +{ + print ( x, 100); printf("\n"); +} + +void dumpTycon ( Int t ) +{ + if (isTycon(TYCMIN+t) && !isTycon(t)) t += TYCMIN; + if (!isTycon(t)) { + printf ( "dumpTycon %d: not a tycon\n", t); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(tycon(t).text) ); + printf ( " line: %d\n", tycon(t).line ); + printf ( " mod: %d %s\n", tycon(t).mod, + maybeModuleStr(tycon(t).mod)); + printf ( " tuple: %d\n", tycon(t).tuple); + printf ( " arity: %d\n", tycon(t).arity); + printf ( " kind: "); print100(tycon(t).kind); + printf ( " what: %d\n", tycon(t).what); + printf ( " defn: "); print100(tycon(t).defn); + printf ( " cToT: %d %s\n", tycon(t).conToTag, + maybeNameStr(tycon(t).conToTag)); + printf ( " tToC: %d %s\n", tycon(t).tagToCon, + maybeNameStr(tycon(t).tagToCon)); + printf ( " itbl: %p\n", tycon(t).itbl); + printf ( " nextTH: %d %s\n", tycon(t).nextTyconHash, + maybeTyconStr(tycon(t).nextTyconHash)); + printf ( "}\n" ); +} + +void dumpName ( Int n ) +{ + if (isName(NAMEMIN+n) && !isName(n)) n += NAMEMIN; + if (!isName(n)) { + printf ( "dumpName %d: not a name\n", n); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(name(n).text) ); + printf ( " line: %d\n", name(n).line ); + printf ( " mod: %d %s\n", name(n).mod, + maybeModuleStr(name(n).mod)); + printf ( " syntax: %d\n", name(n).syntax ); + printf ( " parent: %d\n", name(n).parent ); + printf ( " arity: %d\n", name(n).arity ); + printf ( " number: %d\n", name(n).number ); + printf ( " type: "); print100(name(n).type); + printf ( " defn: %d\n", name(n).defn ); + printf ( " stgVar: "); print100(name(n).stgVar); + printf ( " cconv: %d\n", name(n).callconv ); + printf ( " primop: %p\n", name(n).primop ); + printf ( " itbl: %p\n", name(n).itbl ); + printf ( " nextNH: %d\n", name(n).nextNameHash ); + printf ( "}\n" ); +} + + +void dumpClass ( Int c ) +{ + if (isClass(CLASSMIN+c) && !isClass(c)) c += CLASSMIN; + if (!isClass(c)) { + printf ( "dumpClass %d: not a class\n", c); + return; + } + printf ( "{\n" ); + printf ( " text: %s\n", textToStr(cclass(c).text) ); + printf ( " line: %d\n", cclass(c).line ); + printf ( " mod: %d %s\n", cclass(c).mod, + maybeModuleStr(cclass(c).mod)); + printf ( " arity: %d\n", cclass(c).arity ); + printf ( " level: %d\n", cclass(c).level ); + printf ( " kinds: "); print100( cclass(c).kinds ); + printf ( " fds: %d\n", cclass(c).fds ); + printf ( " xfds: %d\n", cclass(c).xfds ); + printf ( " head: "); print100( cclass(c).head ); + printf ( " dcon: "); print100( cclass(c).dcon ); + printf ( " supers: "); print100( cclass(c).supers ); + printf ( " #supers: %d\n", cclass(c).numSupers ); + printf ( " dsels: "); print100( cclass(c).dsels ); + printf ( " members: "); print100( cclass(c).members ); + printf ( "#members: %d\n", cclass(c).numMembers ); + printf ( "defaults: "); print100( cclass(c).defaults ); + printf ( " insts: "); print100( cclass(c).instances ); + printf ( "}\n" ); +} + + +void dumpInst ( Int i ) +{ + if (isInst(INSTMIN+i) && !isInst(i)) i += INSTMIN; + if (!isInst(i)) { + printf ( "dumpInst %d: not an instance\n", i); + return; + } + printf ( "{\n" ); +// printf ( " text: %s\n", textToStr(cclass(c)).text) ); + printf ( "}\n" ); +} + /* -------------------------------------------------------------------------- * plugin support diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index a048123..2f61590 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -112,7 +112,7 @@ module Prelude ( -- This lot really shouldn't be exported, but are needed to -- implement various libs. - ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray + ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar @@ -632,7 +632,7 @@ instance Ord a => Ord [a] where compare [] (_:_) = LT compare [] [] = EQ compare (_:_) [] = GT - compare (x:xs) (y:ys) = primCompAux x y (compare xs ys) + compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys) instance Functor [] where fmap = map @@ -1545,8 +1545,8 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, -- Hooks for primitives: ----------------------------------------------------- -- Do not mess with these! -primCompAux :: Ord a => a -> a -> Ordering -> Ordering -primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT +hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering +hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT hugsprimEqChar :: Char -> Char -> Bool hugsprimEqChar c1 c2 = primEqChar c1 c2