* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/12/16 16:42:56 $
+ * $Revision: 1.18 $
+ * $Date: 2000/01/05 19:10:21 $
* ------------------------------------------------------------------------*/
-/* ToDo:
- * o use Z encoding
- * o use vectored CONSTR_entry when appropriate
- * o generate export list
- *
- * Needs GHC changes to generate member selectors,
- * superclass selectors, etc
- * o instance decls
- * o dictionary constructors ?
- *
- * o Get Hugs/GHC to agree on what interface files look like.
- * o figure out how to replace the Hugs Prelude with the GHC Prelude
- */
-
#include "prelude.h"
#include "storage.h"
#include "backend.h"
#include "errors.h"
#include "link.h"
#include "Assembler.h" /* for wrapping GHC objects */
-#include "dynamic.h"
+#include "object.h"
+
#define DEBUG_IFACE
#define VERBOSE FALSE
static Type tvsToOffsets Args((Int,Type,List));
static Type conidcellsToTycons Args((Int,Type));
-static Void resolveReferencesInObjectModule Args((Module,Bool));
-static Bool validateOImage Args((void*, Int, Bool));
-static Void readSyms Args((Module,Bool));
-
static void* lookupObjName ( char* );
List ifaces = NIL; /* :: List I_INTERFACE */
List iface_sizes = NIL; /* :: List Int */
List iface_onames = NIL; /* :: List Text */
-
+#if 0
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);
+#if 0
printf ( "\n============= %d known types =============\n", i );
+#endif
if (num_known_types == i) break;
num_known_types = i;
/* Have we reached a fixed point? */
i = length(all_known_types);
+#if 0
printf ( "\n------------- %d known types -------------\n", i );
+#endif
if (num_known_types == i) break;
num_known_types = i;
}
}
}
+#if 0
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
}
}
}
-
+#if 0
fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
+#endif
/* 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
* Modules
* ------------------------------------------------------------------------*/
-Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+void startGHCModule_errMsg ( char* msg )
{
- FILE* f;
- void* img;
-
- Module m = findModule(mname);
- if (isNull(m)) {
- m = newModule(mname);
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), sizeObj );
- } else {
- if (module(m).fake) {
- module(m).fake = FALSE;
- } else {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
- EEND;
- }
- }
+ fprintf ( stderr, "object error: %s\n", msg );
+}
+
+void* startGHCModule_clientLookup ( char* sym )
+{
+ /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
+ return lookupObjName ( sym );
+}
- img = malloc ( sizeObj );
- if (!img) {
- ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
- textToStr(mname)
+ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
+{
+ ObjectCode* oc
+ = ocNew ( startGHCModule_errMsg,
+ startGHCModule_clientLookup,
+ objNm, objSz );
+
+ if (!oc) {
+ ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
EEND;
}
- f = fopen( textToStr(nameObj), "rb" );
- if (!f) {
- /* Really, this shouldn't happen, since makeStackEntry ensures the
- object is available. Nevertheless ...
- */
- ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
- &(textToStr(nameObj)[0])
+ if (!ocLoadImage(oc,VERBOSE)) {
+ ERRMSG(0) "Reading of object file \"%s\" failed", objNm
EEND;
}
- if (sizeObj != fread ( img, 1, sizeObj, f)) {
- ERRMSG(0) "Read of object file \"%s\" failed", textToStr(nameObj)
+ if (!ocVerifyImage(oc,VERBOSE)) {
+ ERRMSG(0) "Validation of object file \"%s\" failed", objNm
EEND;
}
- if (!validateOImage(img,sizeObj,VERBOSE)) {
- ERRMSG(0) "Validation of object file \"%s\" failed",
- textToStr(nameObj)
+ if (!ocGetNames(oc,0||VERBOSE)) {
+ ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
EEND;
}
-
- assert(!module(m).oImage);
- module(m).oImage = img;
+ return oc;
+}
- readSyms(m,VERBOSE);
+Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+{
+ List xts;
+ Module m = findModule(mname);
+
+ if (isNull(m)) {
+ m = newModule(mname);
+ fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
+ textToStr(mname), sizeObj );
+ } else {
+ if (module(m).fake) {
+ module(m).fake = FALSE;
+ } else {
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
+ EEND;
+ }
+ }
- /* setCurrModule(m); */
+ /* Get hold of the primary object for the module. */
+ module(m).object
+ = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
+
+ /* and any extras ... */
+ for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
+ Int size;
+ ObjectCode* oc;
+ Text xtt = hd(xts);
+ String nm = getExtraObjectInfo ( textToStr(nameObj),
+ textToStr(xtt),
+ &size );
+ if (size == -1) {
+ ERRMSG(0) "Can't find extra object file \"%s\"", nm
+ EEND;
+ }
+ oc = startGHCModule_partial_load ( nm, size );
+ oc->next = module(m).objectExtras;
+ module(m).objectExtras = oc;
+ }
}
Void finishGHCModule ( Cell root )
{
/* root :: I_INTERFACE */
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- Module mod = findModule(textOf(iname));
- List exlist_list = NIL;
- List t;
+ Cell iface = unap(I_INTERFACE,root);
+ ConId iname = zfst(iface);
+ Module mod = findModule(textOf(iname));
+ List exlist_list = NIL;
+ List t;
+ ObjectCode* oc;
fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
if (isNull(c)) goto notfound;
fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
break;
case CONIDCELL: /* non data tycon */
if (isNull(c)) goto notfound;
fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
module(mod).exports = cons(c, module(mod).exports);
+ addTycon(c);
break;
case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
original (defining) module.
*/
if (abstract) {
- module(mod).exports = cons ( ex, module(mod).exports );
+ module(mod).exports = cons(c, module(mod).exports);
+ addTycon(c);
fprintf ( stderr, "(abstract) ");
} 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));
fprintf(stderr, "%s ", textToStr(name(c).text));
assert(nonNull(c));
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
}
}
fprintf(stderr, "}\n" );
if (isNull(c)) goto notfound;
fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
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));
fprintf(stderr, "%s ", textToStr(name(c).text));
if (isNull(c)) goto notfound;
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
}
fprintf(stderr, "}\n" );
}
}
}
+#if 0
if (preludeLoaded) {
/* do the implicit 'import Prelude' thing */
List pxs = module(modulePrelude).exports;
}
}
}
+#endif
/* Last, but by no means least ... */
- resolveReferencesInObjectModule ( mod, VERBOSE );
+ if (!ocResolve(module(mod).object,0||VERBOSE))
+ internal("finishGHCModule: object resolution failed");
+
+ for (oc=module(mod).objectExtras; oc; oc=oc->next) {
+ if (!ocResolve(oc, 0||VERBOSE))
+ internal("finishGHCModule: extra object resolution failed");
+ }
}
* Vars (values)
* ------------------------------------------------------------------------*/
+/* 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;
+}
+
+
+
void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
}
n = newName(v,NIL);
+ /* 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 ))
+ */
+ ty = dictapsToQualtype(ty);
+
tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
hd(tmp) = zpair(hd(tmp),STAR);
/* 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)) {
* Instances
* ------------------------------------------------------------------------*/
-Inst startGHCInstance (line,ctxt0,cls,var)
+Inst startGHCInstance (line,ktyvars,cls,var)
Int line;
-List ctxt0; /* [((QConId, VarId))] */
-Type cls; /* Type */
-VarId var; { /* VarId */
- List tmp, tvs, ks;
+List ktyvars; /* [((VarId,Kind))] */
+Type cls; /* Type */
+VarId var; { /* VarId */
+ List tmp, tvs, ks, spec;
+
+ List xs1, xs2;
+ Kind k;
+
Inst in = newInst();
# ifdef DEBUG_IFACE
printf ( "begin startGHCInstance\n" );
# endif
- /* Make tvs into a list of tyvars with bogus kinds. */
- tvs = ifTyvarsIn(cls);
- /* tvs :: [VarId] */
+ tvs = ifTyvarsIn(cls); /* :: [VarId] */
+ /* tvs :: [VarId].
+ The order of tvs is important for tvsToOffsets.
+ tvs should be a permutation of ktyvars. Fish the tyvar kinds
+ out of ktyvars and attach them to tvs.
+ */
+ for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
+ k = NIL;
+ for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
+ if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
+ k = zsnd(hd(xs2));
+ if (isNull(k)) internal("startGHCInstance: finding kinds");
+ hd(xs1) = zpair(hd(xs1),k);
+ }
- ks = NIL;
- for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
- hd(tmp) = zpair(hd(tmp),STAR);
- ks = cons(STAR,ks);
+ cls = tvsToOffsets(line,cls,tvs);
+ spec = NIL;
+ while (isAp(cls)) {
+ spec = cons(fun(cls),spec);
+ cls = arg(cls);
}
- /* tvs :: [((VarId,STAR))] */
+ spec = reverse(spec);
+
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);
+ inst(in).kinds = simpleKind(length(tvs)); /* do this right */
+ inst(in).specifics = spec;
+ inst(in).numSpecifics = length(spec);
+ inst(in).head = cls;
/* 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 (currentModule==inst(in).mod);
/* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
- since beginGHCInstance couldn't possibly have resolved it to
+ since startGHCInstance couldn't possibly have resolved it to
a Class at that point. We convert it to a Class now.
*/
c = inst(in).c;
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 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.
+ */
+ /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
+ {
+ Class cl = fst(unap(DICTAP,type));
+ List args = snd(unap(DICTAP,type));
+ return
+ conidcellsToTycons(line,pair(cl,args));
+ }
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
case BANG:
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));
}
-/* --------------------------------------------------------------------------
- * ELF specifics
- * ------------------------------------------------------------------------*/
-
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
-
-#include <elf.h>
-
-static char* findElfSection ( void* objImage, Elf32_Word sh_type )
-{
- Int i;
- char* ehdrC = (char*)objImage;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* ptr = NULL;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type &&
- i != ehdr->e_shstrndx) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
-
-static Void resolveReferencesInObjectModule_elf ( Module m,
- Bool verb )
-{
- char symbol[1000]; // ToDo
- int i, j;
- 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
- // why is this commented out???
- stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- // also go find the string table
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (!stab || !strtab)
- internal("resolveReferencesInObjectModule_elf");
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_REL ) {
- Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
- Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
- Int target_shndx = shdr[i].sh_info;
- Int symtab_shndx = shdr[i].sh_link;
- stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
- targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- if (verb)
- fprintf ( stderr,
- "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx );
- for (j = 0; j < nent; j++) {
- Elf32_Addr offset = rtab[j].r_offset;
- Elf32_Word info = rtab[j].r_info;
-
- Elf32_Addr P = ((Elf32_Addr)targ) + offset;
- Elf32_Word* pP = (Elf32_Word*)P;
- Elf32_Addr A = *pP;
- Elf32_Addr S;
-
- if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p) ",
- j, (void*)offset, (void*)info );
- if (!info) {
- if (verb) fprintf ( stderr, " ZERO\n" );
- S = 0;
- } else {
- if (stab[ ELF32_R_SYM(info)].st_name == 0) {
- if (verb) fprintf ( stderr, "(noname) ");
- /* nameless (local) symbol */
- S = (Elf32_Addr)(ehdrC
- + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
- + stab[ELF32_R_SYM(info)].st_value
- );
- strcpy ( symbol, "(noname)");
- } else {
- strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
- if (verb) fprintf ( stderr, "`%s' ", symbol );
- S = (Elf32_Addr)lookupObjName ( symbol );
- }
- if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
- if (!S) {
- fprintf ( stderr, "link failure for `%s'\n",
- strtab+stab[ ELF32_R_SYM(info)].st_name );
- assert(0);
- }
- }
- //fprintf ( stderr, "Reloc: P = %p S = %p A = %p\n\n",
- // (void*)P, (void*)S, (void*)A );
- switch (ELF32_R_TYPE(info)) {
- case R_386_32: *pP = S + A; break;
- case R_386_PC32: *pP = S + A - P; break;
- default: fprintf(stderr,
- "unhandled ELF relocation type %d\n",
- ELF32_R_TYPE(info));
- assert(0);
- }
-
- }
- }
- else
- if (shdr[i].sh_type == SHT_RELA) {
- fprintf ( stderr, "RelA style reloc table -- not yet done" );
- assert(0);
- }
- }
-}
-
-
-static Bool validateOImage_elf ( void* imgV,
- Int size,
- Bool verb )
-{
- Elf32_Shdr* shdr;
- Elf32_Sym* stab;
- int i, j, nent, nstrtab, nsymtabs;
- char* sh_strtab;
- char* strtab;
-
- char* ehdrC = (char*)imgV;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
-
- if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
- ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
- ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
- ehdr->e_ident[EI_MAG3] != ELFMAG3) {
- if (verb) fprintf ( stderr, "Not an ELF header\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is an ELF header\n" );
-
- if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
- if (verb) fprintf ( stderr, "Not 32 bit ELF\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
-
- if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
- if (verb) fprintf ( stderr, "Is little-endian\n" );
- } else
- if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
- if (verb) fprintf ( stderr, "Is big-endian\n" );
- } else {
- if (verb) fprintf ( stderr, "Unknown endiannness\n" );
- return FALSE;
- }
-
- if (ehdr->e_type != ET_REL) {
- if (verb) fprintf ( stderr, "Not a relocatable object (.o) file\n" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
-
- if (verb) fprintf ( stderr, "Architecture is " );
- switch (ehdr->e_machine) {
- case EM_386: if (verb) fprintf ( stderr, "x86\n" ); break;
- case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
- default: if (verb) fprintf ( stderr, "unknown\n" ); return FALSE;
- }
-
- if (verb)
- fprintf ( stderr,
- "\nSection header table: start %d, n_entries %d, ent_size %d\n",
- ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
-
- assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
-
- shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
-
- if (ehdr->e_shstrndx == SHN_UNDEF) {
- if (verb) fprintf ( stderr, "No section header string table\n" );
- sh_strtab = NULL;
- return FALSE;
- } else {
- if (verb) fprintf ( stderr,"Section header string table is section %d\n",
- ehdr->e_shstrndx);
- sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- }
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (verb) fprintf ( stderr, "%2d: ", i );
- if (verb) fprintf ( stderr, "type=%2d ", shdr[i].sh_type );
- if (verb) fprintf ( stderr, "size=%4d ", shdr[i].sh_size );
- if (verb) fprintf ( stderr, "offs=%4d ", shdr[i].sh_offset );
- if (verb) fprintf ( stderr, " (%p .. %p) ",
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
-
- 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 (verb) fprintf ( stderr, "\n" );
- }
-
- if (verb) fprintf ( stderr, "\n\nString tables\n" );
- strtab = NULL;
- nstrtab = 0;
- 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 );
- strtab = ehdrC + shdr[i].sh_offset;
- nstrtab++;
- }
- }
- if (nstrtab != 1) {
- if (verb) fprintf ( stderr, "WARNING: no string tables, or too many\n" );
- return FALSE;
- }
-
- nsymtabs = 0;
- if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
- if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
- nsymtabs++;
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- if (verb) fprintf ( stderr, " number of entries is apparently %d (%d rem)\n",
- nent,
- shdr[i].sh_size % sizeof(Elf32_Sym)
- );
- if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
- if (verb) fprintf ( stderr, "non-integral number of symbol table entries\n");
- return FALSE;
- }
- for (j = 0; j < nent; j++) {
- if (verb) fprintf ( stderr, " %2d ", j );
- if (verb) fprintf ( stderr, " sec=%-5d size=%-3d val=%-5p ",
- (int)stab[j].st_shndx,
- (int)stab[j].st_size,
- (char*)stab[j].st_value );
-
- if (verb) fprintf ( stderr, "type=" );
- switch (ELF32_ST_TYPE(stab[j].st_info)) {
- case STT_NOTYPE: if (verb) fprintf ( stderr, "notype " ); break;
- case STT_OBJECT: if (verb) fprintf ( stderr, "object " ); break;
- case STT_FUNC : if (verb) fprintf ( stderr, "func " ); break;
- case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
- case STT_FILE: if (verb) fprintf ( stderr, "file " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "bind=" );
- switch (ELF32_ST_BIND(stab[j].st_info)) {
- case STB_LOCAL : if (verb) fprintf ( stderr, "local " ); break;
- case STB_GLOBAL: if (verb) fprintf ( stderr, "global" ); break;
- case STB_WEAK : if (verb) fprintf ( stderr, "weak " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
- }
- }
-
- if (nsymtabs == 0) {
- if (verb) fprintf ( stderr, "Didn't find any symbol tables\n" );
- return FALSE;
- }
-
- return TRUE;
-}
-
-
-static void readSyms_elf ( Module m, Bool verb )
-{
- int i, j, k, nent;
- Elf32_Sym* stab;
-
- char* ehdrC = (char*)(module(m).oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
-
- if (!strtab) internal("readSyms_elf");
-
- k = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
-
- /* make a HugsDLSection entry for relevant sections */
- DLSect kind = HUGS_DL_SECTION_OTHER;
- if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_RWDATA;
- if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_DL_SECTION_CODE_OR_RODATA;
- if (kind != HUGS_DL_SECTION_OTHER)
- addDLSect (
- m,
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
- kind
- );
-
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
-
- /* copy stuff into this module's object symbol table */
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- for (j = 0; j < nent; j++) {
- if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
- ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
- )
- &&
- ( 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_NOTYPE)
- ) {
- char* nm = strtab + stab[j].st_name;
- char* ad = ehdrC
- + shdr[ stab[j].st_shndx ].sh_offset
- + stab[j].st_value;
- assert(nm);
- assert(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 );
- }
-
- }
-}
-
-#endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
-
-
-/* --------------------------------------------------------------------------
- * Arch-independent interface to the runtime linker
- * ------------------------------------------------------------------------*/
-
-static Bool validateOImage ( void* img, Int size, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- return
- validateOImage_elf ( img, size, verb );
-#else
- internal("validateOImage: not implemented on this platform");
-#endif
-}
-
-
-static Void resolveReferencesInObjectModule ( Module m, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- resolveReferencesInObjectModule_elf ( m, verb );
-#else
- internal("resolveReferencesInObjectModule: not implemented on this platform");
-#endif
-}
-
-
-static Void readSyms ( Module m, Bool verb )
-{
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- readSyms_elf ( m, verb );
-#else
- internal("readSyms: not implemented on this platform");
-#endif
-}
-
/* --------------------------------------------------------------------------
* General object symbol query stuff
* ------------------------------------------------------------------------*/
-/* entirely bogus claims about types of these symbols */
-extern int stg_gc_enter_1;
-extern int stg_chk_0;
-extern int stg_chk_1;
-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;
+#define EXTERN_SYMS \
+ Sym(stg_gc_enter_1) \
+ Sym(stg_gc_noregs) \
+ Sym(stg_gc_seq_1) \
+ Sym(stg_gc_d1) \
+ Sym(stg_chk_0) \
+ Sym(stg_chk_1) \
+ Sym(stg_gen_chk) \
+ Sym(stg_exit) \
+ Sym(stg_update_PAP) \
+ Sym(stg_error_entry) \
+ Sym(__ap_2_upd_info) \
+ Sym(__ap_3_upd_info) \
+ Sym(__ap_4_upd_info) \
+ Sym(__ap_5_upd_info) \
+ Sym(__ap_6_upd_info) \
+ Sym(__sel_0_upd_info) \
+ Sym(__sel_1_upd_info) \
+ Sym(__sel_2_upd_info) \
+ Sym(__sel_3_upd_info) \
+ Sym(__sel_4_upd_info) \
+ Sym(__sel_5_upd_info) \
+ Sym(__sel_6_upd_info) \
+ Sym(__sel_7_upd_info) \
+ Sym(__sel_8_upd_info) \
+ Sym(__sel_9_upd_info) \
+ Sym(__sel_10_upd_info) \
+ Sym(__sel_11_upd_info) \
+ Sym(__sel_12_upd_info) \
+ Sym(MainRegTable) \
+ Sym(Upd_frame_info) \
+ Sym(seq_frame_info) \
+ Sym(CAF_BLACKHOLE_info) \
+ Sym(IND_STATIC_info) \
+ Sym(EMPTY_MVAR_info) \
+ Sym(MUT_ARR_PTRS_FROZEN_info) \
+ Sym(newCAF) \
+ Sym(putMVarzh_fast) \
+ Sym(newMVarzh_fast) \
+ Sym(takeMVarzh_fast) \
+ Sym(catchzh_fast) \
+ Sym(raisezh_fast) \
+ Sym(delayzh_fast) \
+ Sym(yieldzh_fast) \
+ Sym(killThreadzh_fast) \
+ Sym(waitReadzh_fast) \
+ Sym(waitWritezh_fast) \
+ Sym(CHARLIKE_closure) \
+ Sym(suspendThread) \
+ Sym(resumeThread) \
+ Sym(stackOverflow) \
+ Sym(int2Integerzh_fast) \
+ Sym(stg_gc_unbx_r1) \
+ Sym(ErrorHdrHook) \
+ Sym(makeForeignObjzh_fast) \
+ Sym(__encodeDouble) \
+ Sym(decodeDoublezh_fast) \
+ Sym(isDoubleNaN) \
+ Sym(isDoubleInfinite) \
+ Sym(isDoubleDenormalized) \
+ Sym(isDoubleNegativeZero) \
+ Sym(__encodeFloat) \
+ Sym(decodeFloatzh_fast) \
+ Sym(isFloatNaN) \
+ Sym(isFloatInfinite) \
+ Sym(isFloatDenormalized) \
+ Sym(isFloatNegativeZero) \
+ Sym(__int_encodeFloat) \
+ Sym(__int_encodeDouble) \
+ Sym(mpz_cmp_si) \
+ Sym(mpz_cmp) \
+ Sym(newArrayzh_fast) \
+ Sym(unsafeThawArrayzh_fast) \
+ Sym(newDoubleArrayzh_fast) \
+ Sym(newFloatArrayzh_fast) \
+ Sym(newAddrArrayzh_fast) \
+ Sym(newWordArrayzh_fast) \
+ Sym(newIntArrayzh_fast) \
+ Sym(newCharArrayzh_fast) \
+ Sym(newMutVarzh_fast) \
+ Sym(quotRemIntegerzh_fast) \
+ Sym(divModIntegerzh_fast) \
+ Sym(timesIntegerzh_fast) \
+ Sym(minusIntegerzh_fast) \
+ Sym(plusIntegerzh_fast) \
+ Sym(addr2Integerzh_fast) \
+ Sym(mkWeakzh_fast) \
+ Sym(prog_argv) \
+ Sym(prog_argc) \
+ Sym(resetNonBlockingFd) \
+ \
+ /* needed by libHS_cbits */ \
+ SymX(malloc) \
+ Sym(__errno_location) \
+ SymX(close) \
+ Sym(__xstat) \
+ Sym(__fxstat) \
+ Sym(__lxstat) \
+ Sym(mkdir) \
+ SymX(close) \
+ Sym(opendir) \
+ Sym(closedir) \
+ Sym(readdir) \
+ Sym(tcgetattr) \
+ Sym(tcsetattr) \
+ SymX(isatty) \
+ SymX(read) \
+ SymX(lseek) \
+ SymX(write) \
+ Sym(getrusage) \
+ Sym(gettimeofday) \
+ SymX(realloc) \
+ SymX(getcwd) \
+ SymX(free) \
+ SymX(strcpy) \
+ SymX(select) \
+ Sym(fcntl) \
+ SymX(stderr) \
+ SymX(fprintf) \
+ SymX(exit) \
+ Sym(open) \
+ SymX(unlink) \
+ SymX(memcpy) \
+ SymX(memchr) \
+ SymX(rmdir) \
+ SymX(rename) \
+ SymX(chdir) \
+ Sym(localtime) \
+ Sym(strftime) \
+ SymX(vfork) \
+ SymX(execl) \
+ SymX(_exit) \
+ Sym(waitpid) \
+ Sym(tzname) \
+ Sym(timezone) \
+ Sym(mktime) \
+ Sym(gmtime) \
+
+
+/* AJG Hack */
+#undef EXTERN_SYMS
+#define EXTERN_SYMS
+/* entirely bogus claims about types of these symbols */
+#define Sym(vvv) extern int vvv;
+#define SymX(vvv) /* nothing */
+EXTERN_SYMS
+#undef Sym
+#undef SymX
+
+#define Sym(vvv) { #vvv, &vvv },
+#define SymX(vvv) { #vvv, &vvv },
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 },
- { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info },
- { "IND_STATIC_info", &IND_STATIC_info },
- { "newCAF", &newCAF },
+ EXTERN_SYMS
{0,0}
};
-
+#undef Sym
+#undef SymX
void* lookupObjName ( char* nm )
{
nm2[199] = 0;
strncpy(nm2,nm,200);
- // first see if it's an RTS name
+ /* first see if it's an RTS name */
for (k = 0; rtsTab[k].nm; k++)
if (0==strcmp(nm2,rtsTab[k].nm))
return rtsTab[k].ad;
- // if not an RTS name, look in the
- // relevant module's object symbol table
+ /* perhaps an extra-symbol ? */
+ a = lookupOExtraTabName ( nm );
+ if (a) return a;
+
+ /* if not an RTS name, look in the
+ relevant module's object symbol table
+ */
pp = strchr(nm2, '_');
- if (!pp) goto not_found;
+ if (!pp || !isupper(nm2[0])) goto not_found;
*pp = 0;
t = unZcodeThenFindText(nm2);
m = findModule(t);
if (isNull(m)) goto not_found;
-fprintf(stderr, " %%%% %s\n", nm );
- a = lookupOTabName ( m, nm );
+
+ a = lookupOTabName ( m, nm ); /* RATIONALISE */
if (a) return a;
not_found:
fprintf ( stderr,
"lookupObjName: can't resolve name `%s'\n",
nm );
+assert(4-4);
return NULL;
}
int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_CODE_OR_RODATA;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
}
int is_dynamically_loaded_rwdata_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_RWDATA;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_RWDATA);
}
int is_not_dynamically_loaded_ptr ( char* p )
{
- return
- lookupDLSect(p) == HUGS_DL_SECTION_OTHER;
+ OSectionKind sk = lookupSection(p);
+ assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
+ return (sk == HUGS_SECTIONKIND_OTHER);
}
projects / ghc-hetmet.git / blobdiff