ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Linker.c,v 1.80 2002/01/29 06:15:03 sof Exp $
   3  *
   4  * (c) The GHC Team, 2000, 2001
   5  *
   6  * RTS Object Linker
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "PosixSource.h"
  11 #include "Rts.h"
  12 #include "RtsFlags.h"
  13 #include "HsFFI.h"
  14 #include "Hash.h"
  15 #include "Linker.h"
  16 #include "LinkerInternals.h"
  17 #include "RtsUtils.h"
  18 #include "StoragePriv.h"
  19 #include "Schedule.h"
  20
  21 #ifdef HAVE_SYS_TYPES_H
  22 #include <sys/types.h>
  23 #endif
  24
  25 #ifdef HAVE_SYS_STAT_H
  26 #include <sys/stat.h>
  27 #endif
  28
  29 #ifdef HAVE_DLFCN_H
  30 #include <dlfcn.h>
  31 #endif
  32
  33 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) || defined(freebsd_TARGET_OS)
  34 #  define OBJFORMAT_ELF
  35 #elif defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
  36 #  define OBJFORMAT_PEi386
  37 #  include <windows.h>
  38 #endif
  39
  40 /* Hash table mapping symbol names to Symbol */
  41 /*Str*/HashTable *symhash;
  42
  43 #if defined(OBJFORMAT_ELF)
  44 static int ocVerifyImage_ELF    ( ObjectCode* oc );
  45 static int ocGetNames_ELF       ( ObjectCode* oc );
  46 static int ocResolve_ELF        ( ObjectCode* oc );
  47 #elif defined(OBJFORMAT_PEi386)
  48 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
  49 static int ocGetNames_PEi386    ( ObjectCode* oc );
  50 static int ocResolve_PEi386     ( ObjectCode* oc );
  51 #endif
  52
  53 /* -----------------------------------------------------------------------------
  54  * Built-in symbols from the RTS
  55  */
  56
  57 typedef struct _RtsSymbolVal {
  58     char   *lbl;
  59     void   *addr;
  60 } RtsSymbolVal;
  61
  62
  63 #if !defined(PAR)
  64 #define Maybe_ForeignObj        SymX(mkForeignObjzh_fast)
  65
  66 #define Maybe_Stable_Names      SymX(mkWeakzh_fast)                     \
  67                                 SymX(makeStableNamezh_fast)             \
  68                                 SymX(finalizzeWeakzh_fast)
  69 #else
  70 /* These are not available in GUM!!! -- HWL */
  71 #define Maybe_ForeignObj
  72 #define Maybe_Stable_Names
  73 #endif
  74
  75 #if !defined (mingw32_TARGET_OS)
  76
  77 #define RTS_POSIX_ONLY_SYMBOLS                  \
  78       SymX(stg_sig_install)                     \
  79       Sym(nocldstop)
  80 #define RTS_MINGW_ONLY_SYMBOLS /**/
  81
  82 #else
  83
  84 #define RTS_POSIX_ONLY_SYMBOLS
  85
  86 /* These are statically linked from the mingw libraries into the ghc
  87    executable, so we have to employ this hack. */
  88 #define RTS_MINGW_ONLY_SYMBOLS                  \
  89       SymX(memset)                              \
  90       SymX(inet_ntoa)                           \
  91       SymX(inet_addr)                           \
  92       SymX(htonl)                               \
  93       SymX(recvfrom)                            \
  94       SymX(listen)                              \
  95       SymX(bind)                                \
  96       SymX(shutdown)                            \
  97       SymX(connect)                             \
  98       SymX(htons)                               \
  99       SymX(ntohs)                               \
 100       SymX(getservbyname)                       \
 101       SymX(getservbyport)                       \
 102       SymX(getprotobynumber)                    \
 103       SymX(getprotobyname)                      \
 104       SymX(gethostbyname)                       \
 105       SymX(gethostbyaddr)                       \
 106       SymX(gethostname)                         \
 107       SymX(strcpy)                              \
 108       SymX(strncpy)                             \
 109       SymX(abort)                               \
 110       Sym(_alloca)                              \
 111       Sym(isxdigit)                             \
 112       Sym(isupper)                              \
 113       Sym(ispunct)                              \
 114       Sym(islower)                              \
 115       Sym(isspace)                              \
 116       Sym(isprint)                              \
 117       Sym(isdigit)                              \
 118       Sym(iscntrl)                              \
 119       Sym(isalpha)                              \
 120       Sym(isalnum)                              \
 121       SymX(strcmp)                              \
 122       SymX(memmove)                             \
 123       SymX(realloc)                             \
 124       SymX(malloc)                              \
 125       SymX(pow)                                 \
 126       SymX(tanh)                                \
 127       SymX(cosh)                                \
 128       SymX(sinh)                                \
 129       SymX(atan)                                \
 130       SymX(acos)                                \
 131       SymX(asin)                                \
 132       SymX(tan)                                 \
 133       SymX(cos)                                 \
 134       SymX(sin)                                 \
 135       SymX(exp)                                 \
 136       SymX(log)                                 \
 137       SymX(sqrt)                                \
 138       SymX(memcpy)                              \
 139       Sym(mktime)                               \
 140       Sym(_imp___timezone)                      \
 141       Sym(_imp___tzname)                        \
 142       Sym(_imp___iob)                           \
 143       Sym(localtime)                            \
 144       Sym(gmtime)                               \
 145       Sym(opendir)                              \
 146       Sym(readdir)                              \
 147       Sym(closedir)                             \
 148       Sym(__divdi3)                             \
 149       Sym(__udivdi3)                            \
 150       Sym(__moddi3)                             \
 151       Sym(__umoddi3)
 152 #endif
 153
 154 #ifndef SMP
 155 # define MAIN_CAP_SYM SymX(MainCapability)
 156 #else
 157 # define MAIN_CAP_SYM
 158 #endif
 159
 160 #define RTS_SYMBOLS                             \
 161       Maybe_ForeignObj                          \
 162       Maybe_Stable_Names                        \
 163       Sym(StgReturn)                            \
 164       Sym(__stginit_PrelGHC)                    \
 165       Sym(init_stack)                           \
 166       SymX(__stg_chk_0)                         \
 167       SymX(__stg_chk_1)                         \
 168       Sym(stg_enterStackTop)                    \
 169       SymX(stg_gc_d1)                           \
 170       SymX(stg_gc_l1)                           \
 171       SymX(__stg_gc_enter_1)                    \
 172       SymX(stg_gc_f1)                           \
 173       SymX(stg_gc_noregs)                       \
 174       SymX(stg_gc_seq_1)                        \
 175       SymX(stg_gc_unbx_r1)                      \
 176       SymX(stg_gc_unpt_r1)                      \
 177       SymX(stg_gc_ut_0_1)                       \
 178       SymX(stg_gc_ut_1_0)                       \
 179       SymX(stg_gen_chk)                         \
 180       SymX(stg_yield_to_interpreter)            \
 181       SymX(ErrorHdrHook)                        \
 182       MAIN_CAP_SYM                              \
 183       SymX(MallocFailHook)                      \
 184       SymX(NoRunnableThreadsHook)               \
 185       SymX(OnExitHook)                          \
 186       SymX(OutOfHeapHook)                       \
 187       SymX(PatErrorHdrHook)                     \
 188       SymX(PostTraceHook)                       \
 189       SymX(PreTraceHook)                        \
 190       SymX(StackOverflowHook)                   \
 191       SymX(__encodeDouble)                      \
 192       SymX(__encodeFloat)                       \
 193       SymX(__gmpn_gcd_1)                        \
 194       SymX(__gmpz_cmp)                          \
 195       SymX(__gmpz_cmp_si)                       \
 196       SymX(__gmpz_cmp_ui)                       \
 197       SymX(__gmpz_get_si)                       \
 198       SymX(__gmpz_get_ui)                       \
 199       SymX(__int_encodeDouble)                  \
 200       SymX(__int_encodeFloat)                   \
 201       SymX(andIntegerzh_fast)                   \
 202       SymX(blockAsyncExceptionszh_fast)         \
 203       SymX(catchzh_fast)                        \
 204       SymX(cmp_thread)                          \
 205       SymX(complementIntegerzh_fast)            \
 206       SymX(cmpIntegerzh_fast)                   \
 207       SymX(cmpIntegerIntzh_fast)                \
 208       SymX(createAdjustor)                      \
 209       SymX(decodeDoublezh_fast)                 \
 210       SymX(decodeFloatzh_fast)                  \
 211       SymX(defaultsHook)                        \
 212       SymX(delayzh_fast)                        \
 213       SymX(deRefWeakzh_fast)                    \
 214       SymX(deRefStablePtrzh_fast)               \
 215       SymX(divExactIntegerzh_fast)              \
 216       SymX(divModIntegerzh_fast)                \
 217       SymX(forkzh_fast)                         \
 218       SymX(freeHaskellFunctionPtr)              \
 219       SymX(freeStablePtr)                       \
 220       SymX(gcdIntegerzh_fast)                   \
 221       SymX(gcdIntegerIntzh_fast)                \
 222       SymX(gcdIntzh_fast)                       \
 223       SymX(getProgArgv)                         \
 224       SymX(getStablePtr)                        \
 225       SymX(int2Integerzh_fast)                  \
 226       SymX(integer2Intzh_fast)                  \
 227       SymX(integer2Wordzh_fast)                 \
 228       SymX(isDoubleDenormalized)                \
 229       SymX(isDoubleInfinite)                    \
 230       SymX(isDoubleNaN)                         \
 231       SymX(isDoubleNegativeZero)                \
 232       SymX(isEmptyMVarzh_fast)                  \
 233       SymX(isFloatDenormalized)                 \
 234       SymX(isFloatInfinite)                     \
 235       SymX(isFloatNaN)                          \
 236       SymX(isFloatNegativeZero)                 \
 237       SymX(killThreadzh_fast)                   \
 238       SymX(makeStablePtrzh_fast)                \
 239       SymX(minusIntegerzh_fast)                 \
 240       SymX(mkApUpd0zh_fast)                     \
 241       SymX(myThreadIdzh_fast)                   \
 242       SymX(newArrayzh_fast)                     \
 243       SymX(newBCOzh_fast)                       \
 244       SymX(newByteArrayzh_fast)                 \
 245       SymX(newCAF)                              \
 246       SymX(newMVarzh_fast)                      \
 247       SymX(newMutVarzh_fast)                    \
 248       SymX(newPinnedByteArrayzh_fast)           \
 249       SymX(orIntegerzh_fast)                    \
 250       SymX(performGC)                           \
 251       SymX(plusIntegerzh_fast)                  \
 252       SymX(prog_argc)                           \
 253       SymX(prog_argv)                           \
 254       SymX(putMVarzh_fast)                      \
 255       SymX(quotIntegerzh_fast)                  \
 256       SymX(quotRemIntegerzh_fast)               \
 257       SymX(raisezh_fast)                        \
 258       SymX(remIntegerzh_fast)                   \
 259       SymX(resetNonBlockingFd)                  \
 260       SymX(resumeThread)                        \
 261       SymX(rts_apply)                           \
 262       SymX(rts_checkSchedStatus)                \
 263       SymX(rts_eval)                            \
 264       SymX(rts_evalIO)                          \
 265       SymX(rts_evalLazyIO)                      \
 266       SymX(rts_eval_)                           \
 267       SymX(rts_getAddr)                         \
 268       SymX(rts_getBool)                         \
 269       SymX(rts_getChar)                         \
 270       SymX(rts_getDouble)                       \
 271       SymX(rts_getFloat)                        \
 272       SymX(rts_getInt)                          \
 273       SymX(rts_getInt32)                        \
 274       SymX(rts_getPtr)                          \
 275       SymX(rts_getStablePtr)                    \
 276       SymX(rts_getThreadId)                     \
 277       SymX(rts_getWord)                         \
 278       SymX(rts_getWord32)                       \
 279       SymX(rts_mkAddr)                          \
 280       SymX(rts_mkBool)                          \
 281       SymX(rts_mkChar)                          \
 282       SymX(rts_mkDouble)                        \
 283       SymX(rts_mkFloat)                         \
 284       SymX(rts_mkInt)                           \
 285       SymX(rts_mkInt16)                         \
 286       SymX(rts_mkInt32)                         \
 287       SymX(rts_mkInt64)                         \
 288       SymX(rts_mkInt8)                          \
 289       SymX(rts_mkPtr)                           \
 290       SymX(rts_mkStablePtr)                     \
 291       SymX(rts_mkString)                        \
 292       SymX(rts_mkWord)                          \
 293       SymX(rts_mkWord16)                        \
 294       SymX(rts_mkWord32)                        \
 295       SymX(rts_mkWord64)                        \
 296       SymX(rts_mkWord8)                         \
 297       SymX(run_queue_hd)                        \
 298       SymX(setProgArgv)                         \
 299       SymX(shutdownHaskellAndExit)              \
 300       SymX(stable_ptr_table)                    \
 301       SymX(stackOverflow)                       \
 302       SymX(stg_CAF_BLACKHOLE_info)              \
 303       SymX(stg_CHARLIKE_closure)                \
 304       SymX(stg_EMPTY_MVAR_info)                 \
 305       SymX(stg_IND_STATIC_info)                 \
 306       SymX(stg_INTLIKE_closure)                 \
 307       SymX(stg_MUT_ARR_PTRS_FROZEN_info)        \
 308       SymX(stg_WEAK_info)                       \
 309       SymX(stg_ap_1_upd_info)                   \
 310       SymX(stg_ap_2_upd_info)                   \
 311       SymX(stg_ap_3_upd_info)                   \
 312       SymX(stg_ap_4_upd_info)                   \
 313       SymX(stg_ap_5_upd_info)                   \
 314       SymX(stg_ap_6_upd_info)                   \
 315       SymX(stg_ap_7_upd_info)                   \
 316       SymX(stg_ap_8_upd_info)                   \
 317       SymX(stg_exit)                            \
 318       SymX(stg_sel_0_upd_info)                  \
 319       SymX(stg_sel_10_upd_info)                 \
 320       SymX(stg_sel_11_upd_info)                 \
 321       SymX(stg_sel_12_upd_info)                 \
 322       SymX(stg_sel_13_upd_info)                 \
 323       SymX(stg_sel_14_upd_info)                 \
 324       SymX(stg_sel_15_upd_info)                 \
 325       SymX(stg_sel_1_upd_info)                  \
 326       SymX(stg_sel_2_upd_info)                  \
 327       SymX(stg_sel_3_upd_info)                  \
 328       SymX(stg_sel_4_upd_info)                  \
 329       SymX(stg_sel_5_upd_info)                  \
 330       SymX(stg_sel_6_upd_info)                  \
 331       SymX(stg_sel_7_upd_info)                  \
 332       SymX(stg_sel_8_upd_info)                  \
 333       SymX(stg_sel_9_upd_info)                  \
 334       SymX(stg_seq_frame_info)                  \
 335       SymX(stg_upd_frame_info)                  \
 336       SymX(__stg_update_PAP)                    \
 337       SymX(suspendThread)                       \
 338       SymX(takeMVarzh_fast)                     \
 339       SymX(timesIntegerzh_fast)                 \
 340       SymX(tryPutMVarzh_fast)                   \
 341       SymX(tryTakeMVarzh_fast)                  \
 342       SymX(unblockAsyncExceptionszh_fast)       \
 343       SymX(unsafeThawArrayzh_fast)              \
 344       SymX(waitReadzh_fast)                     \
 345       SymX(waitWritezh_fast)                    \
 346       SymX(word2Integerzh_fast)                 \
 347       SymX(xorIntegerzh_fast)                   \
 348       SymX(yieldzh_fast)
 349
 350 #ifndef SUPPORT_LONG_LONGS
 351 #define RTS_LONG_LONG_SYMS /* nothing */
 352 #else
 353 #define RTS_LONG_LONG_SYMS                      \
 354       SymX(int64ToIntegerzh_fast)               \
 355       SymX(word64ToIntegerzh_fast)
 356 #endif /* SUPPORT_LONG_LONGS */
 357
 358 /* entirely bogus claims about types of these symbols */
 359 #define Sym(vvv)  extern void (vvv);
 360 #define SymX(vvv) /**/
 361 RTS_SYMBOLS
 362 RTS_LONG_LONG_SYMS
 363 RTS_POSIX_ONLY_SYMBOLS
 364 RTS_MINGW_ONLY_SYMBOLS
 365 #undef Sym
 366 #undef SymX
 367
 368 #ifdef LEADING_UNDERSCORE
 369 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
 370 #else
 371 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
 372 #endif
 373
 374 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 375                     (void*)(&(vvv)) },
 376 #define SymX(vvv) Sym(vvv)
 377
 378 static RtsSymbolVal rtsSyms[] = {
 379       RTS_SYMBOLS
 380       RTS_LONG_LONG_SYMS
 381       RTS_POSIX_ONLY_SYMBOLS
 382       RTS_MINGW_ONLY_SYMBOLS
 383       { 0, 0 } /* sentinel */
 384 };
 385
 386 /* -----------------------------------------------------------------------------
 387  * Insert symbols into hash tables, checking for duplicates.
 388  */
 389 static void ghciInsertStrHashTable ( char* obj_name,
 390                                      HashTable *table,
 391                                      char* key,
 392                                      void *data
 393                                    )
 394 {
 395    if (lookupHashTable(table, (StgWord)key) == NULL)
 396    {
 397       insertStrHashTable(table, (StgWord)key, data);
 398       return;
 399    }
 400    fprintf(stderr,
 401       "\n\n"
 402       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
 403       "   %s\n"
 404       "whilst processing object file\n"
 405       "   %s\n"
 406       "This could be caused by:\n"
 407       "   * Loading two different object files which export the same symbol\n"
 408       "   * Specifying the same object file twice on the GHCi command line\n"
 409       "   * An incorrect `package.conf' entry, causing some object to be\n"
 410       "     loaded twice.\n"
 411       "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
 412       "\n",
 413       (char*)key,
 414       obj_name
 415    );
 416    exit(1);
 417 }
 418
 419
 420 /* -----------------------------------------------------------------------------
 421  * initialize the object linker
 422  */
 423 #if defined(OBJFORMAT_ELF)
 424 static void *dl_prog_handle;
 425 #endif
 426
 427 void
 428 initLinker( void )
 429 {
 430     RtsSymbolVal *sym;
 431
 432     symhash = allocStrHashTable();
 433
 434     /* populate the symbol table with stuff from the RTS */
 435     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 436         ghciInsertStrHashTable("(GHCi built-in symbols)",
 437                                symhash, sym->lbl, sym->addr);
 438     }
 439 #   if defined(OBJFORMAT_ELF)
 440     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
 441 #   endif
 442 }
 443
 444 /* -----------------------------------------------------------------------------
 445  * Add a DLL from which symbols may be found.  In the ELF case, just
 446  * do RTLD_GLOBAL-style add, so no further messing around needs to
 447  * happen in order that symbols in the loaded .so are findable --
 448  * lookupSymbol() will subsequently see them by dlsym on the program's
 449  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
 450  *
 451  * In the PEi386 case, open the DLLs and put handles to them in a
 452  * linked list.  When looking for a symbol, try all handles in the
 453  * list.
 454  */
 455
 456 #if defined(OBJFORMAT_PEi386)
 457 /* A record for storing handles into DLLs. */
 458
 459 typedef
 460    struct _OpenedDLL {
 461       char*              name;
 462       struct _OpenedDLL* next;
 463       HINSTANCE instance;
 464    }
 465    OpenedDLL;
 466
 467 /* A list thereof. */
 468 static OpenedDLL* opened_dlls = NULL;
 469 #endif
 470
 471
 472
 473 char*
 474 addDLL ( __attribute((unused)) char* path, char* dll_name )
 475 {
 476 #  if defined(OBJFORMAT_ELF)
 477    void *hdl;
 478    char *buf;
 479    char *errmsg;
 480
 481    if (path == NULL || strlen(path) == 0) {
 482       buf = stgMallocBytes(strlen(dll_name) + 10, "addDll");
 483       sprintf(buf, "lib%s.so", dll_name);
 484    } else {
 485       buf = stgMallocBytes(strlen(path) + 1 + strlen(dll_name) + 10, "addDll");
 486       sprintf(buf, "%s/lib%s.so", path, dll_name);
 487    }
 488    hdl = dlopen(buf, RTLD_NOW | RTLD_GLOBAL );
 489    free(buf);
 490    if (hdl == NULL) {
 491       /* dlopen failed; return a ptr to the error msg. */
 492       errmsg = dlerror();
 493       if (errmsg == NULL) errmsg = "addDLL: unknown error";
 494       return errmsg;
 495    } else {
 496       return NULL;
 497    }
 498    /*NOTREACHED*/
 499
 500 #  elif defined(OBJFORMAT_PEi386)
 501
 502    /* Add this DLL to the list of DLLs in which to search for symbols.
 503       The path argument is ignored. */
 504    char*      buf;
 505    OpenedDLL* o_dll;
 506    HINSTANCE  instance;
 507
 508    /* fprintf(stderr, "\naddDLL; path=`%s', dll_name = `%s'\n", path, dll_name); */
 509
 510    /* See if we've already got it, and ignore if so. */
 511    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 512       if (0 == strcmp(o_dll->name, dll_name))
 513          return NULL;
 514    }
 515
 516    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
 517    sprintf(buf, "%s.DLL", dll_name);
 518    instance = LoadLibrary(buf);
 519    free(buf);
 520    if (instance == NULL) {
 521      /* LoadLibrary failed; return a ptr to the error msg. */
 522      return "addDLL: unknown error";
 523    }
 524
 525    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
 526    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
 527    strcpy(o_dll->name, dll_name);
 528    o_dll->instance = instance;
 529    o_dll->next     = opened_dlls;
 530    opened_dlls     = o_dll;
 531
 532    return NULL;
 533 #  else
 534    barf("addDLL: not implemented on this platform");
 535 #  endif
 536 }
 537
 538 /* -----------------------------------------------------------------------------
 539  * lookup a symbol in the hash table
 540  */
 541 void *
 542 lookupSymbol( char *lbl )
 543 {
 544     void *val;
 545     ASSERT(symhash != NULL);
 546     val = lookupStrHashTable(symhash, lbl);
 547
 548     if (val == NULL) {
 549 #       if defined(OBJFORMAT_ELF)
 550         return dlsym(dl_prog_handle, lbl);
 551 #       elif defined(OBJFORMAT_PEi386)
 552         OpenedDLL* o_dll;
 553         void* sym;
 554         for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 555           /* fprintf(stderr, "look in %s for %s\n", o_dll->name, lbl); */
 556            if (lbl[0] == '_') {
 557               /* HACK: if the name has an initial underscore, try stripping
 558                  it off & look that up first. I've yet to verify whether there's
 559                  a Rule that governs whether an initial '_' *should always* be
 560                  stripped off when mapping from import lib name to the DLL name.
 561               */
 562               sym = GetProcAddress(o_dll->instance, (lbl+1));
 563               if (sym != NULL) {
 564                 /*fprintf(stderr, "found %s in %s\n", lbl+1,o_dll->name); fflush(stderr);*/
 565                 return sym;
 566               }
 567            }
 568            sym = GetProcAddress(o_dll->instance, lbl);
 569            if (sym != NULL) {
 570              /*fprintf(stderr, "found %s in %s\n", lbl,o_dll->name); fflush(stderr);*/
 571              return sym;
 572            }
 573         }
 574         return NULL;
 575 #       else
 576         ASSERT(2+2 == 5);
 577         return NULL;
 578 #       endif
 579     } else {
 580         return val;
 581     }
 582 }
 583
 584 static
 585 __attribute((unused))
 586 void *
 587 lookupLocalSymbol( ObjectCode* oc, char *lbl )
 588 {
 589     void *val;
 590     val = lookupStrHashTable(oc->lochash, lbl);
 591
 592     if (val == NULL) {
 593         return NULL;
 594     } else {
 595         return val;
 596     }
 597 }
 598
 599
 600 /* -----------------------------------------------------------------------------
 601  * Debugging aid: look in GHCi's object symbol tables for symbols
 602  * within DELTA bytes of the specified address, and show their names.
 603  */
 604 #ifdef DEBUG
 605 void ghci_enquire ( char* addr );
 606
 607 void ghci_enquire ( char* addr )
 608 {
 609    int   i;
 610    char* sym;
 611    char* a;
 612    const int DELTA = 64;
 613    ObjectCode* oc;
 614    for (oc = objects; oc; oc = oc->next) {
 615       for (i = 0; i < oc->n_symbols; i++) {
 616          sym = oc->symbols[i];
 617          if (sym == NULL) continue;
 618          /* fprintf(stderr, "enquire %p %p\n", sym, oc->lochash); */
 619          a = NULL;
 620          if (oc->lochash != NULL)
 621             a = lookupStrHashTable(oc->lochash, sym);
 622          if (a == NULL)
 623             a = lookupStrHashTable(symhash, sym);
 624          if (a == NULL) {
 625             /* fprintf(stderr, "ghci_enquire: can't find %s\n", sym); */
 626          }
 627          else if (addr-DELTA <= a && a <= addr+DELTA) {
 628             fprintf(stderr, "%p + %3d  ==  `%s'\n", addr, a - addr, sym);
 629          }
 630       }
 631    }
 632 }
 633 #endif
 634
 635
 636 /* -----------------------------------------------------------------------------
 637  * Load an obj (populate the global symbol table, but don't resolve yet)
 638  *
 639  * Returns: 1 if ok, 0 on error.
 640  */
 641 HsInt
 642 loadObj( char *path )
 643 {
 644    ObjectCode* oc;
 645    struct stat st;
 646    int r, n;
 647    FILE *f;
 648
 649    /* fprintf(stderr, "loadObj %s\n", path ); */
 650
 651    /* Check that we haven't already loaded this object.  Don't give up
 652       at this stage; ocGetNames_* will barf later. */
 653    {
 654        ObjectCode *o;
 655        int is_dup = 0;
 656        for (o = objects; o; o = o->next) {
 657           if (0 == strcmp(o->fileName, path))
 658              is_dup = 1;
 659        }
 660        if (is_dup) {
 661          fprintf(stderr,
 662             "\n\n"
 663             "GHCi runtime linker: warning: looks like you're trying to load the\n"
 664             "same object file twice:\n"
 665             "   %s\n"
 666             "GHCi will continue, but a duplicate-symbol error may shortly follow.\n"
 667             "\n"
 668             , path);
 669        }
 670    }
 671
 672    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
 673
 674 #  if defined(OBJFORMAT_ELF)
 675    oc->formatName = "ELF";
 676 #  elif defined(OBJFORMAT_PEi386)
 677    oc->formatName = "PEi386";
 678 #  else
 679    free(oc);
 680    barf("loadObj: not implemented on this platform");
 681 #  endif
 682
 683    r = stat(path, &st);
 684    if (r == -1) { return 0; }
 685
 686    /* sigh, strdup() isn't a POSIX function, so do it the long way */
 687    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
 688    strcpy(oc->fileName, path);
 689
 690    oc->fileSize          = st.st_size;
 691    oc->image             = stgMallocBytes( st.st_size, "loadObj(image)" );
 692    oc->symbols           = NULL;
 693    oc->sections          = NULL;
 694    oc->lochash           = allocStrHashTable();
 695    oc->proddables        = NULL;
 696
 697    /* chain it onto the list of objects */
 698    oc->next              = objects;
 699    objects               = oc;
 700
 701    /* load the image into memory */
 702    f = fopen(path, "rb");
 703    if (!f) {
 704        barf("loadObj: can't read `%s'", path);
 705    }
 706    n = fread ( oc->image, 1, oc->fileSize, f );
 707    if (n != oc->fileSize) {
 708       fclose(f);
 709       barf("loadObj: error whilst reading `%s'", path);
 710    }
 711
 712    /* verify the in-memory image */
 713 #  if defined(OBJFORMAT_ELF)
 714    r = ocVerifyImage_ELF ( oc );
 715 #  elif defined(OBJFORMAT_PEi386)
 716    r = ocVerifyImage_PEi386 ( oc );
 717 #  else
 718    barf("loadObj: no verify method");
 719 #  endif
 720    if (!r) { return r; }
 721
 722    /* build the symbol list for this image */
 723 #  if defined(OBJFORMAT_ELF)
 724    r = ocGetNames_ELF ( oc );
 725 #  elif defined(OBJFORMAT_PEi386)
 726    r = ocGetNames_PEi386 ( oc );
 727 #  else
 728    barf("loadObj: no getNames method");
 729 #  endif
 730    if (!r) { return r; }
 731
 732    /* loaded, but not resolved yet */
 733    oc->status = OBJECT_LOADED;
 734
 735    return 1;
 736 }
 737
 738 /* -----------------------------------------------------------------------------
 739  * resolve all the currently unlinked objects in memory
 740  *
 741  * Returns: 1 if ok, 0 on error.
 742  */
 743 HsInt
 744 resolveObjs( void )
 745 {
 746     ObjectCode *oc;
 747     int r;
 748
 749     for (oc = objects; oc; oc = oc->next) {
 750         if (oc->status != OBJECT_RESOLVED) {
 751 #           if defined(OBJFORMAT_ELF)
 752             r = ocResolve_ELF ( oc );
 753 #           elif defined(OBJFORMAT_PEi386)
 754             r = ocResolve_PEi386 ( oc );
 755 #           else
 756             barf("resolveObjs: not implemented on this platform");
 757 #           endif
 758             if (!r) { return r; }
 759             oc->status = OBJECT_RESOLVED;
 760         }
 761     }
 762     return 1;
 763 }
 764
 765 /* -----------------------------------------------------------------------------
 766  * delete an object from the pool
 767  */
 768 HsInt
 769 unloadObj( char *path )
 770 {
 771     ObjectCode *oc, *prev;
 772
 773     ASSERT(symhash != NULL);
 774     ASSERT(objects != NULL);
 775
 776     prev = NULL;
 777     for (oc = objects; oc; prev = oc, oc = oc->next) {
 778         if (!strcmp(oc->fileName,path)) {
 779
 780             /* Remove all the mappings for the symbols within this
 781              * object..
 782              */
 783             {
 784                 int i;
 785                 for (i = 0; i < oc->n_symbols; i++) {
 786                    if (oc->symbols[i] != NULL) {
 787                        removeStrHashTable(symhash, oc->symbols[i], NULL);
 788                    }
 789                 }
 790             }
 791
 792             if (prev == NULL) {
 793                 objects = oc->next;
 794             } else {
 795                 prev->next = oc->next;
 796             }
 797
 798             /* We're going to leave this in place, in case there are
 799                any pointers from the heap into it: */
 800             /* free(oc->image); */
 801             free(oc->fileName);
 802             free(oc->symbols);
 803             free(oc->sections);
 804             /* The local hash table should have been freed at the end
 805                of the ocResolve_ call on it. */
 806             ASSERT(oc->lochash == NULL);
 807             free(oc);
 808             return 1;
 809         }
 810     }
 811
 812     belch("unloadObj: can't find `%s' to unload", path);
 813     return 0;
 814 }
 815
 816 /* -----------------------------------------------------------------------------
 817  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
 818  * which may be prodded during relocation, and abort if we try and write
 819  * outside any of these.
 820  */
 821 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
 822 {
 823    ProddableBlock* pb
 824       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
 825    /* fprintf(stderr, "aPB %p %p %d\n", oc, start, size); */
 826    ASSERT(size > 0);
 827    pb->start      = start;
 828    pb->size       = size;
 829    pb->next       = oc->proddables;
 830    oc->proddables = pb;
 831 }
 832
 833 static void checkProddableBlock ( ObjectCode* oc, void* addr )
 834 {
 835    ProddableBlock* pb;
 836    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
 837       char* s = (char*)(pb->start);
 838       char* e = s + pb->size - 1;
 839       char* a = (char*)addr;
 840       /* Assumes that the biggest fixup involves a 4-byte write.  This
 841          probably needs to be changed to 8 (ie, +7) on 64-bit
 842          plats. */
 843       if (a >= s && (a+3) <= e) return;
 844    }
 845    barf("checkProddableBlock: invalid fixup in runtime linker");
 846 }
 847
 848 /* -----------------------------------------------------------------------------
 849  * Section management.
 850  */
 851 static void addSection ( ObjectCode* oc, SectionKind kind,
 852                          void* start, void* end )
 853 {
 854    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
 855    s->start     = start;
 856    s->end       = end;
 857    s->kind      = kind;
 858    s->next      = oc->sections;
 859    oc->sections = s;
 860 }
 861
 862
 863
 864 /* --------------------------------------------------------------------------
 865  * PEi386 specifics (Win32 targets)
 866  * ------------------------------------------------------------------------*/
 867
 868 /* The information for this linker comes from
 869       Microsoft Portable Executable
 870       and Common Object File Format Specification
 871       revision 5.1 January 1998
 872    which SimonM says comes from the MS Developer Network CDs.
 873 */
 874
 875
 876 #if defined(OBJFORMAT_PEi386)
 877
 878
 879
 880 typedef unsigned char  UChar;
 881 typedef unsigned short UInt16;
 882 typedef unsigned int   UInt32;
 883 typedef          int   Int32;
 884
 885
 886 typedef
 887    struct {
 888       UInt16 Machine;
 889       UInt16 NumberOfSections;
 890       UInt32 TimeDateStamp;
 891       UInt32 PointerToSymbolTable;
 892       UInt32 NumberOfSymbols;
 893       UInt16 SizeOfOptionalHeader;
 894       UInt16 Characteristics;
 895    }
 896    COFF_header;
 897
 898 #define sizeof_COFF_header 20
 899
 900
 901 typedef
 902    struct {
 903       UChar  Name[8];
 904       UInt32 VirtualSize;
 905       UInt32 VirtualAddress;
 906       UInt32 SizeOfRawData;
 907       UInt32 PointerToRawData;
 908       UInt32 PointerToRelocations;
 909       UInt32 PointerToLinenumbers;
 910       UInt16 NumberOfRelocations;
 911       UInt16 NumberOfLineNumbers;
 912       UInt32 Characteristics;
 913    }
 914    COFF_section;
 915
 916 #define sizeof_COFF_section 40
 917
 918
 919 typedef
 920    struct {
 921       UChar  Name[8];
 922       UInt32 Value;
 923       UInt16 SectionNumber;
 924       UInt16 Type;
 925       UChar  StorageClass;
 926       UChar  NumberOfAuxSymbols;
 927    }
 928    COFF_symbol;
 929
 930 #define sizeof_COFF_symbol 18
 931
 932
 933 typedef
 934    struct {
 935       UInt32 VirtualAddress;
 936       UInt32 SymbolTableIndex;
 937       UInt16 Type;
 938    }
 939    COFF_reloc;
 940
 941 #define sizeof_COFF_reloc 10
 942
 943
 944 /* From PE spec doc, section 3.3.2 */
 945 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
 946    windows.h -- for the same purpose, but I want to know what I'm
 947    getting, here. */
 948 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
 949 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
 950 #define MYIMAGE_FILE_DLL                 0x2000
 951 #define MYIMAGE_FILE_SYSTEM              0x1000
 952 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
 953 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
 954 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
 955
 956 /* From PE spec doc, section 5.4.2 and 5.4.4 */
 957 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
 958 #define MYIMAGE_SYM_CLASS_STATIC         3
 959 #define MYIMAGE_SYM_UNDEFINED            0
 960
 961 /* From PE spec doc, section 4.1 */
 962 #define MYIMAGE_SCN_CNT_CODE             0x00000020
 963 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
 964 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
 965
 966 /* From PE spec doc, section 5.2.1 */
 967 #define MYIMAGE_REL_I386_DIR32           0x0006
 968 #define MYIMAGE_REL_I386_REL32           0x0014
 969
 970
 971 /* We use myindex to calculate array addresses, rather than
 972    simply doing the normal subscript thing.  That's because
 973    some of the above structs have sizes which are not
 974    a whole number of words.  GCC rounds their sizes up to a
 975    whole number of words, which means that the address calcs
 976    arising from using normal C indexing or pointer arithmetic
 977    are just plain wrong.  Sigh.
 978 */
 979 static UChar *
 980 myindex ( int scale, void* base, int index )
 981 {
 982    return
 983       ((UChar*)base) + scale * index;
 984 }
 985
 986
 987 static void
 988 printName ( UChar* name, UChar* strtab )
 989 {
 990    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
 991       UInt32 strtab_offset = * (UInt32*)(name+4);
 992       fprintf ( stderr, "%s", strtab + strtab_offset );
 993    } else {
 994       int i;
 995       for (i = 0; i < 8; i++) {
 996          if (name[i] == 0) break;
 997          fprintf ( stderr, "%c", name[i] );
 998       }
 999    }
