ghc/rts/Linker.c

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