* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.33 $
- * $Date: 2000/03/02 10:10:33 $
+ * $Revision: 1.34 $
+ * $Date: 2000/03/07 16:18:25 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
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);
}
}
+# 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] */
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
}
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
}
static Void ppModule ( Text modt )
{
+# ifdef DEBUG_IFACE
fflush(stderr); fflush(stdout);
fprintf(stderr, "---------------- MODULE %s ----------------\n",
textToStr(modt) );
+# endif
}
char buf[1000];
Text t;
- sprintf ( buf, "%s_%s_con_info",
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
textToStr( module(name(n).mod).text ),
textToStr( name(n).text ) );
t = enZcodeThenFindText(buf);
if (p) return p;
if (name(n).arity == 0) {
- sprintf ( buf, "%s_%s_static_info",
+ sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
textToStr( module(name(n).mod).text ),
textToStr( name(n).text ) );
t = enZcodeThenFindText(buf);
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 (!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
}
}
}
- fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
- fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
+# ifdef DEBUG_IFACE
+ 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
static void* startGHCModule_clientLookup ( char* sym )
{
+# ifdef DEBUG_IFACE
/* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
+# endif
return lookupObjName ( sym );
}
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;
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;
q = mkQualId(exmod,ex);
c = findQualTyconWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
+# ifdef DEBUG_IFACE
fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
+# endif
module(mod).exports = cons(pair(c,NIL), module(mod).exports);
addTycon(c);
break;
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
if (abstract) {
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);
/* 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); */
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)) {
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); */
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;
}
}
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. */
}
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. */
}
/* 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. */
}
/* 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. */
}
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);
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");
{
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");
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);
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");
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "begin startGHCInstance\n" );
+ fprintf ( stderr, "begin startGHCInstance\n" );
# endif
line = intOf(line);
Type cls;
# ifdef DEBUG_IFACE
- printf ( "begin finishGHCInstance\n" );
+ fprintf ( stderr, "begin finishGHCInstance\n" );
# endif
assert (nonNull(in));
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 \
+#if defined(linux_TARGET_OS)
+#define IF_linux(xxx) xxx
+#define IF_cygwin32(xxx) /**/
+#define IF_solaris2(xxx) /**/
+#endif
+
+#if defined(solaris2_TARGET_OS)
+#define IF_linux(xxx) /**/
+#define IF_cygwin32(xxx) /**/
+#define IF_solaris2(xxx) xxx
+#endif
+
+#if defined(cgywin32_TARGET_OS)
+#define IF_linux(xxx) /**/
+#define IF_cygwin32(xxx) xxx
+#define IF_solaris2(xxx) /**/
+#endif
+
+#define EXTERN_SYMS_ALLPLATFORMS \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
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) \
- Sym(shutdownHaskellAndExit) \
+ 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)
+
+
+#if 0
+ Sym(__errno_location) \
+ Sym(__xstat) \
+ Sym(__fxstat) \
+ Sym(__lxstat) \
+ SymX(select) \
+ SymX(vfork) \
+ Sym(tzname) \
+ SymX(stderr) \
+
+#endif
-/* AJG Hack; for the moment, make EXTERN_SYMS vanish on Win32 */
-#ifdef _WIN32
-#undef EXTERN_SYMS
-#define EXTERN_SYMS
+#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
+
+/* 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;
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;
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
+#include <ctype.h>
#include <assert.h>
#include "config.h" /* for linux_TARGET_OS etc */
#include "object.h"
/* From PE spec doc, section 5.4.2 and 5.4.4 */
#define IMAGE_SYM_CLASS_EXTERNAL 2
+#define IMAGE_SYM_CLASS_STATIC 3
#define IMAGE_SYM_UNDEFINED 0
/* From PE spec doc, section 4.1 */
#define IMAGE_SCN_CNT_CODE 0x00000020
#define IMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
+/* From PE spec doc, section 5.2.1 */
+#define IMAGE_REL_I386_DIR32 0x0006
+#define IMAGE_REL_I386_REL32 0x0014
+
/* We use myindex to calculate array addresses, rather than
simply doing the normal subscript thing. That's because
}
+static void copyName ( UChar* name, UChar* strtab,
+ UChar* dst, int dstSize )
+{
+ if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
+ UInt32 strtab_offset = * (UInt32*)(name+4);
+ strncpy ( dst, strtab+strtab_offset, dstSize );
+ dst[dstSize-1] = 0;
+ } else {
+ int i = 0;
+ while (1) {
+ if (i >= 8) break;
+ if (name[i] == 0) break;
+ dst[i] = name[i];
+ i++;
+ }
+ dst[i] = 0;
+ }
+}
+
+
+static UChar* cstring_from_COFF_symbol_name ( UChar* name,
+ UChar* strtab )
+{
+ UChar* newstr;
+ /* If the string is longer than 8 bytes, look in the
+ string table for it -- this will be correctly zero terminated.
+ */
+ if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
+ UInt32 strtab_offset = * (UInt32*)(name+4);
+ return ((UChar*)strtab) + strtab_offset;
+ }
+ /* Otherwise, if shorter than 8 bytes, return the original,
+ which by defn is correctly terminated.
+ */
+ if (name[7]==0) return name;
+ /* The annoying case: 8 bytes. Copy into a temporary
+ (which is never freed ...)
+ */
+ newstr = malloc(9);
+ if (newstr) {
+ strncpy(newstr,name,8);
+ newstr[8] = 0;
+ }
+ return newstr;
+}
+
+
+/* Just compares the short names (first 8 chars) */
+static COFF_section* findPEi386SectionCalled ( ObjectCode* oc,
+ char* name )
+{
+ int i;
+ COFF_header* hdr
+ = (COFF_header*)(oc->oImage);
+ COFF_section* sectab
+ = (COFF_section*) (
+ ((UChar*)(oc->oImage))
+ + sizeof_COFF_header + hdr->SizeOfOptionalHeader
+ );
+ for (i = 0; i < hdr->NumberOfSections; i++) {
+ UChar* n1;
+ UChar* n2;
+ COFF_section* section_i
+ = (COFF_section*)
+ myindex ( sizeof_COFF_section, i, sectab );
+ n1 = (UChar*) &(section_i->Name);
+ n2 = name;
+ if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
+ n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
+ n1[6]==n2[6] && n1[7]==n2[7])
+ return section_i;
+ }
+
+ return NULL;
+}
+
+
+static void zapTrailingAtSign ( UChar* sym )
+{
+ int i, j;
+ if (sym[0] == 0) return;
+ i = 0;
+ while (sym[i] != 0) i++;
+ i--;
+ j = i;
+ while (j > 0 && isdigit(sym[j])) j--;
+ if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
+}
+
+
static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb )
{
int i, j;
COFF_section* sectab;
COFF_symbol* symtab;
UChar* strtab;
-
+
hdr = (COFF_header*)(oc->oImage);
sectab = (COFF_section*) (
((UChar*)(oc->oImage))
oc->errMsg("PEi386 with nonempty optional header");
return FALSE;
}
- if ( (hdr->Characteristics & IMAGE_FILE_RELOCS_STRIPPED) ||
+ if ( /* (hdr->Characteristics & IMAGE_FILE_RELOCS_STRIPPED) || */
(hdr->Characteristics & IMAGE_FILE_EXECUTABLE_IMAGE) ||
(hdr->Characteristics & IMAGE_FILE_DLL) ||
(hdr->Characteristics & IMAGE_FILE_SYSTEM) ) {
return FALSE;
}
if ( (hdr->Characteristics & IMAGE_FILE_BYTES_REVERSED_HI) ||
- !(hdr->Characteristics & IMAGE_FILE_BYTES_REVERSED_LO) ||
!(hdr->Characteristics & IMAGE_FILE_32BIT_MACHINE) ) {
oc->errMsg("Invalid PEi386 word size or endiannness");
return FALSE;
}
-static UChar* cstring_from_COFF_symbol_name ( UChar* name,
- UChar* strtab )
-{
- UChar* newstr;
- /* If the string is longer than 8 bytes, look in the
- string table for it -- this will be correctly zero terminated.
- */
- if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
- UInt32 strtab_offset = * (UInt32*)(name+4);
- return ((UChar*)strtab) + strtab_offset;
- }
- /* Otherwise, if shorter than 8 bytes, return the original,
- which by defn is correctly terminated.
- */
- if (name[7]==0) return name;
- /* The annoying case: 8 bytes. Copy into a temporary
- (which is never freed ...)
- */
- newstr = malloc(9);
- if (newstr) {
- strncpy(newstr,name,8);
- newstr[8] = 0;
- }
- return newstr;
-}
-
-
static int ocGetNames_PEi386 ( ObjectCode* oc, int verb )
{
COFF_header* hdr;
symtab_i->SectionNumber-1,
sectab );
addr = ((UChar*)(oc->oImage))
- + sectabent->PointerToRawData
- + symtab_i->Value;
-
+ + (sectabent->PointerToRawData
+ + symtab_i->Value);
+ /* fprintf ( stderr, "addSymbol %p `%s'\n", addr,sname); */
if (!addSymbol(oc,sname,addr)) return FALSE;
}
i += symtab_i->NumberOfAuxSymbols;
COFF_section* sectab_i
= (COFF_section*)
myindex ( sizeof_COFF_section, i, sectab );
+ /* fprintf ( stderr, "section name = %s\n", sectab_i->Name ); */
+#if 0
+ /* I'm sure this is the Right Way to do it. However, the
+ alternative of testing the sectab_i->Name field seems to
+ work ok with Cygwin.
+ */
if (sectab_i->Characteristics & IMAGE_SCN_CNT_CODE ||
sectab_i->Characteristics & IMAGE_SCN_CNT_INITIALIZED_DATA)
kind = HUGS_SECTIONKIND_CODE_OR_RODATA;
+#endif
+
+ if (0==strcmp(".text",sectab_i->Name))
+ kind = HUGS_SECTIONKIND_CODE_OR_RODATA;
+ if (0==strcmp(".data",sectab_i->Name) ||
+ 0==strcmp(".bss",sectab_i->Name))
+ kind = HUGS_SECTIONKIND_RWDATA;
start = ((UChar*)(oc->oImage))
+ sectab_i->PointerToRawData;
end = start
+ sectab_i->SizeOfRawData - 1;
- addSection ( oc, start, end, kind );
+
+ if (kind != HUGS_SECTIONKIND_OTHER) {
+ addSection ( oc, start, end, kind );
+ } else {
+ fprintf ( stderr, "unknown section name = `%s'\n",
+ sectab_i->Name);
+ oc->errMsg("Unknown PEi386 section name");
+ return FALSE;
+ }
}
return TRUE;
static int ocResolve_PEi386 ( ObjectCode* oc, int verb )
{
+ COFF_header* hdr;
+ COFF_section* sectab;
+ COFF_symbol* symtab;
+ UChar* strtab;
+
+ UInt32 A;
+ UInt32 S;
+ UInt32* pP;
+
+ int i, j;
+ char symbol[1000]; // ToDo
+ hdr = (COFF_header*)(oc->oImage);
+ sectab = (COFF_section*) (
+ ((UChar*)(oc->oImage))
+ + sizeof_COFF_header + hdr->SizeOfOptionalHeader
+ );
+ symtab = (COFF_symbol*) (
+ ((UChar*)(oc->oImage))
+ + hdr->PointerToSymbolTable
+ );
+ strtab = ((UChar*)(oc->oImage))
+ + hdr->PointerToSymbolTable
+ + hdr->NumberOfSymbols * sizeof_COFF_symbol;
+
+ for (i = 0; i < hdr->NumberOfSections; i++) {
+ COFF_section* sectab_i
+ = (COFF_section*)
+ myindex ( sizeof_COFF_section, i, sectab );
+ COFF_reloc* reltab
+ = (COFF_reloc*) (
+ ((UChar*)(oc->oImage)) + sectab_i->PointerToRelocations
+ );
+ for (j = 0; j < sectab_i->NumberOfRelocations; j++) {
+ COFF_symbol* sym;
+ COFF_reloc* reltab_j
+ = (COFF_reloc*)
+ myindex ( sizeof_COFF_reloc, j, reltab );
+
+ /* the location to patch */
+ pP = (UInt32*)(
+ ((UChar*)(oc->oImage))
+ + (sectab_i->PointerToRawData
+ + reltab_j->VirtualAddress)
+ );
+ /* the existing contents of pP */
+ A = *pP;
+ /* the symbol to connect to */
+ sym = (COFF_symbol*)
+ myindex ( sizeof_COFF_symbol,
+ reltab_j->SymbolTableIndex, symtab );
+ if (verb) {
+ fprintf ( stderr,
+ "reloc sec %2d num %3d: type 0x%-4x "
+ "vaddr 0x%-8x name `",
+ i, j,
+ (UInt32)reltab_j->Type,
+ reltab_j->VirtualAddress );
+ printName ( sym->Name, strtab );
+ fprintf ( stderr, "'\n" );
+ }
+
+ if (sym->StorageClass == IMAGE_SYM_CLASS_STATIC) {
+ COFF_section* section_sym
+ = findPEi386SectionCalled ( oc, sym->Name );
+ if (!section_sym) {
+ fprintf ( stderr, "bad section = `%s'\n", sym->Name );
+ oc->errMsg("Can't find abovementioned PEi386 section");
+ return FALSE;
+ }
+ S = ((UInt32)(oc->oImage))
+ + (section_sym->PointerToRawData
+ + sym->Value);
+ } else {
+ copyName ( sym->Name, strtab, symbol, 1000 );
+ zapTrailingAtSign ( symbol );
+ S = (UInt32) ocLookupSym ( oc, symbol );
+ if (S == 0)
+ S = (UInt32)(oc->clientLookup ( symbol ));
+ if (S == 0) {
+ char errtxt[2000];
+ strcpy(errtxt,oc->objFileName);
+ strcat(errtxt,": unresolvable reference to: ");
+ strcat(errtxt,symbol);
+ oc->errMsg(errtxt);
+ return FALSE;
+ }
+ }
+
+ switch (reltab_j->Type) {
+ case IMAGE_REL_I386_DIR32:
+ *pP = A + S;
+ break;
+ case IMAGE_REL_I386_REL32:
+ /* Tricky. We have to insert a displacement at
+ pP which, when added to the PC for the _next_
+ insn, gives the address of the target (S).
+ Problem is to know the address of the next insn
+ when we only know pP. We assume that this
+ literal field is always the last in the insn,
+ so that the address of the next insn is pP+4
+ -- hence the constant 4.
+ Also I don't know if A should be added, but so
+ far it has always been zero.
+ */
+ assert(A==0);
+ *pP = S - ((UInt32)pP) - 4;
+ break;
+ default:
+ fprintf(stderr,
+ "unhandled PEi386 relocation type %d\n",
+ reltab_j->Type);
+ oc->errMsg("unhandled PEi386 relocation type");
+ return FALSE;
+ }
+
+ }
+ }
+
+ return TRUE;
}
#endif /* defined(cygwin32_TARGET_OS) */
projects / ghc-hetmet.git / commitdiff