ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Linker.c,v 1.81 2002/02/01 02:05:52 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    It can be found there (on older CDs), but can also be found
 875    online at:
 876
 877       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
 878
 879    (this is Rev 6.0 from February 1999).
 880
 881    Things move, so if that fails, try searching for it via
 882
 883       http://www.google.com/search?q=PE+COFF+specification
 884
 885    The ultimate reference for the PE format is the Winnt.h
 886    header file that comes with the Platform SDKs; as always,
 887    implementations will drift wrt their documentation.
 888
 889    A good background article on the PE format is Matt Pietrek's
 890    March 1994 article in Microsoft System Journal (MSJ)
 891    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
 892    Win32 Portable Executable File Format." The info in there
 893    has recently been updated in a two part article in
 894    MSDN magazine, issues Feb and March 2002,
 895    "Inside Windows: An In-Depth Look into the Win32 Portable
 896    Executable File Format"
 897
 898    John Levine's book "Linkers and Loaders" contains useful
 899    info on PE too.
 900 */
 901
 902
 903 #if defined(OBJFORMAT_PEi386)
 904
 905
 906
 907 typedef unsigned char  UChar;
 908 typedef unsigned short UInt16;
 909 typedef unsigned int   UInt32;
 910 typedef          int   Int32;
 911
 912
 913 typedef
 914    struct {
 915       UInt16 Machine;
 916       UInt16 NumberOfSections;
 917       UInt32 TimeDateStamp;
 918       UInt32 PointerToSymbolTable;
 919       UInt32 NumberOfSymbols;
 920       UInt16 SizeOfOptionalHeader;
 921       UInt16 Characteristics;
 922    }
 923    COFF_header;
 924
 925 #define sizeof_COFF_header 20
 926
 927
 928 typedef
 929    struct {
 930       UChar  Name[8];
 931       UInt32 VirtualSize;
 932       UInt32 VirtualAddress;
 933       UInt32 SizeOfRawData;
 934       UInt32 PointerToRawData;
 935       UInt32 PointerToRelocations;
 936       UInt32 PointerToLinenumbers;
 937       UInt16 NumberOfRelocations;
 938       UInt16 NumberOfLineNumbers;
 939       UInt32 Characteristics;
 940    }
 941    COFF_section;
 942
 943 #define sizeof_COFF_section 40
 944
 945
 946 typedef
 947    struct {
 948       UChar  Name[8];
 949       UInt32 Value;
 950       UInt16 SectionNumber;
 951       UInt16 Type;
 952       UChar  StorageClass;
 953       UChar  NumberOfAuxSymbols;
 954    }
 955    COFF_symbol;
 956
 957 #define sizeof_COFF_symbol 18
 958
 959
 960 typedef
 961    struct {
 962       UInt32 VirtualAddress;
 963       UInt32 SymbolTableIndex;
 964       UInt16 Type;
 965    }
 966    COFF_reloc;
 967
 968 #define sizeof_COFF_reloc 10
 969
 970
 971 /* From PE spec doc, section 3.3.2 */
 972 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
 973    windows.h -- for the same purpose, but I want to know what I'm
 974    getting, here. */
 975 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
 976 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
 977 #define MYIMAGE_FILE_DLL                 0x2000
 978 #define MYIMAGE_FILE_SYSTEM              0x1000
 979 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
 980 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
 981 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
 982
 983 /* From PE spec doc, section 5.4.2 and 5.4.4 */
 984 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
 985 #define MYIMAGE_SYM_CLASS_STATIC         3
 986 #define MYIMAGE_SYM_UNDEFINED            0
 987
 988 /* From PE spec doc, section 4.1 */
 989 #define MYIMAGE_SCN_CNT_CODE             0x00000020
 990 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
 991 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
 992
 993 /* From PE spec doc, section 5.2.1 */
 994 #define MYIMAGE_REL_I386_DIR32           0x0006
 995 #define MYIMAGE_REL_I386_REL32           0x0014
 996
 997
 998 /* We use myindex to calculate array addresses, rather than
 999    simply doing the normal subscript thing.  That's because
1000    some of the above structs have sizes which are not
1001    a whole number of words.  GCC rounds their sizes up to a
1002    whole number of words, which means that the address calcs
1003    arising from using normal C indexing or pointer arithmetic
1004    are just plain wrong.  Sigh.
1005 */
1006 static UChar *
1007 myindex ( int scale, void* base, int index )
1008 {
1009    return
1010       ((UChar*)base) + scale * index;
1011 }
1012
1013
1014 static void
1015 printName ( UChar* name, UChar* strtab )
1016 {
1017    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1018       UInt32 strtab_offset = * (UInt32*)(name+4);
1019       fprintf ( stderr, "%s", strtab + strtab_offset );
1020    } else {
1021       int i;
1022       for (i = 0; i < 8; i++) {
1023          if (name[i] == 0) break;
1024          fprintf ( stderr, "%c", name[i] );
1025       }
1026    }
1027 }
1028
1029
1030 static void
1031 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1032 {
1033    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1034       UInt32 strtab_offset = * (UInt32*)(name+4);
1035       strncpy ( dst, strtab+strtab_offset, dstSize );
1036       dst[dstSize-1] = 0;
1037    } else {
1038       int i = 0;
1039       while (1) {
1040          if (i >= 8) break;
1041          if (name[i] == 0) break;
1042          dst[i] = name[i];
1043          i++;
1044       }
1045       dst[i] = 0;
1046    }
1047 }
1048
1049
1050 static UChar *
1051 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1052 {
1053    UChar* newstr;
1054    /* If the string is longer than 8 bytes, look in the
1055       string table for it -- this will be correctly zero terminated.
1056    */
1057    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1058       UInt32 strtab_offset = * (UInt32*)(name+4);
1059       return ((UChar*)strtab) + strtab_offset;
1060    }
1061    /* Otherwise, if shorter than 8 bytes, return the original,
1062       which by defn is correctly terminated.
1063    */
1064    if (name[7]==0) return name;
1065    /* The annoying case: 8 bytes.  Copy into a temporary
1066       (which is never freed ...)
1067    */
1068    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1069    ASSERT(newstr);
1070    strncpy(newstr,name,8);
1071    newstr[8] = 0;
1072    return newstr;
1073 }
1074
1075
1076 /* Just compares the short names (first 8 chars) */
1077 static COFF_section *
1078 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1079 {
1080    int i;
1081    COFF_header* hdr
1082       = (COFF_header*)(oc->image);
1083    COFF_section* sectab
1084       = (COFF_section*) (
1085            ((UChar*)(oc->image))
1086            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1087         );
1088    for (i = 0; i < hdr->NumberOfSections; i++) {
1089       UChar* n1;
1090       UChar* n2;
1091       COFF_section* section_i
1092          = (COFF_section*)
1093            myindex ( sizeof_COFF_section, sectab, i );
1094       n1 = (UChar*) &(section_i->Name);
1095       n2 = name;
1096       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1097           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1098           n1[6]==n2[6] && n1[7]==n2[7])
1099          return section_i;
1100    }
1101
1102    return NULL;
1103 }
1104
1105
1106 static void
1107 zapTrailingAtSign ( UChar* sym )
1108 {
1109 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1110    int i, j;
1111    if (sym[0] == 0) return;
1112    i = 0;
1113    while (sym[i] != 0) i++;
1114    i--;
1115    j = i;
1116    while (j > 0 && my_isdigit(sym[j])) j--;
1117    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1118 #  undef my_isdigit
1119 }
1120
1121
1122 static int
1123 ocVerifyImage_PEi386 ( ObjectCode* oc )
1124 {
1125    int i;
1126    UInt32 j, noRelocs;
1127    COFF_header*  hdr;
1128    COFF_section* sectab;
1129    COFF_symbol*  symtab;
1130    UChar*        strtab;
1131    /* fprintf(stderr, "\nLOADING %s\n", oc->fileName); */
1132    hdr = (COFF_header*)(oc->image);
1133    sectab = (COFF_section*) (
1134                ((UChar*)(oc->image))
1135                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1136             );
1137    symtab = (COFF_symbol*) (
1138                ((UChar*)(oc->image))
1139                + hdr->PointerToSymbolTable
1140             );
1141    strtab = ((UChar*)symtab)
1142             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1143
1144    if (hdr->Machine != 0x14c) {
1145       belch("Not x86 PEi386");
1146       return 0;
1147    }
1148    if (hdr->SizeOfOptionalHeader != 0) {
1149       belch("PEi386 with nonempty optional header");
1150       return 0;
1151    }
1152    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1153         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1154         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1155         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1156       belch("Not a PEi386 object file");
1157       return 0;
1158    }
1159    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1160         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1161       belch("Invalid PEi386 word size or endiannness: %d",
1162             (int)(hdr->Characteristics));
1163       return 0;
1164    }
1165    /* If the string table size is way crazy, this might indicate that
1166       there are more than 64k relocations, despite claims to the
1167       contrary.  Hence this test. */
1168    /* fprintf(stderr, "strtab size %d\n", * (UInt32*)strtab); */
1169 #if 0
1170    if ( (*(UInt32*)strtab) > 600000 ) {
1171       /* Note that 600k has no special significance other than being
1172          big enough to handle the almost-2MB-sized lumps that
1173          constitute HSwin32*.o. */
1174       belch("PEi386 object has suspiciously large string table; > 64k relocs?");
1175       return 0;
1176    }
1177 #endif
1178
1179    /* No further verification after this point; only debug printing. */
1180    i = 0;
1181    IF_DEBUG(linker, i=1);
1182    if (i == 0) return 1;
1183
1184    fprintf ( stderr,
1185              "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1186    fprintf ( stderr,
1187              "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1188    fprintf ( stderr,
1189              "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1190
1191    fprintf ( stderr, "\n" );
1192    fprintf ( stderr,
1193              "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1194    fprintf ( stderr,
1195              "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1196    fprintf ( stderr,
1197              "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1198    fprintf ( stderr,
1199              "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1200    fprintf ( stderr,
1201              "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1202    fprintf ( stderr,
1203              "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1204    fprintf ( stderr,
1205              "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1206
1207    /* Print the section table. */
1208    fprintf ( stderr, "\n" );
1209    for (i = 0; i < hdr->NumberOfSections; i++) {
1210       COFF_reloc* reltab;
1211       COFF_section* sectab_i
1212          = (COFF_section*)
1213            myindex ( sizeof_COFF_section, sectab, i );
1214       fprintf ( stderr,
1215                 "\n"
1216                 "section %d\n"
1217                 "     name `",
1218                 i
1219               );
1220       printName ( sectab_i->Name, strtab );
1221       fprintf ( stderr,
1222                 "'\n"
1223                 "    vsize %d\n"
1224                 "    vaddr %d\n"
1225                 "  data sz %d\n"
1226                 " data off %d\n"
1227                 "  num rel %d\n"
1228                 "  off rel %d\n"
1229                 "  ptr raw 0x%x\n",
1230                 sectab_i->VirtualSize,
1231                 sectab_i->VirtualAddress,
1232                 sectab_i->SizeOfRawData,
1233                 sectab_i->PointerToRawData,
1234                 sectab_i->NumberOfRelocations,
1235                 sectab_i->PointerToRelocations,
1236                 sectab_i->PointerToRawData
1237               );
1238       reltab = (COFF_reloc*) (
1239                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1240                );
1241
1242       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1243         /* If the relocation field (a short) has overflowed, the
1244          * real count can be found in the first reloc entry.
1245          *
1246          * See Section 4.1 (last para) of the PE spec (rev6.0).
1247          */
1248         COFF_reloc* rel = (COFF_reloc*)
1249                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1250         noRelocs = rel->VirtualAddress;
1251         j = 1;
1252       } else {
1253         noRelocs = sectab_i->NumberOfRelocations;
1254         j = 0;
1255       }
1256
1257       for (; j < noRelocs; j++) {
1258          COFF_symbol* sym;
1259          COFF_reloc* rel = (COFF_reloc*)
1260                            myindex ( sizeof_COFF_reloc, reltab, j );
1261          fprintf ( stderr,
1262                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1263                    (UInt32)rel->Type,
1264                    rel->VirtualAddress );
1265          sym = (COFF_symbol*)
1266                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1267          /* Hmm..mysterious looking offset - what's it for? SOF */
1268          printName ( sym->Name, strtab -10 );
1269          fprintf ( stderr, "'\n" );
1270       }
1271
1272       fprintf ( stderr, "\n" );
1273    }
1274    fprintf ( stderr, "\n" );
1275    fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
1276    fprintf ( stderr, "---START of string table---\n");
1277    for (i = 4; i < *(Int32*)strtab; i++) {
1278       if (strtab[i] == 0)
1279          fprintf ( stderr, "\n"); else
1280          fprintf( stderr, "%c", strtab[i] );
1281    }
1282    fprintf ( stderr, "--- END  of string table---\n");
1283
1284    fprintf ( stderr, "\n" );
1285    i = 0;
1286    while (1) {
1287       COFF_symbol* symtab_i;
1288       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1289       symtab_i = (COFF_symbol*)
1290                  myindex ( sizeof_COFF_symbol, symtab, i );
1291       fprintf ( stderr,
1292                 "symbol %d\n"
1293                 "     name `",
1294                 i
1295               );
1296       printName ( symtab_i->Name, strtab );
1297       fprintf ( stderr,
1298                 "'\n"
1299                 "    value 0x%x\n"
1300                 "   1+sec# %d\n"
1301                 "     type 0x%x\n"
1302                 "   sclass 0x%x\n"
1303                 "     nAux %d\n",
1304                 symtab_i->Value,
1305                 (Int32)(symtab_i->SectionNumber),
1306                 (UInt32)symtab_i->Type,
1307                 (UInt32)symtab_i->StorageClass,
1308                 (UInt32)symtab_i->NumberOfAuxSymbols
1309               );
1310       i += symtab_i->NumberOfAuxSymbols;
1311       i++;
1312    }
1313
1314    fprintf ( stderr, "\n" );
1315    return 1;
1316 }
1317
1318
1319 static int
1320 ocGetNames_PEi386 ( ObjectCode* oc )
1321 {
1322    COFF_header*  hdr;
1323    COFF_section* sectab;
1324    COFF_symbol*  symtab;
1325    UChar*        strtab;
1326
1327    UChar* sname;
1328    void*  addr;
1329    int    i;
1330
1331    hdr = (COFF_header*)(oc->image);
1332    sectab = (COFF_section*) (
1333                ((UChar*)(oc->image))
1334                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1335             );
1336    symtab = (COFF_symbol*) (
1337                ((UChar*)(oc->image))
1338                + hdr->PointerToSymbolTable
1339             );
1340    strtab = ((UChar*)(oc->image))
1341             + hdr->PointerToSymbolTable
1342             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1343
1344    /* Allocate space for any (local, anonymous) .bss sections. */
1345
1346    for (i = 0; i < hdr->NumberOfSections; i++) {
1347       UChar* zspace;
1348       COFF_section* sectab_i
1349          = (COFF_section*)
1350            myindex ( sizeof_COFF_section, sectab, i );
1351       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1352       if (sectab_i->VirtualSize == 0) continue;
1353       /* This is a non-empty .bss section.  Allocate zeroed space for
1354          it, and set its PointerToRawData field such that oc->image +
1355          PointerToRawData == addr_of_zeroed_space.  */
1356       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1357                               "ocGetNames_PEi386(anonymous bss)");
1358       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1359       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1360       /* fprintf(stderr, "BSS anon section at 0x%x\n", zspace); */
1361    }
1362
1363    /* Copy section information into the ObjectCode. */
1364
1365    for (i = 0; i < hdr->NumberOfSections; i++) {
1366       UChar* start;
1367       UChar* end;
1368       UInt32 sz;
1369
1370       SectionKind kind
1371          = SECTIONKIND_OTHER;
1372       COFF_section* sectab_i
1373          = (COFF_section*)
1374            myindex ( sizeof_COFF_section, sectab, i );
1375       IF_DEBUG(linker, belch("section name = %s\n", sectab_i->Name ));
1376
1377 #     if 0
1378       /* I'm sure this is the Right Way to do it.  However, the
1379          alternative of testing the sectab_i->Name field seems to
1380          work ok with Cygwin.
1381       */
1382       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1383           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1384          kind = SECTIONKIND_CODE_OR_RODATA;
1385 #     endif
1386
1387       if (0==strcmp(".text",sectab_i->Name) ||
1388           0==strcmp(".rodata",sectab_i->Name))
1389          kind = SECTIONKIND_CODE_OR_RODATA;
1390       if (0==strcmp(".data",sectab_i->Name) ||
1391           0==strcmp(".bss",sectab_i->Name))
1392          kind = SECTIONKIND_RWDATA;
1393
1394       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
1395       sz = sectab_i->SizeOfRawData;
1396       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
1397
1398       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
1399       end   = start + sz - 1;
1400
1401       if (kind == SECTIONKIND_OTHER
1402           /* Ignore sections called which contain stabs debugging
1403              information. */
1404           && 0 != strcmp(".stab", sectab_i->Name)
1405           && 0 != strcmp(".stabstr", sectab_i->Name)
1406          ) {
1407          belch("Unknown PEi386 section name `%s'", sectab_i->Name);
1408          return 0;
1409       }
1410
1411       if (kind != SECTIONKIND_OTHER && end >= start) {
1412          addSection(oc, kind, start, end);
1413          addProddableBlock(oc, start, end - start + 1);
1414       }
1415    }
1416
1417    /* Copy exported symbols into the ObjectCode. */
1418
1419    oc->n_symbols = hdr->NumberOfSymbols;
1420    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
1421                                   "ocGetNames_PEi386(oc->symbols)");
1422    /* Call me paranoid; I don't care. */
1423    for (i = 0; i < oc->n_symbols; i++)
1424       oc->symbols[i] = NULL;
1425
1426    i = 0;
1427    while (1) {
1428       COFF_symbol* symtab_i;
1429       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1430       symtab_i = (COFF_symbol*)
1431                  myindex ( sizeof_COFF_symbol, symtab, i );
1432
1433       addr  = NULL;
1434
1435       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
1436           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
1437          /* This symbol is global and defined, viz, exported */
1438          /* for MYIMAGE_SYMCLASS_EXTERNAL
1439                 && !MYIMAGE_SYM_UNDEFINED,
1440             the address of the symbol is:
1441                 address of relevant section + offset in section
1442          */
1443          COFF_section* sectabent
1444             = (COFF_section*) myindex ( sizeof_COFF_section,
1445                                         sectab,
1446                                         symtab_i->SectionNumber-1 );
1447          addr = ((UChar*)(oc->image))
1448                 + (sectabent->PointerToRawData
1449                    + symtab_i->Value);
1450       }
1451       else
1452       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
1453           && symtab_i->Value > 0) {
1454          /* This symbol isn't in any section at all, ie, global bss.
1455             Allocate zeroed space for it. */
1456          addr = stgCallocBytes(1, symtab_i->Value,
1457                                "ocGetNames_PEi386(non-anonymous bss)");
1458          addSection(oc, SECTIONKIND_RWDATA, addr,
1459                         ((UChar*)addr) + symtab_i->Value - 1);
1460          addProddableBlock(oc, addr, symtab_i->Value);
1461          /* fprintf(stderr, "BSS      section at 0x%x\n", addr); */
1462       }
1463
1464       if (addr != NULL ) {
1465          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
1466          /* fprintf(stderr,"addSymbol %p `%s \n", addr,sname);  */
1467          IF_DEBUG(linker, belch("addSymbol %p `%s'\n", addr,sname);)
1468          ASSERT(i >= 0 && i < oc->n_symbols);
1469          /* cstring_from_COFF_symbol_name always succeeds. */
1470          oc->symbols[i] = sname;
1471          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
1472       } else {
1473 #        if 0
1474          fprintf ( stderr,
1475                    "IGNORING symbol %d\n"
1476                    "     name `",
1477                    i
1478                  );
1479          printName ( symtab_i->Name, strtab );
1480          fprintf ( stderr,
1481                    "'\n"
1482                    "    value 0x%x\n"
1483                    "   1+sec# %d\n"
1484                    "     type 0x%x\n"
1485                    "   sclass 0x%x\n"
1486                    "     nAux %d\n",
1487                    symtab_i->Value,
1488                    (Int32)(symtab_i->SectionNumber),
1489                    (UInt32)symtab_i->Type,
1490                    (UInt32)symtab_i->StorageClass,
1491                    (UInt32)symtab_i->NumberOfAuxSymbols
1492                  );
1493 #        endif
1494       }
1495
1496       i += symtab_i->NumberOfAuxSymbols;
1497       i++;
1498    }
1499
1500    return 1;
1501 }
1502
1503
1504 static int
1505 ocResolve_PEi386 ( ObjectCode* oc )
1506 {
1507    COFF_header*  hdr;
1508    COFF_section* sectab;
1509    COFF_symbol*  symtab;
1510    UChar*        strtab;
1511
1512    UInt32        A;
1513    UInt32        S;
1514    UInt32*       pP;
1515
1516    int i;
1517    UInt32 j, noRelocs;
1518
1519    /* ToDo: should be variable-sized?  But is at least safe in the
1520       sense of buffer-overrun-proof. */
1521    char symbol[1000];
1522    /* fprintf(stderr, "resolving for %s\n", oc->fileName); */
1523
1524    hdr = (COFF_header*)(oc->image);
1525    sectab = (COFF_section*) (
1526                ((UChar*)(oc->image))
1527                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1528             );
1529    symtab = (COFF_symbol*) (
1530                ((UChar*)(oc->image))
1531                + hdr->PointerToSymbolTable
1532             );
1533    strtab = ((UChar*)(oc->image))
1534             + hdr->PointerToSymbolTable
1535             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1536
1537    for (i = 0; i < hdr->NumberOfSections; i++) {
1538       COFF_section* sectab_i
1539          = (COFF_section*)
1540            myindex ( sizeof_COFF_section, sectab, i );
1541       COFF_reloc* reltab
1542          = (COFF_reloc*) (
1543               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1544            );
1545
1546       /* Ignore sections called which contain stabs debugging
1547          information. */
1548       if (0 == strcmp(".stab", sectab_i->Name)
1549           || 0 == strcmp(".stabstr", sectab_i->Name))
1550          continue;
1551
1552       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1553         /* If the relocation field (a short) has overflowed, the
1554          * real count can be found in the first reloc entry.
1555          *
1556          * See Section 4.1 (last para) of the PE spec (rev6.0).
1557          */
1558         COFF_reloc* rel = (COFF_reloc*)
1559                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1560         noRelocs = rel->VirtualAddress;
1561         fprintf(stderr, "Overflown relocs: %u\n", noRelocs);
1562         j = 1;
1563       } else {
1564         noRelocs = sectab_i->NumberOfRelocations;
1565         j = 0;
1566       }
1567
1568
1569       for (; j < noRelocs; j++) {
1570          COFF_symbol* sym;
1571          COFF_reloc* reltab_j
1572             = (COFF_reloc*)
1573               myindex ( sizeof_COFF_reloc, reltab, j );
1574
1575          /* the location to patch */
1576          pP = (UInt32*)(
1577                  ((UChar*)(oc->image))
1578                  + (sectab_i->PointerToRawData
1579                     + reltab_j->VirtualAddress
1580                     - sectab_i->VirtualAddress )
1581               );
1582          /* the existing contents of pP */
1583          A = *pP;
1584          /* the symbol to connect to */
1585          sym = (COFF_symbol*)
1586                myindex ( sizeof_COFF_symbol,
1587                          symtab, reltab_j->SymbolTableIndex );
1588          IF_DEBUG(linker,
1589                   fprintf ( stderr,
1590                             "reloc sec %2d num %3d:  type 0x%-4x   "
1591                             "vaddr 0x%-8x   name `",
1592                             i, j,
1593                             (UInt32)reltab_j->Type,
1594                             reltab_j->VirtualAddress );
1595                             printName ( sym->Name, strtab );
1596                             fprintf ( stderr, "'\n" ));
1597
1598          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1599             COFF_section* section_sym
1600                = findPEi386SectionCalled ( oc, sym->Name );
1601             if (!section_sym) {
1602                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
1603                return 0;
1604             }
1605             S = ((UInt32)(oc->image))
1606                 + (section_sym->PointerToRawData
1607                    + sym->Value);
1608          } else {
1609             copyName ( sym->Name, strtab, symbol, 1000-1 );
1610             (void*)S = lookupLocalSymbol( oc, symbol );
1611             if ((void*)S != NULL) goto foundit;
1612             (void*)S = lookupSymbol( symbol );
1613             if ((void*)S != NULL) goto foundit;
1614             zapTrailingAtSign ( symbol );
1615             (void*)S = lookupLocalSymbol( oc, symbol );
1616             if ((void*)S != NULL) goto foundit;
1617             (void*)S = lookupSymbol( symbol );
1618             if ((void*)S != NULL) goto foundit;
1619             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
1620             return 0;
1621            foundit:
1622          }
1623          checkProddableBlock(oc, pP);
1624          switch (reltab_j->Type) {
1625             case MYIMAGE_REL_I386_DIR32:
1626                *pP = A + S;
1627                break;
1628             case MYIMAGE_REL_I386_REL32:
1629                /* Tricky.  We have to insert a displacement at
1630                   pP which, when added to the PC for the _next_
1631                   insn, gives the address of the target (S).
1632                   Problem is to know the address of the next insn
1633                   when we only know pP.  We assume that this
1634                   literal field is always the last in the insn,
1635                   so that the address of the next insn is pP+4
1636                   -- hence the constant 4.
1637                   Also I don't know if A should be added, but so
1638                   far it has always been zero.
1639                */
1640                ASSERT(A==0);
1641                *pP = S - ((UInt32)pP) - 4;
1642                break;
1643             default:
1644                belch("%s: unhandled PEi386 relocation type %d",
1645                      oc->fileName, reltab_j->Type);
1646                return 0;
1647          }
1648
1649       }
1650    }
1651
1652    IF_DEBUG(linker, belch("completed %s", oc->fileName));
1653    return 1;
1654 }
1655
1656 #endif /* defined(OBJFORMAT_PEi386) */
1657
1658
1659 /* --------------------------------------------------------------------------
1660  * ELF specifics
1661  * ------------------------------------------------------------------------*/
1662
1663 #if defined(OBJFORMAT_ELF)
1664
1665 #define FALSE 0
1666 #define TRUE  1
1667
1668 #if defined(sparc_TARGET_ARCH)
1669 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
1670 #elif defined(i386_TARGET_ARCH)
1671 #  define ELF_TARGET_386    /* Used inside <elf.h> */
1672 #endif
1673 /* There is a similar case for IA64 in the Solaris2 headers if this
1674  * ever becomes relevant.
1675  */
1676
1677 #include <elf.h>
1678 #include <ctype.h>
1679
1680 static char *
1681 findElfSection ( void* objImage, Elf32_Word sh_type )
1682 {
1683    int i;
1684    char* ehdrC = (char*)objImage;
1685    Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
1686    Elf32_Shdr* shdr = (Elf32_Shdr*)(ehdrC + ehdr->e_shoff);
1687    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1688    char* ptr = NULL;
1689    for (i = 0; i < ehdr->e_shnum; i++) {
1690       if (shdr[i].sh_type == sh_type
1691           /* Ignore the section header's string table. */
1692           && i != ehdr->e_shstrndx
1693           /* Ignore string tables named .stabstr, as they contain
1694              debugging info. */
1695           && 0 != strncmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
1696          ) {
1697          ptr = ehdrC + shdr[i].sh_offset;
1698          break;
1699       }
1700    }
1701    return ptr;
1702 }
1703
1704
1705 static int
1706 ocVerifyImage_ELF ( ObjectCode* oc )
1707 {
1708    Elf32_Shdr* shdr;
1709    Elf32_Sym*  stab;
1710    int i, j, nent, nstrtab, nsymtabs;
1711    char* sh_strtab;
1712    char* strtab;
1713
1714    char*       ehdrC = (char*)(oc->image);
1715    Elf32_Ehdr* ehdr  = ( Elf32_Ehdr*)ehdrC;
1716
1717    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1718        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1719        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1720        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1721       belch("%s: not an ELF header", oc->fileName);
1722       return 0;
1723    }
1724    IF_DEBUG(linker,belch( "Is an ELF header" ));
1725
1726    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1727       belch("%s: not 32 bit ELF", oc->fileName);
1728       return 0;
1729    }
1730
1731    IF_DEBUG(linker,belch( "Is 32 bit ELF" ));
1732
1733    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1734        IF_DEBUG(linker,belch( "Is little-endian" ));
1735    } else
1736    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1737        IF_DEBUG(linker,belch( "Is big-endian" ));
1738    } else {
1739        belch("%s: unknown endiannness", oc->fileName);
1740        return 0;
1741    }
1742
1743    if (ehdr->e_type != ET_REL) {
1744       belch("%s: not a relocatable object (.o) file", oc->fileName);
1745       return 0;
1746    }
1747    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
1748
1749    IF_DEBUG(linker,belch( "Architecture is " ));
1750    switch (ehdr->e_machine) {
1751       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
1752       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
1753       default:       IF_DEBUG(linker,belch( "unknown" ));
1754                      belch("%s: unknown architecture", oc->fileName);
1755                      return 0;
1756    }
1757
1758    IF_DEBUG(linker,belch(
1759              "\nSection header table: start %d, n_entries %d, ent_size %d",
1760              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
1761
1762    ASSERT (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1763
1764    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1765
1766    if (ehdr->e_shstrndx == SHN_UNDEF) {
1767       belch("%s: no section header string table", oc->fileName);
1768       return 0;
1769    } else {
1770       IF_DEBUG(linker,belch( "Section header string table is section %d",
1771                           ehdr->e_shstrndx));
1772       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1773    }
1774
1775    for (i = 0; i < ehdr->e_shnum; i++) {
1776       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
1777       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
1778       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
1779       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
1780       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
1781                ehdrC + shdr[i].sh_offset,
1782                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
1783
1784       if (shdr[i].sh_type == SHT_REL) {
1785           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
1786       } else if (shdr[i].sh_type == SHT_RELA) {
1787           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
1788       } else {
1789           IF_DEBUG(linker,fprintf(stderr,"     "));
1790       }
1791       if (sh_strtab) {
1792           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
1793       }
1794    }
1795
1796    IF_DEBUG(linker,belch( "\nString tables" ));
1797    strtab = NULL;
1798    nstrtab = 0;
1799    for (i = 0; i < ehdr->e_shnum; i++) {
1800       if (shdr[i].sh_type == SHT_STRTAB
1801           /* Ignore the section header's string table. */
1802           && i != ehdr->e_shstrndx
1803           /* Ignore string tables named .stabstr, as they contain
1804              debugging info. */
1805           && 0 != strncmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
1806          ) {
1807          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
1808          strtab = ehdrC + shdr[i].sh_offset;
1809          nstrtab++;
1810       }
1811    }
1812    if (nstrtab != 1) {
1813       belch("%s: no string tables, or too many", oc->fileName);
1814       return 0;
1815    }
1816
1817    nsymtabs = 0;
1818    IF_DEBUG(linker,belch( "\nSymbol tables" ));
1819    for (i = 0; i < ehdr->e_shnum; i++) {
1820       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1821       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
1822       nsymtabs++;
1823       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1824       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1825       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
1826                nent,
1827                shdr[i].sh_size % sizeof(Elf32_Sym)
1828              ));
1829       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1830          belch("%s: non-integral number of symbol table entries", oc->fileName);
1831          return 0;
1832       }
1833       for (j = 0; j < nent; j++) {
1834          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
1835          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
1836                              (int)stab[j].st_shndx,
1837                              (int)stab[j].st_size,
1838                              (char*)stab[j].st_value ));
1839
1840          IF_DEBUG(linker,fprintf(stderr, "type=" ));
1841          switch (ELF32_ST_TYPE(stab[j].st_info)) {
1842             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
1843             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
1844             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
1845             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
1846             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
1847             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
1848          }
1849          IF_DEBUG(linker,fprintf(stderr, "  " ));
1850
1851          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
1852          switch (ELF32_ST_BIND(stab[j].st_info)) {
1853             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
1854             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
1855             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
1856             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
1857          }
1858          IF_DEBUG(linker,fprintf(stderr, "  " ));
1859
1860          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
1861       }
1862    }
1863
1864    if (nsymtabs == 0) {
1865       belch("%s: didn't find any symbol tables", oc->fileName);
1866       return 0;
1867    }
1868
1869    return 1;
1870 }
1871
1872
1873 static int
1874 ocGetNames_ELF ( ObjectCode* oc )
1875 {
1876    int i, j, k, nent;
1877    Elf32_Sym* stab;
1878
1879    char*       ehdrC      = (char*)(oc->image);
1880    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
1881    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
1882    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1883
1884    ASSERT(symhash != NULL);
1885
1886    if (!strtab) {
1887       belch("%s: no strtab", oc->fileName);
1888       return 0;
1889    }
1890
1891    k = 0;
1892    for (i = 0; i < ehdr->e_shnum; i++) {
1893       /* Figure out what kind of section it is.  Logic derived from
1894          Figure 1.14 ("Special Sections") of the ELF document
1895          ("Portable Formats Specification, Version 1.1"). */
1896       Elf32_Shdr  hdr    = shdr[i];
1897       SectionKind kind   = SECTIONKIND_OTHER;
1898       int         is_bss = FALSE;
1899
1900       if (hdr.sh_type == SHT_PROGBITS
1901           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_EXECINSTR)) {
1902          /* .text-style section */
1903          kind = SECTIONKIND_CODE_OR_RODATA;
1904       }
1905       else
1906       if (hdr.sh_type == SHT_PROGBITS
1907           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
1908          /* .data-style section */
1909          kind = SECTIONKIND_RWDATA;
1910       }
1911       else
1912       if (hdr.sh_type == SHT_PROGBITS
1913           && (hdr.sh_flags & SHF_ALLOC) && !(hdr.sh_flags & SHF_WRITE)) {
1914          /* .rodata-style section */
1915          kind = SECTIONKIND_CODE_OR_RODATA;
1916       }
1917       else
1918       if (hdr.sh_type == SHT_NOBITS
1919           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
1920          /* .bss-style section */
1921          kind = SECTIONKIND_RWDATA;
1922          is_bss = TRUE;
1923       }
1924
1925       if (is_bss && shdr[i].sh_size > 0) {
1926          /* This is a non-empty .bss section.  Allocate zeroed space for
1927             it, and set its .sh_offset field such that
1928             ehdrC + .sh_offset == addr_of_zeroed_space.  */
1929          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
1930                                        "ocGetNames_ELF(BSS)");
1931          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
1932          /*
1933          fprintf(stderr, "BSS section at 0x%x, size %d\n",
1934                          zspace, shdr[i].sh_size);
1935          */
1936       }
1937
1938       /* fill in the section info */
1939       addSection(oc, kind, ehdrC + shdr[i].sh_offset,
1940                      ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1941       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0)
1942          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
1943
1944       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1945
1946       /* copy stuff into this module's object symbol table */
1947       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1948       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1949
1950       oc->n_symbols = nent;
1951       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
1952                                    "ocGetNames_ELF(oc->symbols)");
1953
1954       for (j = 0; j < nent; j++) {
1955
1956          char  isLocal = FALSE; /* avoids uninit-var warning */
1957          char* ad      = NULL;
1958          char* nm      = strtab + stab[j].st_name;
1959          int   secno   = stab[j].st_shndx;
1960
1961          /* Figure out if we want to add it; if so, set ad to its
1962             address.  Otherwise leave ad == NULL. */
1963
1964          if (secno == SHN_COMMON) {
1965             isLocal = FALSE;
1966             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
1967             /*
1968             fprintf(stderr, "COMMON symbol, size %d name %s\n",
1969                             stab[j].st_size, nm);
1970             */
1971             /* Pointless to do addProddableBlock() for this area,
1972                since the linker should never poke around in it. */
1973          }
1974          else
1975          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL
1976                 || ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1977               )
1978               /* and not an undefined symbol */
1979               && stab[j].st_shndx != SHN_UNDEF
1980               /* and not in a "special section" */
1981               && stab[j].st_shndx < SHN_LORESERVE
1982               &&
1983               /* and it's a not a section or string table or anything silly */
1984               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1985                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
1986                 ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE
1987               )
1988             ) {
1989             /* Section 0 is the undefined section, hence > and not >=. */
1990             ASSERT(secno > 0 && secno < ehdr->e_shnum);
1991             /*
1992             if (shdr[secno].sh_type == SHT_NOBITS) {
1993                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
1994                                stab[j].st_size, stab[j].st_value, nm);
1995             }
1996             */
1997             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
1998             if (ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL) {
1999                isLocal = TRUE;
2000             } else {
2001                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
2002                                       ad, oc->fileName, nm ));
2003                isLocal = FALSE;
2004             }
2005          }
2006
2007          /* And the decision is ... */
2008
2009          if (ad != NULL) {
2010             ASSERT(nm != NULL);
2011             oc->symbols[j] = nm;
2012             /* Acquire! */
2013             if (isLocal) {
2014                /* Ignore entirely. */
2015             } else {
2016                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2017             }
2018          } else {
2019             /* Skip. */
2020             IF_DEBUG(linker,belch( "skipping `%s'",
2021                                    strtab + stab[j].st_name ));
2022             /*
2023             fprintf(stderr,
2024                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2025                     (int)ELF32_ST_BIND(stab[j].st_info),
2026                     (int)ELF32_ST_TYPE(stab[j].st_info),
2027                     (int)stab[j].st_shndx,
2028                     strtab + stab[j].st_name
2029                    );
2030             */
2031             oc->symbols[j] = NULL;
2032          }
2033
2034       }
2035    }
2036
2037    return 1;
2038 }
2039
2040
2041 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2042    relocations appear to be of this form. */
2043 static int
2044 do_Elf32_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2045                            Elf32_Shdr* shdr, int shnum,
2046                            Elf32_Sym*  stab, char* strtab )
2047 {
2048    int j;
2049    char *symbol;
2050    Elf32_Word* targ;
2051    Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[shnum].sh_offset);
2052    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rel);
2053    int target_shndx = shdr[shnum].sh_info;
2054    int symtab_shndx = shdr[shnum].sh_link;
2055    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2056    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2057    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2058                           target_shndx, symtab_shndx ));
2059    for (j = 0; j < nent; j++) {
2060       Elf32_Addr offset = rtab[j].r_offset;
2061       Elf32_Word info   = rtab[j].r_info;
2062
2063       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
2064       Elf32_Word* pP = (Elf32_Word*)P;
2065       Elf32_Addr  A  = *pP;
2066       Elf32_Addr  S;
2067
2068       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
2069                              j, (void*)offset, (void*)info ));
2070       if (!info) {
2071          IF_DEBUG(linker,belch( " ZERO" ));
2072          S = 0;
2073       } else {
2074          Elf32_Sym sym = stab[ELF32_R_SYM(info)];
2075          /* First see if it is a local symbol. */
2076          if (ELF32_ST_BIND(sym.st_info) == STB_LOCAL) {
2077             /* Yes, so we can get the address directly from the ELF symbol
2078                table. */
2079             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2080             S = (Elf32_Addr)
2081                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2082                        + stab[ELF32_R_SYM(info)].st_value);
2083
2084          } else {
2085             /* No, so look up the name in our global table. */
2086             symbol = strtab + sym.st_name;
2087             (void*)S = lookupSymbol( symbol );
2088          }
2089          if (!S) {
2090             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2091             return 0;
2092          }
2093          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2094       }
2095       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2096                              (void*)P, (void*)S, (void*)A ));
2097       checkProddableBlock ( oc, pP );
2098       switch (ELF32_R_TYPE(info)) {
2099 #        ifdef i386_TARGET_ARCH
2100          case R_386_32:   *pP = S + A;     break;
2101          case R_386_PC32: *pP = S + A - P; break;
2102 #        endif
2103          default:
2104             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2105                   oc->fileName, ELF32_R_TYPE(info));
2106             return 0;
2107       }
2108
2109    }
2110    return 1;
2111 }
2112
2113
2114 /* Do ELF relocations for which explicit addends are supplied.
2115    sparc-solaris relocations appear to be of this form. */
2116 static int
2117 do_Elf32_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2118                             Elf32_Shdr* shdr, int shnum,
2119                             Elf32_Sym*  stab, char* strtab )
2120 {
2121    int j;
2122    char *symbol;
2123    Elf32_Word* targ;
2124    Elf32_Rela* rtab = (Elf32_Rela*) (ehdrC + shdr[shnum].sh_offset);
2125    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rela);
2126    int target_shndx = shdr[shnum].sh_info;
2127    int symtab_shndx = shdr[shnum].sh_link;
2128    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2129    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2130    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2131                           target_shndx, symtab_shndx ));
2132    for (j = 0; j < nent; j++) {
2133       Elf32_Addr  offset = rtab[j].r_offset;
2134       Elf32_Word  info   = rtab[j].r_info;
2135       Elf32_Sword addend = rtab[j].r_addend;
2136       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
2137       Elf32_Addr  A  = addend; /* Do not delete this; it is used on sparc. */
2138       Elf32_Addr  S;
2139 #     if defined(sparc_TARGET_ARCH)
2140       /* This #ifdef only serves to avoid unused-var warnings. */
2141       Elf32_Word* pP = (Elf32_Word*)P;
2142       Elf32_Word  w1, w2;
2143 #     endif
2144
2145       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2146                              j, (void*)offset, (void*)info,
2147                                 (void*)addend ));
2148       if (!info) {
2149          IF_DEBUG(linker,belch( " ZERO" ));
2150          S = 0;
2151       } else {
2152          Elf32_Sym sym = stab[ELF32_R_SYM(info)];
2153          /* First see if it is a local symbol. */
2154          if (ELF32_ST_BIND(sym.st_info) == STB_LOCAL) {
2155             /* Yes, so we can get the address directly from the ELF symbol
2156                table. */
2157             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2158             S = (Elf32_Addr)
2159                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2160                        + stab[ELF32_R_SYM(info)].st_value);
2161
2162          } else {
2163             /* No, so look up the name in our global table. */
2164             symbol = strtab + sym.st_name;
2165             (void*)S = lookupSymbol( symbol );
2166          }
2167          if (!S) {
2168            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2169            return 0;
2170            /*
2171            S = 0x11223344;
2172            fprintf ( stderr, "S %p A %p S+A %p S+A-P %p\n",S,A,S+A,S+A-P);
2173            */
2174          }
2175          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2176       }
2177       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2178                                         (void*)P, (void*)S, (void*)A ));
2179       checkProddableBlock ( oc, (void*)P );
2180       switch (ELF32_R_TYPE(info)) {
2181 #        if defined(sparc_TARGET_ARCH)
2182          case R_SPARC_WDISP30:
2183             w1 = *pP & 0xC0000000;
2184             w2 = (Elf32_Word)((S + A - P) >> 2);
2185             ASSERT((w2 & 0xC0000000) == 0);
2186             w1 |= w2;
2187             *pP = w1;
2188             break;
2189          case R_SPARC_HI22:
2190             w1 = *pP & 0xFFC00000;
2191             w2 = (Elf32_Word)((S + A) >> 10);
2192             ASSERT((w2 & 0xFFC00000) == 0);
2193             w1 |= w2;
2194             *pP = w1;
2195             break;
2196          case R_SPARC_LO10:
2197             w1 = *pP & ~0x3FF;
2198             w2 = (Elf32_Word)((S + A) & 0x3FF);
2199             ASSERT((w2 & ~0x3FF) == 0);
2200             w1 |= w2;
2201             *pP = w1;
2202             break;
2203          /* According to the Sun documentation:
2204             R_SPARC_UA32
2205             This relocation type resembles R_SPARC_32, except it refers to an
2206             unaligned word. That is, the word to be relocated must be treated
2207             as four separate bytes with arbitrary alignment, not as a word
2208             aligned according to the architecture requirements.
2209
2210             (JRS: which means that freeloading on the R_SPARC_32 case
2211             is probably wrong, but hey ...)
2212          */
2213          case R_SPARC_UA32:
2214          case R_SPARC_32:
2215             w2 = (Elf32_Word)(S + A);
2216             *pP = w2;
2217             break;
2218 #        endif
2219          default:
2220             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2221                   oc->fileName, ELF32_R_TYPE(info));
2222             return 0;
2223       }
2224
2225    }
2226    return 1;
2227 }
2228
2229
2230 static int
2231 ocResolve_ELF ( ObjectCode* oc )
2232 {
2233    char *strtab;
2234    int   shnum, ok;
2235    Elf32_Sym*  stab = NULL;
2236    char*       ehdrC = (char*)(oc->image);
2237    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
2238    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2239    char* sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2240
2241    /* first find "the" symbol table */
2242    stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2243
2244    /* also go find the string table */
2245    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2246
2247    if (stab == NULL || strtab == NULL) {
2248       belch("%s: can't find string or symbol table", oc->fileName);
2249       return 0;
2250    }
2251
2252    /* Process the relocation sections. */
2253    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2254
2255       /* Skip sections called ".rel.stab".  These appear to contain
2256          relocation entries that, when done, make the stabs debugging
2257          info point at the right places.  We ain't interested in all
2258          dat jazz, mun. */
2259       if (0 == strncmp(".rel.stab", sh_strtab + shdr[shnum].sh_name, 9))
2260          continue;
2261
2262       if (shdr[shnum].sh_type == SHT_REL ) {
2263          ok = do_Elf32_Rel_relocations ( oc, ehdrC, shdr,
2264                                          shnum, stab, strtab );
2265          if (!ok) return ok;
2266       }
2267       else
2268       if (shdr[shnum].sh_type == SHT_RELA) {
2269          ok = do_Elf32_Rela_relocations ( oc, ehdrC, shdr,
2270                                           shnum, stab, strtab );
2271          if (!ok) return ok;
2272       }
2273
2274    }
2275
2276    /* Free the local symbol table; we won't need it again. */
2277    freeHashTable(oc->lochash, NULL);
2278    oc->lochash = NULL;
2279
2280    return 1;
2281 }
2282
2283
2284 #endif /* ELF */