X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Finterface.c;h=28562d90e717d40fbef86331a1fad1f5e22def17;hb=68b0b216fd91c61f0397d3f5a5ae7bd2f53065ae;hp=78dbd3c0cfbecaf935c641ae9b5e9f75943aa9fb;hpb=d2ae51efe07db4d7c003ca90a96fa8578c5c8566;p=ghc-hetmet.git diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 78dbd3c..28562d9 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.6 $ - * $Date: 1999/10/29 11:41:04 $ + * $Revision: 1.9 $ + * $Date: 1999/12/03 17:01:21 $ * ------------------------------------------------------------------------*/ /* ToDo: @@ -34,7 +34,8 @@ #include "Assembler.h" /* for wrapping GHC objects */ #include "dynamic.h" -#define DEBUG_IFACE +// #define DEBUG_IFACE +#define VERBOSE FALSE extern void print ( Cell, Int ); @@ -109,7 +110,7 @@ static Type local conidcellsToTycons Args((Int,Type)); static Void local resolveReferencesInObjectModule Args((Module,Bool)); static Bool local validateOImage Args((void*, Int, Bool)); -static Void local readSyms Args((Module)); +static Void local readSyms Args((Module,Bool)); static void* local lookupObjName ( char* ); @@ -364,7 +365,7 @@ Module mod; { } // Last, but by no means least ... - resolveReferencesInObjectModule ( mod, FALSE ); + resolveReferencesInObjectModule ( mod, TRUE ); } Void openGHCIface(t) @@ -375,7 +376,7 @@ Text t; { Module m = findModule(t); if (isNull(m)) { m = newModule(t); -printf ( "new module %s\n", textToStr(t) ); + //printf ( "new module %s\n", textToStr(t) ); } else if (m != modulePrelude) { ERRMSG(0) "Module \"%s\" already loaded", textToStr(t) EEND; @@ -403,7 +404,7 @@ printf ( "new module %s\n", textToStr(t) ); ERRMSG(0) "Read of object file \"%s\" failed", nameObj EEND; } - if (!validateOImage(img,sizeObj,FALSE)) { + if (!validateOImage(img,sizeObj,VERBOSE)) { ERRMSG(0) "Validation of object file \"%s\" failed", nameObj EEND; } @@ -411,7 +412,7 @@ printf ( "new module %s\n", textToStr(t) ); assert(!module(m).oImage); module(m).oImage = img; - readSyms(m); + readSyms(m,VERBOSE); if (!cellIsMember(m, ghcModules)) ghcModules = cons(m, ghcModules); @@ -430,8 +431,8 @@ List syms; { /* [ConId | VarId] -- the names to import */ printf("\naddGHCImport %s\n", textToStr(mn) ); # endif - // Hack to avoid chasing Prel* junk right now - if (strncmp(textToStr(mn), "Prel",4)==0) return; + /* Don't chase PrelGHC -- it doesn't exist */ + if (strncmp(textToStr(mn), "PrelGHC",7)==0) return; found = FALSE; for (t=ifImports; nonNull(t); t=tl(t)) { @@ -551,9 +552,10 @@ Int line; List ctx0; /* [(QConId,VarId)] */ Cell tycon; /* ConId */ List ktyvars; /* [(VarId,Kind)] */ -List constrs0; /* [(ConId,[(Type,Text)],NIL)] +List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] The NIL will become the constr's type - The Text is an optional field name */ + The Text is an optional field name + The Int indicates strictness */ /* ToDo: worry about being given a decl for (->) ? * and worry about qualidents for () */ @@ -565,6 +567,7 @@ List constrs0; /* [(ConId,[(Type,Text)],NIL)] Cell conid; Pair conArg, ctxElem; Text conArgNm; + Int conArgStrictness; Text t = textOf(tycon); # ifdef DEBUG_IFACE @@ -606,11 +609,13 @@ List constrs0; /* [(ConId,[(Type,Text)],NIL)] tyvarsMentioned = NIL; /* [VarId] */ conArgs = reverse(fields); for (; nonNull(conArgs); conArgs=tl(conArgs)) { - conArg = hd(conArgs); /* (Type,Text) */ - conArgTy = fst(conArg); - conArgNm = snd(conArg); + conArg = hd(conArgs); /* (Type,Text) */ + conArgTy = fst3(conArg); + conArgNm = snd3(conArg); + conArgStrictness = intOf(thd3(conArg)); tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy), tyvarsMentioned); + if (conArgStrictness > 0) conArgTy = bang(conArgTy); ty = fn(conArgTy,ty); if (nonNull(conArgNm)) { /* a field name is mentioned too */ @@ -662,7 +667,7 @@ List constrs0; /* [(ConId,[(Type,Text)],NIL)] static List local addGHCConstrs(line,cons,sels) Int line; -List cons; /* [(ConId,[(Type,Text)],Type)] */ +List cons; /* [(ConId,[(Type,Text,Int)],Type)] */ List sels; { /* [(VarId,Type)] */ List cs, ss; Int conNo = 0; /* or maybe 1? */ @@ -706,7 +711,7 @@ Pair sel; /* (VarId,Type) */ static Name local addGHCConstr(line,conNo,constr) Int line; Int conNo; -Triple constr; { /* (ConId,[(Type,Text)],Type) */ +Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */ /* ToDo: add rank2 annotation and existential annotation * these affect how constr can be used. */ @@ -815,17 +820,17 @@ Cell constr; { /* (ConId,Type) */ } } -Void addGHCClass(line,ctxt,tc_name,tv,mems0) +Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0) Int line; List ctxt; /* [(QConId, VarId)] */ Cell tc_name; /* ConId */ -Text tv; /* VarId */ +Text kinded_tv; /* (VarId, Kind) */ List mems0; { /* [(VarId, Type)] */ List mems; /* [(VarId, Type)] */ List tvsInT; /* [VarId] and then [(VarId,Kind)] */ List tvs; /* [(VarId,Kind)] */ Text ct = textOf(tc_name); - Pair newCtx = pair(tc_name, tv); + Pair newCtx = pair(tc_name, fst(kinded_tv)); # ifdef DEBUG_IFACE printf ( "\nbegin addGHCclass %s\n", textToStr(ct) ); # endif @@ -849,9 +854,13 @@ List mems0; { /* [(VarId, Type)] */ /* 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)); + for (mems=mems0; nonNull(mems); mems=tl(mems)) { Pair mem = hd(mems); @@ -945,7 +954,7 @@ static Void local finishGHCClass(Class nw) Void addGHCInstance (line,ctxt0,cls,var) Int line; List ctxt0; /* [(QConId, Type)] */ -Pair cls; /* (ConId, [Type]) */ +List cls; /* [(ConId, Type)] */ Text var; { /* Text */ List tmp, tvs, ks; Inst in = newInst(); @@ -954,7 +963,9 @@ Text var; { /* Text */ # endif /* Make tvs into a list of tyvars with bogus kinds. */ - tvs = nubList(ifTyvarsIn(snd(cls))); + //print ( cls, 10 ); printf ( "\n"); + tvs = nubList(ifTyvarsIn(cls)); + //print ( tvs, 10 ); ks = NIL; for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) { hd(tmp) = pair(hd(tmp),STAR); @@ -1041,6 +1052,12 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ case QUAL: return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars), tvsToOffsets(line,snd(snd(type)),ktyvars))); + case DICTAP: /* bogus ?? */ + return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars)); + case UNBOXEDTUP: /* bogus?? */ + return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars)); + case BANG: /* bogus?? */ + return ap(BANG, tvsToOffsets(line,snd(type),ktyvars)); case VARIDCELL: /* Ha! some real work to do! */ { Int i = 0; Text tv = textOf(type); @@ -1063,6 +1080,16 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ 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 @@ -1072,6 +1099,7 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ Tycons or Classes have been loaded into the symbol tables and can be looked up. */ + static Type local conidcellsToTycons(line,type) Int line; Type type; { @@ -1084,7 +1112,7 @@ Type type; { return type; case QUALIDENT: { List t; - Text m = qmodOf(type); + Text m = kludgeGHCPrelText(qmodOf(type)); Text v = qtextOf(type); Module mod = findModule(m); //printf ( "lookup qualident " ); print(type,100); printf("\n"); @@ -1130,6 +1158,10 @@ Type type; { case QUAL: return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))), conidcellsToTycons(line,snd(snd(type))))); + case DICTAP: /* bogus?? */ + return ap(DICTAP, conidcellsToTycons(line, snd(type))); + case UNBOXEDTUP: + return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type))); default: fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n", whatIs(type)); @@ -1248,14 +1280,15 @@ static Void local resolveReferencesInObjectModule_elf ( Module m, { char symbol[1000]; // ToDo int i, j; - Elf32_Sym* stab; + Elf32_Sym* stab = NULL; char* strtab; char* ehdrC = (char*)(module(m).oImage); Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC; Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff); Elf32_Word* targ; // first find "the" symbol table - //stab = findElfSection ( objImage, SHT_SYMTAB ); + // why is this commented out??? + stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB ); // also go find the string table strtab = findElfSection ( ehdrC, SHT_STRTAB ); @@ -1414,7 +1447,8 @@ static Bool local validateOImage_elf ( void* imgV, if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else if (verb) fprintf ( stderr, " " ); - if (sh_strtab && verb) fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name ); + if (sh_strtab && verb) + fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name ); if (verb) fprintf ( stderr, "\n" ); } @@ -1424,7 +1458,8 @@ static Bool local validateOImage_elf ( void* imgV, for (i = 0; i < ehdr->e_shnum; i++) { if (shdr[i].sh_type == SHT_STRTAB && i != ehdr->e_shstrndx) { - if (verb) fprintf ( stderr, " section %d is a normal string table\n", i ); + if (verb) + fprintf ( stderr, " section %d is a normal string table\n", i ); strtab = ehdrC + shdr[i].sh_offset; nstrtab++; } @@ -1490,7 +1525,7 @@ static Bool local validateOImage_elf ( void* imgV, } -static void readSyms_elf ( Module m ) +static void readSyms_elf ( Module m, Bool verb ) { int i, j, k, nent; Elf32_Sym* stab; @@ -1534,7 +1569,8 @@ static void readSyms_elf ( Module m ) ) && ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC || - ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ) + ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT || + ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE) ) { char* nm = strtab + stab[j].st_name; char* ad = ehdrC @@ -1542,11 +1578,12 @@ static void readSyms_elf ( Module m ) + stab[j].st_value; assert(nm); assert(ad); - /* fprintf(stderr, "addOTabName: %s %s %p\n", - textToStr(module(m).text), nm, ad ); - */ + if (verb) + fprintf(stderr, "addOTabName: %10p %s %s\n", + ad, textToStr(module(m).text), nm ); addOTabName ( m, nm, ad ); } + //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name ); } } @@ -1580,10 +1617,10 @@ static Void local resolveReferencesInObjectModule ( Module m, Bool verb ) } -static Void local readSyms ( Module m ) +static Void local readSyms ( Module m, Bool verb ) { #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) - readSyms_elf ( m ); + readSyms_elf ( m, verb ); #else internal("readSyms: not implemented on this platform"); #endif @@ -1602,16 +1639,22 @@ extern int stg_update_PAP; extern int __ap_2_upd_info; extern int MainRegTable; extern int Upd_frame_info; +extern int CAF_BLACKHOLE_info; +extern int IND_STATIC_info; +extern int newCAF; OSym rtsTab[] = { - { "stg_gc_enter_1", &stg_gc_enter_1 }, - { "stg_chk_0", &stg_chk_0 }, - { "stg_chk_1", &stg_chk_1 }, - { "stg_update_PAP", &stg_update_PAP }, - { "__ap_2_upd_info", &__ap_2_upd_info }, - { "MainRegTable", &MainRegTable }, - { "Upd_frame_info", &Upd_frame_info }, + { "stg_gc_enter_1", &stg_gc_enter_1 }, + { "stg_chk_0", &stg_chk_0 }, + { "stg_chk_1", &stg_chk_1 }, + { "stg_update_PAP", &stg_update_PAP }, + { "__ap_2_upd_info", &__ap_2_upd_info }, + { "MainRegTable", &MainRegTable }, + { "Upd_frame_info", &Upd_frame_info }, + { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info }, + { "IND_STATIC_info", &IND_STATIC_info }, + { "newCAF", &newCAF }, {0,0} }; @@ -1638,7 +1681,7 @@ void* lookupObjName ( char* nm ) pp = strchr(nm2, '_'); if (!pp) goto not_found; *pp = 0; - t = findText(nm2); + t = kludgeGHCPrelText( unZcodeThenFindText(nm2) ); m = findModule(t); if (isNull(m)) goto not_found; a = lookupOTabName ( m, nm );