1000 }
1001
1002
1003 static void
1004 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1005 {
1006    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1007       UInt32 strtab_offset = * (UInt32*)(name+4);
1008       strncpy ( dst, strtab+strtab_offset, dstSize );
1009       dst[dstSize-1] = 0;
1010    } else {
1011       int i = 0;
1012       while (1) {
1013          if (i >= 8) break;
1014          if (name[i] == 0) break;
1015          dst[i] = name[i];
1016          i++;
1017       }
1018       dst[i] = 0;
1019    }
1020 }
1021
1022
1023 static UChar *
1024 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1025 {
1026    UChar* newstr;
1027    /* If the string is longer than 8 bytes, look in the
1028       string table for it -- this will be correctly zero terminated.
1029    */
1030    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1031       UInt32 strtab_offset = * (UInt32*)(name+4);
1032       return ((UChar*)strtab) + strtab_offset;
1033    }
1034    /* Otherwise, if shorter than 8 bytes, return the original,
1035       which by defn is correctly terminated.
1036    */
1037    if (name[7]==0) return name;
1038    /* The annoying case: 8 bytes.  Copy into a temporary
1039       (which is never freed ...)
1040    */
1041    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1042    ASSERT(newstr);
1043    strncpy(newstr,name,8);
1044    newstr[8] = 0;
1045    return newstr;
1046 }
1047
1048
1049 /* Just compares the short names (first 8 chars) */
1050 static COFF_section *
1051 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1052 {
1053    int i;
1054    COFF_header* hdr
1055       = (COFF_header*)(oc->image);
1056    COFF_section* sectab
1057       = (COFF_section*) (
1058            ((UChar*)(oc->image))
1059            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1060         );
1061    for (i = 0; i < hdr->NumberOfSections; i++) {
1062       UChar* n1;
1063       UChar* n2;
1064       COFF_section* section_i
1065          = (COFF_section*)
1066            myindex ( sizeof_COFF_section, sectab, i );
1067       n1 = (UChar*) &(section_i->Name);
1068       n2 = name;
1069       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1070           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1071           n1[6]==n2[6] && n1[7]==n2[7])
1072          return section_i;
1073    }
1074
1075    return NULL;
1076 }
1077
1078
1079 static void
1080 zapTrailingAtSign ( UChar* sym )
1081 {
1082 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1083    int i, j;
1084    if (sym[0] == 0) return;
1085    i = 0;
1086    while (sym[i] != 0) i++;
1087    i--;
1088    j = i;
1089    while (j > 0 && my_isdigit(sym[j])) j--;
1090    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1091 #  undef my_isdigit
1092 }
1093
1094
1095 static int
1096 ocVerifyImage_PEi386 ( ObjectCode* oc )
1097 {
1098    int i;
1099    UInt32 j, noRelocs;
1100    COFF_header*  hdr;
1101    COFF_section* sectab;
1102    COFF_symbol*  symtab;
1103    UChar*        strtab;
1104    /* fprintf(stderr, "\nLOADING %s\n", oc->fileName); */
1105    hdr = (COFF_header*)(oc->image);
1106    sectab = (COFF_section*) (
1107                ((UChar*)(oc->image))
1108                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1109             );
1110    symtab = (COFF_symbol*) (
1111                ((UChar*)(oc->image))
1112                + hdr->PointerToSymbolTable
1113             );
1114    strtab = ((UChar*)symtab)
1115             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1116
1117    if (hdr->Machine != 0x14c) {
1118       belch("Not x86 PEi386");
1119       return 0;
1120    }
1121    if (hdr->SizeOfOptionalHeader != 0) {
1122       belch("PEi386 with nonempty optional header");
1123       return 0;
1124    }
1125    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1126         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1127         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1128         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1129       belch("Not a PEi386 object file");
1130       return 0;
1131    }
1132    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1133         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1134       belch("Invalid PEi386 word size or endiannness: %d",
1135             (int)(hdr->Characteristics));
1136       return 0;
1137    }
1138    /* If the string table size is way crazy, this might indicate that
1139       there are more than 64k relocations, despite claims to the
1140       contrary.  Hence this test. */
1141    /* fprintf(stderr, "strtab size %d\n", * (UInt32*)strtab); */
1142 #if 0
1143    if ( (*(UInt32*)strtab) > 600000 ) {
1144       /* Note that 600k has no special significance other than being
1145          big enough to handle the almost-2MB-sized lumps that
1146          constitute HSwin32*.o. */
1147       belch("PEi386 object has suspiciously large string table; > 64k relocs?");
1148       return 0;
1149    }
1150 #endif
1151
1152    /* No further verification after this point; only debug printing. */
1153    i = 0;
1154    IF_DEBUG(linker, i=1);
1155    if (i == 0) return 1;
1156
1157    fprintf ( stderr,
1158              "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1159    fprintf ( stderr,
1160              "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1161    fprintf ( stderr,
1162              "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1163
1164    fprintf ( stderr, "\n" );
1165    fprintf ( stderr,
1166              "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1167    fprintf ( stderr,
1168              "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1169    fprintf ( stderr,
1170              "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1171    fprintf ( stderr,
1172              "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1173    fprintf ( stderr,
1174              "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1175    fprintf ( stderr,
1176              "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1177    fprintf ( stderr,
1178              "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1179
1180    /* Print the section table. */
1181    fprintf ( stderr, "\n" );
1182    for (i = 0; i < hdr->NumberOfSections; i++) {
1183       COFF_reloc* reltab;
1184       COFF_section* sectab_i
1185          = (COFF_section*)
1186            myindex ( sizeof_COFF_section, sectab, i );
1187       fprintf ( stderr,
1188                 "\n"
1189                 "section %d\n"
1190                 "     name `",
1191                 i
1192               );
1193       printName ( sectab_i->Name, strtab );
1194       fprintf ( stderr,
1195                 "'\n"
1196                 "    vsize %d\n"
1197                 "    vaddr %d\n"
1198                 "  data sz %d\n"
1199                 " data off %d\n"
1200                 "  num rel %d\n"
1201                 "  off rel %d\n"
1202                 "  ptr raw 0x%x\n",
1203                 sectab_i->VirtualSize,
1204                 sectab_i->VirtualAddress,
1205                 sectab_i->SizeOfRawData,
1206                 sectab_i->PointerToRawData,
1207                 sectab_i->NumberOfRelocations,
1208                 sectab_i->PointerToRelocations,
1209                 sectab_i->PointerToRawData
1210               );
1211       reltab = (COFF_reloc*) (
1212                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1213                );
1214
1215       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1216         /* If the relocation field (a short) has overflowed, the
1217          * real count can be found in the first reloc entry.
1218          *
1219          * See Section 4.1 (last para) of the PE spec (rev6.0).
1220          */
1221         COFF_reloc* rel = (COFF_reloc*)
1222                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1223         noRelocs = rel->VirtualAddress;
1224         j = 1;
1225       } else {
1226         noRelocs = sectab_i->NumberOfRelocations;
1227         j = 0;
1228       }
1229
1230       for (; j < noRelocs; j++) {
1231          COFF_symbol* sym;
1232          COFF_reloc* rel = (COFF_reloc*)
1233                            myindex ( sizeof_COFF_reloc, reltab, j );
1234          fprintf ( stderr,
1235                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1236                    (UInt32)rel->Type,
1237                    rel->VirtualAddress );
1238          sym = (COFF_symbol*)
1239                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1240          /* Hmm..mysterious looking offset - what's it for? SOF */
1241          printName ( sym->Name, strtab -10 );
1242          fprintf ( stderr, "'\n" );
1243       }
1244
1245       fprintf ( stderr, "\n" );
1246    }
1247    fprintf ( stderr, "\n" );
1248    fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
1249    fprintf ( stderr, "---START of string table---\n");
1250    for (i = 4; i < *(Int32*)strtab; i++) {
1251       if (strtab[i] == 0)
1252          fprintf ( stderr, "\n"); else
1253          fprintf( stderr, "%c", strtab[i] );
1254    }
1255    fprintf ( stderr, "--- END  of string table---\n");
1256
1257    fprintf ( stderr, "\n" );
1258    i = 0;
1259    while (1) {
1260       COFF_symbol* symtab_i;
1261       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1262       symtab_i = (COFF_symbol*)
1263                  myindex ( sizeof_COFF_symbol, symtab, i );
1264       fprintf ( stderr,
1265                 "symbol %d\n"
1266                 "     name `",
1267                 i
1268               );
1269       printName ( symtab_i->Name, strtab );
1270       fprintf ( stderr,
1271                 "'\n"
1272                 "    value 0x%x\n"
1273                 "   1+sec# %d\n"
1274                 "     type 0x%x\n"
1275                 "   sclass 0x%x\n"
1276                 "     nAux %d\n",
1277                 symtab_i->Value,
1278                 (Int32)(symtab_i->SectionNumber),
1279                 (UInt32)symtab_i->Type,
1280                 (UInt32)symtab_i->StorageClass,
1281                 (UInt32)symtab_i->NumberOfAuxSymbols
1282               );
1283       i += symtab_i->NumberOfAuxSymbols;
1284       i++;
1285    }
1286
1287    fprintf ( stderr, "\n" );
1288    return 1;
1289 }
1290
1291
1292 static int
1293 ocGetNames_PEi386 ( ObjectCode* oc )
1294 {
1295    COFF_header*  hdr;
1296    COFF_section* sectab;
1297    COFF_symbol*  symtab;
1298    UChar*        strtab;
1299
1300    UChar* sname;
1301    void*  addr;
1302    int    i;
1303
1304    hdr = (COFF_header*)(oc->image);
1305    sectab = (COFF_section*) (
1306                ((UChar*)(oc->image))
1307                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1308             );
1309    symtab = (COFF_symbol*) (
1310                ((UChar*)(oc->image))
1311                + hdr->PointerToSymbolTable
1312             );
1313    strtab = ((UChar*)(oc->image))
1314             + hdr->PointerToSymbolTable
1315             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1316
1317    /* Allocate space for any (local, anonymous) .bss sections. */
1318
1319    for (i = 0; i < hdr->NumberOfSections; i++) {
1320       UChar* zspace;
1321       COFF_section* sectab_i
1322          = (COFF_section*)
1323            myindex ( sizeof_COFF_section, sectab, i );
1324       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1325       if (sectab_i->VirtualSize == 0) continue;
1326       /* This is a non-empty .bss section.  Allocate zeroed space for
1327          it, and set its PointerToRawData field such that oc->image +
1328          PointerToRawData == addr_of_zeroed_space.  */
1329       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1330                               "ocGetNames_PEi386(anonymous bss)");
1331       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1332       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1333       /* fprintf(stderr, "BSS anon section at 0x%x\n", zspace); */
1334    }
1335
1336    /* Copy section information into the ObjectCode. */
1337
1338    for (i = 0; i < hdr->NumberOfSections; i++) {
1339       UChar* start;
1340       UChar* end;
1341       UInt32 sz;
1342
1343       SectionKind kind
1344          = SECTIONKIND_OTHER;
1345       COFF_section* sectab_i
1346          = (COFF_section*)
1347            myindex ( sizeof_COFF_section, sectab, i );
1348       IF_DEBUG(linker, belch("section name = %s\n", sectab_i->Name ));
1349
1350 #     if 0
1351       /* I'm sure this is the Right Way to do it.  However, the
1352          alternative of testing the sectab_i->Name field seems to
1353          work ok with Cygwin.
1354       */
1355       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1356           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1357          kind = SECTIONKIND_CODE_OR_RODATA;
1358 #     endif
1359
1360       if (0==strcmp(".text",sectab_i->Name) ||
1361           0==strcmp(".rodata",sectab_i->Name))
1362          kind = SECTIONKIND_CODE_OR_RODATA;
1363       if (0==strcmp(".data",sectab_i->Name) ||
1364           0==strcmp(".bss",sectab_i->Name))
1365          kind = SECTIONKIND_RWDATA;
1366
1367       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
1368       sz = sectab_i->SizeOfRawData;
1369       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
1370
1371       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
1372       end   = start + sz - 1;
1373
1374       if (kind == SECTIONKIND_OTHER
1375           /* Ignore sections called which contain stabs debugging
1376              information. */
1377           && 0 != strcmp(".stab", sectab_i->Name)
1378           && 0 != strcmp(".stabstr", sectab_i->Name)
1379          ) {
1380          belch("Unknown PEi386 section name `%s'", sectab_i->Name);
1381          return 0;
1382       }
1383
1384       if (kind != SECTIONKIND_OTHER && end >= start) {
1385          addSection(oc, kind, start, end);
1386          addProddableBlock(oc, start, end - start + 1);
1387       }
1388    }
1389
1390    /* Copy exported symbols into the ObjectCode. */
1391
1392    oc->n_symbols = hdr->NumberOfSymbols;
1393    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
1394                                   "ocGetNames_PEi386(oc->symbols)");
1395    /* Call me paranoid; I don't care. */
1396    for (i = 0; i < oc->n_symbols; i++)
1397       oc->symbols[i] = NULL;
1398
1399    i = 0;
1400    while (1) {
1401       COFF_symbol* symtab_i;
1402       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1403       symtab_i = (COFF_symbol*)
1404                  myindex ( sizeof_COFF_symbol, symtab, i );
1405
1406       addr  = NULL;
1407
1408       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
1409           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
1410          /* This symbol is global and defined, viz, exported */
1411          /* for MYIMAGE_SYMCLASS_EXTERNAL
1412                 && !MYIMAGE_SYM_UNDEFINED,
1413             the address of the symbol is:
1414                 address of relevant section + offset in section
1415          */
1416          COFF_section* sectabent
1417             = (COFF_section*) myindex ( sizeof_COFF_section,
1418                                         sectab,
1419                                         symtab_i->SectionNumber-1 );
1420          addr = ((UChar*)(oc->image))
1421                 + (sectabent->PointerToRawData
1422                    + symtab_i->Value);
1423       }
1424       else
1425       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
1426           && symtab_i->Value > 0) {
1427          /* This symbol isn't in any section at all, ie, global bss.
1428             Allocate zeroed space for it. */
1429          addr = stgCallocBytes(1, symtab_i->Value,
1430                                "ocGetNames_PEi386(non-anonymous bss)");
1431          addSection(oc, SECTIONKIND_RWDATA, addr,
1432                         ((UChar*)addr) + symtab_i->Value - 1);
1433          addProddableBlock(oc, addr, symtab_i->Value);
1434          /* fprintf(stderr, "BSS      section at 0x%x\n", addr); */
1435       }
1436
1437       if (addr != NULL ) {
1438          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
1439          /* fprintf(stderr,"addSymbol %p `%s \n", addr,sname);  */
1440          IF_DEBUG(linker, belch("addSymbol %p `%s'\n", addr,sname);)
1441          ASSERT(i >= 0 && i < oc->n_symbols);
1442          /* cstring_from_COFF_symbol_name always succeeds. */
1443          oc->symbols[i] = sname;
1444          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
1445       } else {
1446 #        if 0
1447          fprintf ( stderr,
1448                    "IGNORING symbol %d\n"
1449                    "     name `",
1450                    i
1451                  );
1452          printName ( symtab_i->Name, strtab );
1453          fprintf ( stderr,
1454                    "'\n"
1455                    "    value 0x%x\n"
1456                    "   1+sec# %d\n"
1457                    "     type 0x%x\n"
1458                    "   sclass 0x%x\n"
1459                    "     nAux %d\n",
1460                    symtab_i->Value,
1461                    (Int32)(symtab_i->SectionNumber),
1462                    (UInt32)symtab_i->Type,
1463                    (UInt32)symtab_i->StorageClass,
1464                    (UInt32)symtab_i->NumberOfAuxSymbols
1465                  );
1466 #        endif
1467       }
1468
1469       i += symtab_i->NumberOfAuxSymbols;
1470       i++;
1471    }
1472
1473    return 1;
1474 }
1475
1476
1477 static int
1478 ocResolve_PEi386 ( ObjectCode* oc )
1479 {
1480    COFF_header*  hdr;
1481    COFF_section* sectab;
1482    COFF_symbol*  symtab;
1483    UChar*        strtab;
1484
1485    UInt32        A;
1486    UInt32        S;
1487    UInt32*       pP;
1488
1489    int i;
1490    UInt32 j, noRelocs;
1491
1492    /* ToDo: should be variable-sized?  But is at least safe in the
1493       sense of buffer-overrun-proof. */
1494    char symbol[1000];
1495    /* fprintf(stderr, "resolving for %s\n", oc->fileName); */
1496
1497    hdr = (COFF_header*)(oc->image);
1498    sectab = (COFF_section*) (
1499                ((UChar*)(oc->image))
1500                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1501             );
1502    symtab = (COFF_symbol*) (
1503                ((UChar*)(oc->image))
1504                + hdr->PointerToSymbolTable
1505             );
1506    strtab = ((UChar*)(oc->image))
1507             + hdr->PointerToSymbolTable
1508             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1509
1510    for (i = 0; i < hdr->NumberOfSections; i++) {
1511       COFF_section* sectab_i
1512          = (COFF_section*)
1513            myindex ( sizeof_COFF_section, sectab, i );
1514       COFF_reloc* reltab
1515          = (COFF_reloc*) (
1516               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1517            );
1518
1519       /* Ignore sections called which contain stabs debugging
1520          information. */
1521       if (0 == strcmp(".stab", sectab_i->Name)
1522           || 0 == strcmp(".stabstr", sectab_i->Name))
1523          continue;
1524
1525       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1526         /* If the relocation field (a short) has overflowed, the
1527          * real count can be found in the first reloc entry.
1528          *
1529          * See Section 4.1 (last para) of the PE spec (rev6.0).
1530          */
1531         COFF_reloc* rel = (COFF_reloc*)
1532                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1533         noRelocs = rel->VirtualAddress;
1534         fprintf(stderr, "Overflown relocs: %u\n", noRelocs);
1535         j = 1;
1536       } else {
1537         noRelocs = sectab_i->NumberOfRelocations;
1538         j = 0;
1539       }
1540
1541
1542       for (; j < noRelocs; j++) {
1543          COFF_symbol* sym;
1544          COFF_reloc* reltab_j
1545             = (COFF_reloc*)
1546               myindex ( sizeof_COFF_reloc, reltab, j );
1547
1548          /* the location to patch */
1549          pP = (UInt32*)(
1550                  ((UChar*)(oc->image))
1551                  + (sectab_i->PointerToRawData
1552                     + reltab_j->VirtualAddress
1553                     - sectab_i->VirtualAddress )
1554               );
1555          /* the existing contents of pP */
1556          A = *pP;
1557          /* the symbol to connect to */
1558          sym = (COFF_symbol*)
1559                myindex ( sizeof_COFF_symbol,
1560                          symtab, reltab_j->SymbolTableIndex );
1561          IF_DEBUG(linker,
1562                   fprintf ( stderr,
1563                             "reloc sec %2d num %3d:  type 0x%-4x   "
1564                             "vaddr 0x%-8x   name `",
1565                             i, j,
1566                             (UInt32)reltab_j->Type,
1567                             reltab_j->VirtualAddress );
1568                             printName ( sym->Name, strtab );
1569                             fprintf ( stderr, "'\n" ));
1570
1571          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1572             COFF_section* section_sym
1573                = findPEi386SectionCalled ( oc, sym->Name );
1574             if (!section_sym) {
1575                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
1576                return 0;
1577             }
1578             S = ((UInt32)(oc->image))
1579                 + (section_sym->PointerToRawData
1580                    + sym->Value);
1581          } else {
1582             copyName ( sym->Name, strtab, symbol, 1000-1 );
1583             (void*)S = lookupLocalSymbol( oc, symbol );
1584             if ((void*)S != NULL) goto foundit;
1585             (void*)S = lookupSymbol( symbol );
1586             if ((void*)S != NULL) goto foundit;
1587             zapTrailingAtSign ( symbol );
1588             (void*)S = lookupLocalSymbol( oc, symbol );
1589             if ((void*)S != NULL) goto foundit;
1590             (void*)S = lookupSymbol( symbol );
1591             if ((void*)S != NULL) goto foundit;
1592             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
1593             return 0;
1594            foundit:
1595          }
1596          checkProddableBlock(oc, pP);
1597          switch (reltab_j->Type) {
1598             case MYIMAGE_REL_I386_DIR32:
1599                *pP = A + S;
1600                break;
1601             case MYIMAGE_REL_I386_REL32:
1602                /* Tricky.  We have to insert a displacement at
1603                   pP which, when added to the PC for the _next_
1604                   insn, gives the address of the target (S).
1605                   Problem is to know the address of the next insn
1606                   when we only know pP.  We assume that this
1607                   literal field is always the last in the insn,
1608                   so that the address of the next insn is pP+4
1609                   -- hence the constant 4.
1610                   Also I don't know if A should be added, but so
1611                   far it has always been zero.
1612                */
1613                ASSERT(A==0);
1614                *pP = S - ((UInt32)pP) - 4;
1615                break;
1616             default:
1617                belch("%s: unhandled PEi386 relocation type %d",
1618                      oc->fileName, reltab_j->Type);
1619                return 0;
1620          }
1621
1622       }
1623    }
1624
1625    IF_DEBUG(linker, belch("completed %s", oc->fileName));
1626    return 1;
1627 }
1628
1629 #endif /* defined(OBJFORMAT_PEi386) */
1630
1631
1632 /* --------------------------------------------------------------------------
1633  * ELF specifics
1634  * ------------------------------------------------------------------------*/
1635
1636 #if defined(OBJFORMAT_ELF)
1637
1638 #define FALSE 0
1639 #define TRUE  1
1640
1641 #if defined(sparc_TARGET_ARCH)
1642 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
1643 #elif defined(i386_TARGET_ARCH)
1644 #  define ELF_TARGET_386    /* Used inside <elf.h> */
1645 #endif
1646 /* There is a similar case for IA64 in the Solaris2 headers if this
1647  * ever becomes relevant.
1648  */
1649
1650 #include <elf.h>
1651 #include <ctype.h>
1652
1653 static char *
1654 findElfSection ( void* objImage, Elf32_Word sh_type )
1655 {
1656    int i;
1657    char* ehdrC = (char*)objImage;
1658    Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
1659    Elf32_Shdr* shdr = (Elf32_Shdr*)(ehdrC + ehdr->e_shoff);
1660    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1661    char* ptr = NULL;
1662    for (i = 0; i < ehdr->e_shnum; i++) {
1663       if (shdr[i].sh_type == sh_type
1664           /* Ignore the section header's string table. */
1665           && i != ehdr->e_shstrndx
1666           /* Ignore string tables named .stabstr, as they contain
1667              debugging info. */
1668           && 0 != strncmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
1669          ) {
1670          ptr = ehdrC + shdr[i].sh_offset;
1671          break;
1672       }
1673    }
1674    return ptr;
1675 }
1676
1677
1678 static int
1679 ocVerifyImage_ELF ( ObjectCode* oc )
1680 {
1681    Elf32_Shdr* shdr;
1682    Elf32_Sym*  stab;
1683    int i, j, nent, nstrtab, nsymtabs;
1684    char* sh_strtab;
1685    char* strtab;
1686
1687    char*       ehdrC = (char*)(oc->image);
1688    Elf32_Ehdr* ehdr  = ( Elf32_Ehdr*)ehdrC;
1689
1690    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1691        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1692        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1693        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1694       belch("%s: not an ELF header", oc->fileName);
1695       return 0;
1696    }
1697    IF_DEBUG(linker,belch( "Is an ELF header" ));
1698
1699    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1700       belch("%s: not 32 bit ELF", oc->fileName);
1701       return 0;
1702    }
1703
1704    IF_DEBUG(linker,belch( "Is 32 bit ELF" ));
1705
1706    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1707        IF_DEBUG(linker,belch( "Is little-endian" ));
1708    } else
1709    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1710        IF_DEBUG(linker,belch( "Is big-endian" ));
1711    } else {
1712        belch("%s: unknown endiannness", oc->fileName);
1713        return 0;
1714    }
1715
1716    if (ehdr->e_type != ET_REL) {
1717       belch("%s: not a relocatable object (.o) file", oc->fileName);
1718       return 0;
1719    }
1720    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
1721
1722    IF_DEBUG(linker,belch( "Architecture is " ));
1723    switch (ehdr->e_machine) {
1724       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
1725       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
1726       default:       IF_DEBUG(linker,belch( "unknown" ));
1727                      belch("%s: unknown architecture", oc->fileName);
1728                      return 0;
1729    }
1730
1731    IF_DEBUG(linker,belch(
1732              "\nSection header table: start %d, n_entries %d, ent_size %d",
1733              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
1734
1735    ASSERT (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1736
1737    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1738
1739    if (ehdr->e_shstrndx == SHN_UNDEF) {
1740       belch("%s: no section header string table", oc->fileName);
1741       return 0;
1742    } else {
1743       IF_DEBUG(linker,belch( "Section header string table is section %d",
1744                           ehdr->e_shstrndx));
1745       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1746    }
1747
1748    for (i = 0; i < ehdr->e_shnum; i++) {
1749       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
1750       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
1751       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
1752       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
1753       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
1754                ehdrC + shdr[i].sh_offset,
1755                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
1756
1757       if (shdr[i].sh_type == SHT_REL) {
1758           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
1759       } else if (shdr[i].sh_type == SHT_RELA) {
1760           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
1761       } else {
1762           IF_DEBUG(linker,fprintf(stderr,"     "));
1763       }
1764       if (sh_strtab) {
1765           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
1766       }
1767    }
1768
1769    IF_DEBUG(linker,belch( "\nString tables" ));
1770    strtab = NULL;
1771    nstrtab = 0;
1772    for (i = 0; i < ehdr->e_shnum; i++) {
1773       if (shdr[i].sh_type == SHT_STRTAB
1774           /* Ignore the section header's string table. */
1775           && i != ehdr->e_shstrndx
1776           /* Ignore string tables named .stabstr, as they contain
1777              debugging info. */
1778           && 0 != strncmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
1779          ) {
1780          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
1781          strtab = ehdrC + shdr[i].sh_offset;
1782          nstrtab++;
1783       }
1784    }
1785    if (nstrtab != 1) {
1786       belch("%s: no string tables, or too many", oc->fileName);
1787       return 0;
1788    }
1789
1790    nsymtabs = 0;
1791    IF_DEBUG(linker,belch( "\nSymbol tables" ));
1792    for (i = 0; i < ehdr->e_shnum; i++) {
1793       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1794       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
1795       nsymtabs++;
1796       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1797       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1798       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
1799                nent,
1800                shdr[i].sh_size % sizeof(Elf32_Sym)
1801              ));
1802       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1803          belch("%s: non-integral number of symbol table entries", oc->fileName);
1804          return 0;
1805       }
1806       for (j = 0; j < nent; j++) {
1807          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
1808          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
1809                              (int)stab[j].st_shndx,
1810                              (int)stab[j].st_size,
1811                              (char*)stab[j].st_value ));
1812
1813          IF_DEBUG(linker,fprintf(stderr, "type=" ));
1814          switch (ELF32_ST_TYPE(stab[j].st_info)) {
1815             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
1816             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
1817             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
1818             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
1819             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
1820             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
1821          }
1822          IF_DEBUG(linker,fprintf(stderr, "  " ));
1823
1824          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
1825          switch (ELF32_ST_BIND(stab[j].st_info)) {
1826             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
1827             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
1828             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
1829             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
1830          }
1831          IF_DEBUG(linker,fprintf(stderr, "  " ));
1832
1833          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
1834       }
1835    }
1836
1837    if (nsymtabs == 0) {
1838       belch("%s: didn't find any symbol tables", oc->fileName);
1839       return 0;
1840    }
1841
1842    return 1;
1843 }
1844
1845
1846 static int
1847 ocGetNames_ELF ( ObjectCode* oc )
1848 {
1849    int i, j, k, nent;
1850    Elf32_Sym* stab;
1851
1852    char*       ehdrC      = (char*)(oc->image);
1853    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
1854    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
1855    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1856
1857    ASSERT(symhash != NULL);
1858
1859    if (!strtab) {
1860       belch("%s: no strtab", oc->fileName);
1861       return 0;
1862    }
1863
1864    k = 0;
1865    for (i = 0; i < ehdr->e_shnum; i++) {
1866       /* Figure out what kind of section it is.  Logic derived from
1867          Figure 1.14 ("Special Sections") of the ELF document
1868          ("Portable Formats Specification, Version 1.1"). */
1869       Elf32_Shdr  hdr    = shdr[i];
1870       SectionKind kind   = SECTIONKIND_OTHER;
1871       int         is_bss = FALSE;
1872
1873       if (hdr.sh_type == SHT_PROGBITS
1874           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_EXECINSTR)) {
1875          /* .text-style section */
1876          kind = SECTIONKIND_CODE_OR_RODATA;
1877       }
1878       else
1879       if (hdr.sh_type == SHT_PROGBITS
1880           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
1881          /* .data-style section */
1882          kind = SECTIONKIND_RWDATA;
1883       }
1884       else
1885       if (hdr.sh_type == SHT_PROGBITS
1886           && (hdr.sh_flags & SHF_ALLOC) && !(hdr.sh_flags & SHF_WRITE)) {
1887          /* .rodata-style section */
1888          kind = SECTIONKIND_CODE_OR_RODATA;
1889       }
1890       else
1891       if (hdr.sh_type == SHT_NOBITS
1892           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
1893          /* .bss-style section */
1894          kind = SECTIONKIND_RWDATA;
1895          is_bss = TRUE;
1896       }
1897
1898       if (is_bss && shdr[i].sh_size > 0) {
1899          /* This is a non-empty .bss section.  Allocate zeroed space for
1900             it, and set its .sh_offset field such that
1901             ehdrC + .sh_offset == addr_of_zeroed_space.  */
1902          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
1903                                        "ocGetNames_ELF(BSS)");
1904          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
1905          /*
1906          fprintf(stderr, "BSS section at 0x%x, size %d\n",
1907                          zspace, shdr[i].sh_size);
1908          */
1909       }
1910
1911       /* fill in the section info */
1912       addSection(oc, kind, ehdrC + shdr[i].sh_offset,
1913                      ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1914       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0)
1915          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
1916
1917       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1918
1919       /* copy stuff into this module's object symbol table */
1920       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1921       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1922
1923       oc->n_symbols = nent;
1924       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
1925                                    "ocGetNames_ELF(oc->symbols)");
1926
1927       for (j = 0; j < nent; j++) {
1928
1929          char  isLocal = FALSE; /* avoids uninit-var warning */
1930          char* ad      = NULL;
1931          char* nm      = strtab + stab[j].st_name;
1932          int   secno   = stab[j].st_shndx;
1933
1934          /* Figure out if we want to add it; if so, set ad to its
1935             address.  Otherwise leave ad == NULL. */
1936
1937          if (secno == SHN_COMMON) {
1938             isLocal = FALSE;
1939             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
1940             /*
1941             fprintf(stderr, "COMMON symbol, size %d name %s\n",
1942                             stab[j].st_size, nm);
1943             */
1944             /* Pointless to do addProddableBlock() for this area,
1945                since the linker should never poke around in it. */
1946          }
1947          else
1948          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL
1949                 || ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1950               )
1951               /* and not an undefined symbol */
1952               && stab[j].st_shndx != SHN_UNDEF
1953               /* and not in a "special section" */
1954               && stab[j].st_shndx < SHN_LORESERVE
1955               &&
1956               /* and it's a not a section or string table or anything silly */
1957               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1958                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
1959                 ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE
1960               )
1961             ) {
1962             /* Section 0 is the undefined section, hence > and not >=. */
1963             ASSERT(secno > 0 && secno < ehdr->e_shnum);
1964             /*
1965             if (shdr[secno].sh_type == SHT_NOBITS) {
1966                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
1967                                stab[j].st_size, stab[j].st_value, nm);
1968             }
1969             */
1970             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
1971             if (ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL) {
1972                isLocal = TRUE;
1973             } else {
1974                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
1975                                       ad, oc->fileName, nm ));
1976                isLocal = FALSE;
1977             }
1978          }
1979
1980          /* And the decision is ... */
1981
1982          if (ad != NULL) {
1983             ASSERT(nm != NULL);
1984             oc->symbols[j] = nm;
1985             /* Acquire! */
1986             if (isLocal) {
1987                /* Ignore entirely. */
1988             } else {
1989                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
1990             }
1991          } else {
1992             /* Skip. */
1993             IF_DEBUG(linker,belch( "skipping `%s'",
1994                                    strtab + stab[j].st_name ));
1995             /*
1996             fprintf(stderr,
1997                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
1998                     (int)ELF32_ST_BIND(stab[j].st_info),
1999                     (int)ELF32_ST_TYPE(stab[j].st_info),
2000                     (int)stab[j].st_shndx,
2001                     strtab + stab[j].st_name
2002                    );
2003             */
2004             oc->symbols[j] = NULL;
2005          }
2006
2007       }
2008    }
2009
2010    return 1;
2011 }
2012
2013
2014 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2015    relocations appear to be of this form. */
2016 static int
2017 do_Elf32_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2018                            Elf32_Shdr* shdr, int shnum,
2019                            Elf32_Sym*  stab, char* strtab )
2020 {
2021    int j;
2022    char *symbol;
2023    Elf32_Word* targ;
2024    Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[shnum].sh_offset);
2025    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rel);
2026    int target_shndx = shdr[shnum].sh_info;
2027    int symtab_shndx = shdr[shnum].sh_link;
2028    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2029    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2030    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2031                           target_shndx, symtab_shndx ));
2032    for (j = 0; j < nent; j++) {
2033       Elf32_Addr offset = rtab[j].r_offset;
2034       Elf32_Word info   = rtab[j].r_info;
2035
2036       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
2037       Elf32_Word* pP = (Elf32_Word*)P;
2038       Elf32_Addr  A  = *pP;
2039       Elf32_Addr  S;
2040
2041       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
2042                              j, (void*)offset, (void*)info ));
2043       if (!info) {
2044          IF_DEBUG(linker,belch( " ZERO" ));
2045          S = 0;
2046       } else {
2047          Elf32_Sym sym = stab[ELF32_R_SYM(info)];
2048          /* First see if it is a local symbol. */
2049          if (ELF32_ST_BIND(sym.st_info) == STB_LOCAL) {
2050             /* Yes, so we can get the address directly from the ELF symbol
2051                table. */
2052             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2053             S = (Elf32_Addr)
2054                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2055                        + stab[ELF32_R_SYM(info)].st_value);
2056
2057          } else {
2058             /* No, so look up the name in our global table. */
2059             symbol = strtab + sym.st_name;
2060             (void*)S = lookupSymbol( symbol );
2061          }
2062          if (!S) {
2063             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2064             return 0;
2065          }
2066          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2067       }
2068       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2069                              (void*)P, (void*)S, (void*)A ));
2070       checkProddableBlock ( oc, pP );
2071       switch (ELF32_R_TYPE(info)) {
2072 #        ifdef i386_TARGET_ARCH
2073          case R_386_32:   *pP = S + A;     break;
2074          case R_386_PC32: *pP = S + A - P; break;
2075 #        endif
2076          default:
2077             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2078                   oc->fileName, ELF32_R_TYPE(info));
2079             return 0;
2080       }
2081
2082    }
2083    return 1;
2084 }
2085
2086
2087 /* Do ELF relocations for which explicit addends are supplied.
2088    sparc-solaris relocations appear to be of this form. */
2089 static int
2090 do_Elf32_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2091                             Elf32_Shdr* shdr, int shnum,
2092                             Elf32_Sym*  stab, char* strtab )
2093 {
2094    int j;
2095    char *symbol;
2096    Elf32_Word* targ;
2097    Elf32_Rela* rtab = (Elf32_Rela*) (ehdrC + shdr[shnum].sh_offset);
2098    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rela);
2099    int target_shndx = shdr[shnum].sh_info;
2100    int symtab_shndx = shdr[shnum].sh_link;
2101    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2102    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2103    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2104                           target_shndx, symtab_shndx ));
2105    for (j = 0; j < nent; j++) {
2106       Elf32_Addr  offset = rtab[j].r_offset;
2107       Elf32_Word  info   = rtab[j].r_info;
2108       Elf32_Sword addend = rtab[j].r_addend;
2109       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
2110       Elf32_Addr  A  = addend; /* Do not delete this; it is used on sparc. */
2111       Elf32_Addr  S;
2112 #     if defined(sparc_TARGET_ARCH)
2113       /* This #ifdef only serves to avoid unused-var warnings. */
2114       Elf32_Word* pP = (Elf32_Word*)P;
2115       Elf32_Word  w1, w2;
2116 #     endif
2117
2118       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2119                              j, (void*)offset, (void*)info,
2120                                 (void*)addend ));
2121       if (!info) {
2122          IF_DEBUG(linker,belch( " ZERO" ));
2123          S = 0;
2124       } else {
2125          Elf32_Sym sym = stab[ELF32_R_SYM(info)];
2126          /* First see if it is a local symbol. */
2127          if (ELF32_ST_BIND(sym.st_info) == STB_LOCAL) {
2128             /* Yes, so we can get the address directly from the ELF symbol
2129                table. */
2130             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2131             S = (Elf32_Addr)
2132                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2133                        + stab[ELF32_R_SYM(info)].st_value);
2134
2135          } else {
2136             /* No, so look up the name in our global table. */
2137             symbol = strtab + sym.st_name;
2138             (void*)S = lookupSymbol( symbol );
2139          }
2140          if (!S) {
2141            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2142            return 0;
2143            /*
2144            S = 0x11223344;
2145            fprintf ( stderr, "S %p A %p S+A %p S+A-P %p\n",S,A,S+A,S+A-P);
2146            */
2147          }
2148          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2149       }
2150       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2151                                         (void*)P, (void*)S, (void*)A ));
2152       checkProddableBlock ( oc, (void*)P );
2153       switch (ELF32_R_TYPE(info)) {
2154 #        if defined(sparc_TARGET_ARCH)
2155          case R_SPARC_WDISP30:
2156             w1 = *pP & 0xC0000000;
2157             w2 = (Elf32_Word)((S + A - P) >> 2);
2158             ASSERT((w2 & 0xC0000000) == 0);
2159             w1 |= w2;
2160             *pP = w1;
2161             break;
2162          case R_SPARC_HI22:
2163             w1 = *pP & 0xFFC00000;
2164             w2 = (Elf32_Word)((S + A) >> 10);
2165             ASSERT((w2 & 0xFFC00000) == 0);
2166             w1 |= w2;
2167             *pP = w1;
2168             break;
2169          case R_SPARC_LO10:
2170             w1 = *pP & ~0x3FF;
2171             w2 = (Elf32_Word)((S + A) & 0x3FF);
2172             ASSERT((w2 & ~0x3FF) == 0);
2173             w1 |= w2;
2174             *pP = w1;
2175             break;
2176          /* According to the Sun documentation:
2177             R_SPARC_UA32
2178             This relocation type resembles R_SPARC_32, except it refers to an
2179             unaligned word. That is, the word to be relocated must be treated
2180             as four separate bytes with arbitrary alignment, not as a word
2181             aligned according to the architecture requirements.
2182
2183             (JRS: which means that freeloading on the R_SPARC_32 case
2184             is probably wrong, but hey ...)
2185          */
2186          case R_SPARC_UA32:
2187          case R_SPARC_32:
2188             w2 = (Elf32_Word)(S + A);
2189             *pP = w2;
2190             break;
2191 #        endif
2192          default:
2193             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2194                   oc->fileName, ELF32_R_TYPE(info));
2195             return 0;
2196       }
2197
2198    }
2199    return 1;
2200 }
2201
2202
2203 static int
2204 ocResolve_ELF ( ObjectCode* oc )
2205 {
2206    char *strtab;
2207    int   shnum, ok;
2208    Elf32_Sym*  stab = NULL;
2209    char*       ehdrC = (char*)(oc->image);
2210    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
2211    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2212    char* sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2213
2214    /* first find "the" symbol table */
2215    stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2216
2217    /* also go find the string table */
2218    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2219
2220    if (stab == NULL || strtab == NULL) {
2221       belch("%s: can't find string or symbol table", oc->fileName);
2222       return 0;
2223    }
2224
2225    /* Process the relocation sections. */
2226    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2227
2228       /* Skip sections called ".rel.stab".  These appear to contain
2229          relocation entries that, when done, make the stabs debugging
2230          info point at the right places.  We ain't interested in all
2231          dat jazz, mun. */
2232       if (0 == strncmp(".rel.stab", sh_strtab + shdr[shnum].sh_name, 9))
2233          continue;
2234
2235       if (shdr[shnum].sh_type == SHT_REL ) {
2236          ok = do_Elf32_Rel_relocations ( oc, ehdrC, shdr,
2237                                          shnum, stab, strtab );
2238          if (!ok) return ok;
2239       }
2240       else
2241       if (shdr[shnum].sh_type == SHT_RELA) {
2242          ok = do_Elf32_Rela_relocations ( oc, ehdrC, shdr,
2243                                           shnum, stab, strtab );
2244          if (!ok) return ok;
2245       }
2246
2247    }
2248
2249    /* Free the local symbol table; we won't need it again. */
2250    freeHashTable(oc->lochash, NULL);
2251    oc->lochash = NULL;
2252
2253    return 1;
2254 }
2255
2256
2257 #endif /* ELF */