ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Linker.c,v 1.77 2001/12/29 09:24:42 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 void *
 586 lookupLocalSymbol( ObjectCode* oc, char *lbl )
 587 {
 588     void *val;
 589     val = lookupStrHashTable(oc->lochash, lbl);
 590
 591     if (val == NULL) {
 592         return NULL;
 593     } else {
 594         return val;
 595     }
 596 }
 597
 598
 599 /* -----------------------------------------------------------------------------
 600  * Debugging aid: look in GHCi's object symbol tables for symbols
 601  * within DELTA bytes of the specified address, and show their names.
 602  */
 603 #ifdef DEBUG
 604 void ghci_enquire ( char* addr );
 605
 606 void ghci_enquire ( char* addr )
 607 {
 608    int   i;
 609    char* sym;
 610    char* a;
 611    const int DELTA = 64;
 612    ObjectCode* oc;
 613    for (oc = objects; oc; oc = oc->next) {
 614       for (i = 0; i < oc->n_symbols; i++) {
 615          sym = oc->symbols[i];
 616          if (sym == NULL) continue;
 617          /* fprintf(stderr, "enquire %p %p\n", sym, oc->lochash); */
 618          a = NULL;
 619          if (oc->lochash != NULL)
 620             a = lookupStrHashTable(oc->lochash, sym);
 621          if (a == NULL)
 622             a = lookupStrHashTable(symhash, sym);
 623          if (a == NULL) {
 624             /* fprintf(stderr, "ghci_enquire: can't find %s\n", sym); */
 625          }
 626          else if (addr-DELTA <= a && a <= addr+DELTA) {
 627             fprintf(stderr, "%p + %3d  ==  `%s'\n", addr, a - addr, sym);
 628          }
 629       }
 630    }
 631 }
 632 #endif
 633
 634
 635 /* -----------------------------------------------------------------------------
 636  * Load an obj (populate the global symbol table, but don't resolve yet)
 637  *
 638  * Returns: 1 if ok, 0 on error.
 639  */
 640 HsInt
 641 loadObj( char *path )
 642 {
 643    ObjectCode* oc;
 644    struct stat st;
 645    int r, n;
 646    FILE *f;
 647
 648    /* fprintf(stderr, "loadObj %s\n", path ); */
 649
 650    /* Check that we haven't already loaded this object.  Don't give up
 651       at this stage; ocGetNames_* will barf later. */
 652    {
 653        ObjectCode *o;
 654        int is_dup = 0;
 655        for (o = objects; o; o = o->next) {
 656           if (0 == strcmp(o->fileName, path))
 657              is_dup = 1;
 658        }
 659        if (is_dup) {
 660          fprintf(stderr,
 661             "\n\n"
 662             "GHCi runtime linker: warning: looks like you're trying to load the\n"
 663             "same object file twice:\n"
 664             "   %s\n"
 665             "GHCi will continue, but a duplicate-symbol error may shortly follow.\n"
 666             "\n"
 667             , path);
 668        }
 669    }
 670
 671    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
 672
 673 #  if defined(OBJFORMAT_ELF)
 674    oc->formatName = "ELF";
 675 #  elif defined(OBJFORMAT_PEi386)
 676    oc->formatName = "PEi386";
 677 #  else
 678    free(oc);
 679    barf("loadObj: not implemented on this platform");
 680 #  endif
 681
 682    r = stat(path, &st);
 683    if (r == -1) { return 0; }
 684
 685    /* sigh, strdup() isn't a POSIX function, so do it the long way */
 686    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
 687    strcpy(oc->fileName, path);
 688
 689    oc->fileSize          = st.st_size;
 690    oc->image             = stgMallocBytes( st.st_size, "loadObj(image)" );
 691    oc->symbols           = NULL;
 692    oc->sections          = NULL;
 693    oc->lochash           = allocStrHashTable();
 694    oc->proddables        = NULL;
 695
 696    /* chain it onto the list of objects */
 697    oc->next              = objects;
 698    objects               = oc;
 699
 700    /* load the image into memory */
 701    f = fopen(path, "rb");
 702    if (!f) {
 703        barf("loadObj: can't read `%s'", path);
 704    }
 705    n = fread ( oc->image, 1, oc->fileSize, f );
 706    if (n != oc->fileSize) {
 707       fclose(f);
 708       barf("loadObj: error whilst reading `%s'", path);
 709    }
 710
 711    /* verify the in-memory image */
 712 #  if defined(OBJFORMAT_ELF)
 713    r = ocVerifyImage_ELF ( oc );
 714 #  elif defined(OBJFORMAT_PEi386)
 715    r = ocVerifyImage_PEi386 ( oc );
 716 #  else
 717    barf("loadObj: no verify method");
 718 #  endif
 719    if (!r) { return r; }
 720
 721    /* build the symbol list for this image */
 722 #  if defined(OBJFORMAT_ELF)
 723    r = ocGetNames_ELF ( oc );
 724 #  elif defined(OBJFORMAT_PEi386)
 725    r = ocGetNames_PEi386 ( oc );
 726 #  else
 727    barf("loadObj: no getNames method");
 728 #  endif
 729    if (!r) { return r; }
 730
 731    /* loaded, but not resolved yet */
 732    oc->status = OBJECT_LOADED;
 733
 734    return 1;
 735 }
 736
 737 /* -----------------------------------------------------------------------------
 738  * resolve all the currently unlinked objects in memory
 739  *
 740  * Returns: 1 if ok, 0 on error.
 741  */
 742 HsInt
 743 resolveObjs( void )
 744 {
 745     ObjectCode *oc;
 746     int r;
 747
 748     for (oc = objects; oc; oc = oc->next) {
 749         if (oc->status != OBJECT_RESOLVED) {
 750 #           if defined(OBJFORMAT_ELF)
 751             r = ocResolve_ELF ( oc );
 752 #           elif defined(OBJFORMAT_PEi386)
 753             r = ocResolve_PEi386 ( oc );
 754 #           else
 755             barf("resolveObjs: not implemented on this platform");
 756 #           endif
 757             if (!r) { return r; }
 758             oc->status = OBJECT_RESOLVED;
 759         }
 760     }
 761     return 1;
 762 }
 763
 764 /* -----------------------------------------------------------------------------
 765  * delete an object from the pool
 766  */
 767 HsInt
 768 unloadObj( char *path )
 769 {
 770     ObjectCode *oc, *prev;
 771
 772     ASSERT(symhash != NULL);
 773     ASSERT(objects != NULL);
 774
 775     prev = NULL;
 776     for (oc = objects; oc; prev = oc, oc = oc->next) {
 777         if (!strcmp(oc->fileName,path)) {
 778
 779             /* Remove all the mappings for the symbols within this
 780              * object..
 781              */
 782             {
 783                 int i;
 784                 for (i = 0; i < oc->n_symbols; i++) {
 785                    if (oc->symbols[i] != NULL) {
 786                        removeStrHashTable(symhash, oc->symbols[i], NULL);
 787                    }
 788                 }
 789             }
 790
 791             if (prev == NULL) {
 792                 objects = oc->next;
 793             } else {
 794                 prev->next = oc->next;
 795             }
 796
 797             /* We're going to leave this in place, in case there are
 798                any pointers from the heap into it: */
 799             /* free(oc->image); */
 800             free(oc->fileName);
 801             free(oc->symbols);
 802             free(oc->sections);
 803             /* The local hash table should have been freed at the end
 804                of the ocResolve_ call on it. */
 805             ASSERT(oc->lochash == NULL);
 806             free(oc);
 807             return 1;
 808         }
 809     }
 810
 811     belch("unloadObj: can't find `%s' to unload", path);
 812     return 0;
 813 }
 814
 815 /* -----------------------------------------------------------------------------
 816  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
 817  * which may be prodded during relocation, and abort if we try and write
 818  * outside any of these.
 819  */
 820 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
 821 {
 822    ProddableBlock* pb
 823       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
 824    /* fprintf(stderr, "aPB %p %p %d\n", oc, start, size); */
 825    ASSERT(size > 0);
 826    pb->start      = start;
 827    pb->size       = size;
 828    pb->next       = oc->proddables;
 829    oc->proddables = pb;
 830 }
 831
 832 static void checkProddableBlock ( ObjectCode* oc, void* addr )
 833 {
 834    ProddableBlock* pb;
 835    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
 836       char* s = (char*)(pb->start);
 837       char* e = s + pb->size - 1;
 838       char* a = (char*)addr;
 839       /* Assumes that the biggest fixup involves a 4-byte write.  This
 840          probably needs to be changed to 8 (ie, +7) on 64-bit
 841          plats. */
 842       if (a >= s && (a+3) <= e) return;
 843    }
 844    barf("checkProddableBlock: invalid fixup in runtime linker");
 845 }
 846
 847 /* -----------------------------------------------------------------------------
 848  * Section management.
 849  */
 850 static void addSection ( ObjectCode* oc, SectionKind kind,
 851                          void* start, void* end )
 852 {
 853    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
 854    s->start     = start;
 855    s->end       = end;
 856    s->kind      = kind;
 857    s->next      = oc->sections;
 858    oc->sections = s;
 859 }
 860
 861
 862
 863 /* --------------------------------------------------------------------------
 864  * PEi386 specifics (Win32 targets)
 865  * ------------------------------------------------------------------------*/
 866
 867 /* The information for this linker comes from
 868       Microsoft Portable Executable
 869       and Common Object File Format Specification
 870       revision 5.1 January 1998
 871    which SimonM says comes from the MS Developer Network CDs.
 872 */
 873
 874
 875 #if defined(OBJFORMAT_PEi386)
 876
 877
 878
 879 typedef unsigned char  UChar;
 880 typedef unsigned short UInt16;
 881 typedef unsigned int   UInt32;
 882 typedef          int   Int32;
 883
 884
 885 typedef
 886    struct {
 887       UInt16 Machine;
 888       UInt16 NumberOfSections;
 889       UInt32 TimeDateStamp;
 890       UInt32 PointerToSymbolTable;
 891       UInt32 NumberOfSymbols;
 892       UInt16 SizeOfOptionalHeader;
 893       UInt16 Characteristics;
 894    }
 895    COFF_header;
 896
 897 #define sizeof_COFF_header 20
 898
 899
 900 typedef
 901    struct {
 902       UChar  Name[8];
 903       UInt32 VirtualSize;
 904       UInt32 VirtualAddress;
 905       UInt32 SizeOfRawData;
 906       UInt32 PointerToRawData;
 907       UInt32 PointerToRelocations;
 908       UInt32 PointerToLinenumbers;
 909       UInt16 NumberOfRelocations;
 910       UInt16 NumberOfLineNumbers;
 911       UInt32 Characteristics;
 912    }
 913    COFF_section;
 914
 915 #define sizeof_COFF_section 40
 916
 917
 918 typedef
 919    struct {
 920       UChar  Name[8];
 921       UInt32 Value;
 922       UInt16 SectionNumber;
 923       UInt16 Type;
 924       UChar  StorageClass;
 925       UChar  NumberOfAuxSymbols;
 926    }
 927    COFF_symbol;
 928
 929 #define sizeof_COFF_symbol 18
 930
 931
 932 typedef
 933    struct {
 934       UInt32 VirtualAddress;
 935       UInt32 SymbolTableIndex;
 936       UInt16 Type;
 937    }
 938    COFF_reloc;
 939
 940 #define sizeof_COFF_reloc 10
 941
 942
 943 /* From PE spec doc, section 3.3.2 */
 944 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
 945    windows.h -- for the same purpose, but I want to know what I'm
 946    getting, here. */
 947 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
 948 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
 949 #define MYIMAGE_FILE_DLL                 0x2000
 950 #define MYIMAGE_FILE_SYSTEM              0x1000
 951 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
 952 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
 953 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
 954
 955 /* From PE spec doc, section 5.4.2 and 5.4.4 */
 956 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
 957 #define MYIMAGE_SYM_CLASS_STATIC         3
 958 #define MYIMAGE_SYM_UNDEFINED            0
 959
 960 /* From PE spec doc, section 4.1 */
 961 #define MYIMAGE_SCN_CNT_CODE             0x00000020
 962 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
 963
 964 /* From PE spec doc, section 5.2.1 */
 965 #define MYIMAGE_REL_I386_DIR32           0x0006
 966 #define MYIMAGE_REL_I386_REL32           0x0014
 967
 968
 969 /* We use myindex to calculate array addresses, rather than
 970    simply doing the normal subscript thing.  That's because
 971    some of the above structs have sizes which are not
 972    a whole number of words.  GCC rounds their sizes up to a
 973    whole number of words, which means that the address calcs
 974    arising from using normal C indexing or pointer arithmetic
 975    are just plain wrong.  Sigh.
 976 */
 977 static UChar *
 978 myindex ( int scale, void* base, int index )
 979 {
 980    return
 981       ((UChar*)base) + scale * index;
 982 }
 983
 984
 985 static void
 986 printName ( UChar* name, UChar* strtab )
 987 {
 988    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
 989       UInt32 strtab_offset = * (UInt32*)(name+4);
 990       fprintf ( stderr, "%s", strtab + strtab_offset );
 991    } else {
 992       int i;
 993       for (i = 0; i < 8; i++) {
 994          if (name[i] == 0) break;
 995          fprintf ( stderr, "%c", name[i] );
 996       }
 997    }
 998 }
 999
1000
1001 static void
1002 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1003 {
1004    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1005       UInt32 strtab_offset = * (UInt32*)(name+4);
1006       strncpy ( dst, strtab+strtab_offset, dstSize );
1007       dst[dstSize-1] = 0;
1008    } else {
1009       int i = 0;
1010       while (1) {
1011          if (i >= 8) break;
1012          if (name[i] == 0) break;
1013          dst[i] = name[i];
1014          i++;
1015       }
1016       dst[i] = 0;
1017    }
1018 }
1019
1020
1021 static UChar *
1022 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1023 {
1024    UChar* newstr;
1025    /* If the string is longer than 8 bytes, look in the
1026       string table for it -- this will be correctly zero terminated.
1027    */
1028    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1029       UInt32 strtab_offset = * (UInt32*)(name+4);
1030       return ((UChar*)strtab) + strtab_offset;
1031    }
1032    /* Otherwise, if shorter than 8 bytes, return the original,
1033       which by defn is correctly terminated.
1034    */
1035    if (name[7]==0) return name;
1036    /* The annoying case: 8 bytes.  Copy into a temporary
1037       (which is never freed ...)
1038    */
1039    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1040    ASSERT(newstr);
1041    strncpy(newstr,name,8);
1042    newstr[8] = 0;
1043    return newstr;
1044 }
1045
1046
1047 /* Just compares the short names (first 8 chars) */
1048 static COFF_section *
1049 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1050 {
1051    int i;
1052    COFF_header* hdr
1053       = (COFF_header*)(oc->image);
1054    COFF_section* sectab
1055       = (COFF_section*) (
1056            ((UChar*)(oc->image))
1057            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1058         );
1059    for (i = 0; i < hdr->NumberOfSections; i++) {
1060       UChar* n1;
1061       UChar* n2;
1062       COFF_section* section_i
1063          = (COFF_section*)
1064            myindex ( sizeof_COFF_section, sectab, i );
1065       n1 = (UChar*) &(section_i->Name);
1066       n2 = name;
1067       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1068           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1069           n1[6]==n2[6] && n1[7]==n2[7])
1070          return section_i;
1071    }
1072
1073    return NULL;
1074 }
1075
1076
1077 static void
1078 zapTrailingAtSign ( UChar* sym )
1079 {
1080 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1081    int i, j;
1082    if (sym[0] == 0) return;
1083    i = 0;
1084    while (sym[i] != 0) i++;
1085    i--;
1086    j = i;
1087    while (j > 0 && my_isdigit(sym[j])) j--;
1088    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1089 #  undef my_isdigit
1090 }
1091
1092
1093 static int
1094 ocVerifyImage_PEi386 ( ObjectCode* oc )
1095 {
1096    int i, j;
1097    COFF_header*  hdr;
1098    COFF_section* sectab;
1099    COFF_symbol*  symtab;
1100    UChar*        strtab;
1101    /* fprintf(stderr, "\nLOADING %s\n", oc->fileName); */
1102    hdr = (COFF_header*)(oc->image);
1103    sectab = (COFF_section*) (
1104                ((UChar*)(oc->image))
1105                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1106             );
1107    symtab = (COFF_symbol*) (
1108                ((UChar*)(oc->image))
1109                + hdr->PointerToSymbolTable
1110             );
1111    strtab = ((UChar*)symtab)
1112             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1113
1114    if (hdr->Machine != 0x14c) {
1115       belch("Not x86 PEi386");
1116       return 0;
1117    }
1118    if (hdr->SizeOfOptionalHeader != 0) {
1119       belch("PEi386 with nonempty optional header");
1120       return 0;
1121    }
1122    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1123         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1124         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1125         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1126       belch("Not a PEi386 object file");
1127       return 0;
1128    }
1129    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1130         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1131       belch("Invalid PEi386 word size or endiannness: %d",
1132             (int)(hdr->Characteristics));
1133       return 0;
1134    }
1135    /* If the string table size is way crazy, this might indicate that
1136       there are more than 64k relocations, despite claims to the
1137       contrary.  Hence this test. */
1138    /* fprintf(stderr, "strtab size %d\n", * (UInt32*)strtab); */
1139    if (* (UInt32*)strtab > 600000) {
1140       /* Note that 600k has no special significance other than being
1141          big enough to handle the almost-2MB-sized lumps that
1142          constitute HSwin32*.o. */
1143       belch("PEi386 object has suspiciously large string table; > 64k relocs?");
1144       return 0;
1145    }
1146
1147    /* No further verification after this point; only debug printing. */
1148    i = 0;
1149    IF_DEBUG(linker, i=1);
1150    if (i == 0) return 1;
1151
1152    fprintf ( stderr,
1153              "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1154    fprintf ( stderr,
1155              "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1156    fprintf ( stderr,
1157              "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1158
1159    fprintf ( stderr, "\n" );
1160    fprintf ( stderr,
1161              "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1162    fprintf ( stderr,
1163              "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1164    fprintf ( stderr,
1165              "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1166    fprintf ( stderr,
1167              "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1168    fprintf ( stderr,
1169              "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1170    fprintf ( stderr,
1171              "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1172    fprintf ( stderr,
1173              "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1174
1175    /* Print the section table. */
1176    fprintf ( stderr, "\n" );
1177    for (i = 0; i < hdr->NumberOfSections; i++) {
1178       COFF_reloc* reltab;
1179       COFF_section* sectab_i
1180          = (COFF_section*)
1181            myindex ( sizeof_COFF_section, sectab, i );
1182       fprintf ( stderr,
1183                 "\n"
1184                 "section %d\n"
1185                 "     name `",
1186                 i
1187               );
1188       printName ( sectab_i->Name, strtab );
1189       fprintf ( stderr,
1190                 "'\n"
1191                 "    vsize %d\n"
1192                 "    vaddr %d\n"
1193                 "  data sz %d\n"
1194                 " data off %d\n"
1195                 "  num rel %d\n"
1196                 "  off rel %d\n"
1197                 "  ptr raw 0x%x\n",
1198                 sectab_i->VirtualSize,
1199                 sectab_i->VirtualAddress,
1200                 sectab_i->SizeOfRawData,
1201                 sectab_i->PointerToRawData,
1202                 sectab_i->NumberOfRelocations,
1203                 sectab_i->PointerToRelocations,
1204                 sectab_i->PointerToRawData
1205               );
1206       reltab = (COFF_reloc*) (
1207                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1208                );
1209
1210       for (j = 0; j < sectab_i->NumberOfRelocations; j++) {
1211          COFF_symbol* sym;
1212          COFF_reloc* rel = (COFF_reloc*)
1213                            myindex ( sizeof_COFF_reloc, reltab, j );
1214          fprintf ( stderr,
1215                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1216                    (UInt32)rel->Type,
1217                    rel->VirtualAddress );
1218          sym = (COFF_symbol*)
1219                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1220          printName ( sym->Name, strtab -10 );
1221          fprintf ( stderr, "'\n" );
1222       }
1223
1224       fprintf ( stderr, "\n" );
1225    }
1226    fprintf ( stderr, "\n" );
1227    fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
1228    fprintf ( stderr, "---START of string table---\n");
1229    for (i = 4; i < *(Int32*)strtab; i++) {
1230       if (strtab[i] == 0)
1231          fprintf ( stderr, "\n"); else
1232          fprintf( stderr, "%c", strtab[i] );
1233    }
1234    fprintf ( stderr, "--- END  of string table---\n");
1235
1236    fprintf ( stderr, "\n" );
1237    i = 0;
1238    while (1) {
1239       COFF_symbol* symtab_i;
1240       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1241       symtab_i = (COFF_symbol*)
1242                  myindex ( sizeof_COFF_symbol, symtab, i );
1243       fprintf ( stderr,
1244                 "symbol %d\n"
1245                 "     name `",
1246                 i
1247               );
1248       printName ( symtab_i->Name, strtab );
1249       fprintf ( stderr,
1250                 "'\n"
1251                 "    value 0x%x\n"
1252                 "   1+sec# %d\n"
1253                 "     type 0x%x\n"
1254                 "   sclass 0x%x\n"
1255                 "     nAux %d\n",
1256                 symtab_i->Value,
1257                 (Int32)(symtab_i->SectionNumber),
1258                 (UInt32)symtab_i->Type,
1259                 (UInt32)symtab_i->StorageClass,
1260                 (UInt32)symtab_i->NumberOfAuxSymbols
1261               );
1262       i += symtab_i->NumberOfAuxSymbols;
1263       i++;
1264    }
1265
1266    fprintf ( stderr, "\n" );
1267    return 1;
1268 }
1269
1270
1271 static int
1272 ocGetNames_PEi386 ( ObjectCode* oc )
1273 {
1274    COFF_header*  hdr;
1275    COFF_section* sectab;
1276    COFF_symbol*  symtab;
1277    UChar*        strtab;
1278
1279    UChar* sname;
1280    void*  addr;
1281    int    i;
1282
1283    hdr = (COFF_header*)(oc->image);
1284    sectab = (COFF_section*) (
1285                ((UChar*)(oc->image))
1286                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1287             );
1288    symtab = (COFF_symbol*) (
1289                ((UChar*)(oc->image))
1290                + hdr->PointerToSymbolTable
1291             );
1292    strtab = ((UChar*)(oc->image))
1293             + hdr->PointerToSymbolTable
1294             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1295
1296    /* Allocate space for any (local, anonymous) .bss sections. */
1297
1298    for (i = 0; i < hdr->NumberOfSections; i++) {
1299       UChar* zspace;
1300       COFF_section* sectab_i
1301          = (COFF_section*)
1302            myindex ( sizeof_COFF_section, sectab, i );
1303       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1304       if (sectab_i->VirtualSize == 0) continue;
1305       /* This is a non-empty .bss section.  Allocate zeroed space for
1306          it, and set its PointerToRawData field such that oc->image +
1307          PointerToRawData == addr_of_zeroed_space.  */
1308       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1309                               "ocGetNames_PEi386(anonymous bss)");
1310       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1311       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1312       /* fprintf(stderr, "BSS anon section at 0x%x\n", zspace); */
1313    }
1314
1315    /* Copy section information into the ObjectCode. */
1316
1317    for (i = 0; i < hdr->NumberOfSections; i++) {
1318       UChar* start;
1319       UChar* end;
1320       UInt32 sz;
1321
1322       SectionKind kind
1323          = SECTIONKIND_OTHER;
1324       COFF_section* sectab_i
1325          = (COFF_section*)
1326            myindex ( sizeof_COFF_section, sectab, i );
1327       IF_DEBUG(linker, belch("section name = %s\n", sectab_i->Name ));
1328
1329 #     if 0
1330       /* I'm sure this is the Right Way to do it.  However, the
1331          alternative of testing the sectab_i->Name field seems to
1332          work ok with Cygwin.
1333       */
1334       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1335           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1336          kind = SECTIONKIND_CODE_OR_RODATA;
1337 #     endif
1338
1339       if (0==strcmp(".text",sectab_i->Name) ||
1340           0==strcmp(".rodata",sectab_i->Name))
1341          kind = SECTIONKIND_CODE_OR_RODATA;
1342       if (0==strcmp(".data",sectab_i->Name) ||
1343           0==strcmp(".bss",sectab_i->Name))
1344          kind = SECTIONKIND_RWDATA;
1345
1346       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
1347       sz = sectab_i->SizeOfRawData;
1348       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
1349
1350       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
1351       end   = start + sz - 1;
1352
1353       if (kind == SECTIONKIND_OTHER
1354           /* Ignore sections called which contain stabs debugging
1355              information. */
1356           && 0 != strcmp(".stab", sectab_i->Name)
1357           && 0 != strcmp(".stabstr", sectab_i->Name)
1358          ) {
1359          belch("Unknown PEi386 section name `%s'", sectab_i->Name);
1360          return 0;
1361       }
1362
1363       if (kind != SECTIONKIND_OTHER && end >= start) {
1364          addSection(oc, kind, start, end);
1365          addProddableBlock(oc, start, end - start + 1);
1366       }
1367    }
1368
1369    /* Copy exported symbols into the ObjectCode. */
1370
1371    oc->n_symbols = hdr->NumberOfSymbols;
1372    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
1373                                   "ocGetNames_PEi386(oc->symbols)");
1374    /* Call me paranoid; I don't care. */
1375    for (i = 0; i < oc->n_symbols; i++)
1376       oc->symbols[i] = NULL;
1377
1378    i = 0;
1379    while (1) {
1380       COFF_symbol* symtab_i;
1381       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1382       symtab_i = (COFF_symbol*)
1383                  myindex ( sizeof_COFF_symbol, symtab, i );
1384
1385       addr  = NULL;
1386
1387       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
1388           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
1389          /* This symbol is global and defined, viz, exported */
1390          /* for MYIMAGE_SYMCLASS_EXTERNAL
1391                 && !MYIMAGE_SYM_UNDEFINED,
1392             the address of the symbol is:
1393                 address of relevant section + offset in section
1394          */
1395          COFF_section* sectabent
1396             = (COFF_section*) myindex ( sizeof_COFF_section,
1397                                         sectab,
1398                                         symtab_i->SectionNumber-1 );
1399          addr = ((UChar*)(oc->image))
1400                 + (sectabent->PointerToRawData
1401                    + symtab_i->Value);
1402       }
1403       else
1404       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
1405           && symtab_i->Value > 0) {
1406          /* This symbol isn't in any section at all, ie, global bss.
1407             Allocate zeroed space for it. */
1408          addr = stgCallocBytes(1, symtab_i->Value,
1409                                "ocGetNames_PEi386(non-anonymous bss)");
1410          addSection(oc, SECTIONKIND_RWDATA, addr,
1411                         ((UChar*)addr) + symtab_i->Value - 1);
1412          addProddableBlock(oc, addr, symtab_i->Value);
1413          /* fprintf(stderr, "BSS      section at 0x%x\n", addr); */
1414       }
1415
1416       if (addr != NULL) {
1417          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
1418          /* fprintf(stderr,"addSymbol %p `%s'\n", addr,sname); */
1419          IF_DEBUG(linker, belch("addSymbol %p `%s'\n", addr,sname);)
1420          ASSERT(i >= 0 && i < oc->n_symbols);
1421          /* cstring_from_COFF_symbol_name always succeeds. */
1422          oc->symbols[i] = sname;
1423          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
1424       } else {
1425 #        if 0
1426          fprintf ( stderr,
1427                    "IGNORING symbol %d\n"
1428                    "     name `",
1429                    i
1430                  );
1431          printName ( symtab_i->Name, strtab );
1432          fprintf ( stderr,
1433                    "'\n"
1434                    "    value 0x%x\n"
1435                    "   1+sec# %d\n"
1436                    "     type 0x%x\n"
1437                    "   sclass 0x%x\n"
1438                    "     nAux %d\n",
1439                    symtab_i->Value,
1440                    (Int32)(symtab_i->SectionNumber),
1441                    (UInt32)symtab_i->Type,
1442                    (UInt32)symtab_i->StorageClass,
1443                    (UInt32)symtab_i->NumberOfAuxSymbols
1444                  );
1445 #        endif
1446       }
1447
1448       i += symtab_i->NumberOfAuxSymbols;
1449       i++;
1450    }
1451
1452    return 1;
1453 }
1454
1455
1456 static int
1457 ocResolve_PEi386 ( ObjectCode* oc )
1458 {
1459    COFF_header*  hdr;
1460    COFF_section* sectab;
1461    COFF_symbol*  symtab;
1462    UChar*        strtab;
1463
1464    UInt32        A;
1465    UInt32        S;
1466    UInt32*       pP;
1467
1468    int i, j;
1469
1470    /* ToDo: should be variable-sized?  But is at least safe in the
1471       sense of buffer-overrun-proof. */
1472    char symbol[1000];
1473    /* fprintf(stderr, "resolving for %s\n", oc->fileName); */
1474
1475    hdr = (COFF_header*)(oc->image);
1476    sectab = (COFF_section*) (
1477                ((UChar*)(oc->image))
1478                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1479             );
1480    symtab = (COFF_symbol*) (
1481                ((UChar*)(oc->image))
1482                + hdr->PointerToSymbolTable
1483             );
1484    strtab = ((UChar*)(oc->image))
1485             + hdr->PointerToSymbolTable
1486             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1487
1488    for (i = 0; i < hdr->NumberOfSections; i++) {
1489       COFF_section* sectab_i
1490          = (COFF_section*)
1491            myindex ( sizeof_COFF_section, sectab, i );
1492       COFF_reloc* reltab
1493          = (COFF_reloc*) (
1494               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1495            );
1496
1497       /* Ignore sections called which contain stabs debugging
1498          information. */
1499       if (0 == strcmp(".stab", sectab_i->Name)
1500           || 0 == strcmp(".stabstr", sectab_i->Name))
1501          continue;
1502
1503       for (j = 0; j < sectab_i->NumberOfRelocations; j++) {
1504          COFF_symbol* sym;
1505          COFF_reloc* reltab_j
1506             = (COFF_reloc*)
1507               myindex ( sizeof_COFF_reloc, reltab, j );
1508
1509          /* the location to patch */
1510          pP = (UInt32*)(
1511                  ((UChar*)(oc->image))
1512                  + (sectab_i->PointerToRawData
1513                     + reltab_j->VirtualAddress
1514                     - sectab_i->VirtualAddress )
1515               );
1516          /* the existing contents of pP */
1517          A = *pP;
1518          /* the symbol to connect to */
1519          sym = (COFF_symbol*)
1520                myindex ( sizeof_COFF_symbol,
1521                          symtab, reltab_j->SymbolTableIndex );
1522          IF_DEBUG(linker,
1523                   fprintf ( stderr,
1524                             "reloc sec %2d num %3d:  type 0x%-4x   "
1525                             "vaddr 0x%-8x   name `",
1526                             i, j,
1527                             (UInt32)reltab_j->Type,
1528                             reltab_j->VirtualAddress );
1529                             printName ( sym->Name, strtab );
1530                             fprintf ( stderr, "'\n" ));
1531
1532          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1533             COFF_section* section_sym
1534                = findPEi386SectionCalled ( oc, sym->Name );
1535             if (!section_sym) {
1536                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
1537                return 0;
1538             }
1539             S = ((UInt32)(oc->image))
1540                 + (section_sym->PointerToRawData
1541                    + sym->Value);
1542          } else {
1543             copyName ( sym->Name, strtab, symbol, 1000-1 );
1544             (void*)S = lookupLocalSymbol( oc, symbol );
1545             if ((void*)S != NULL) goto foundit;
1546             (void*)S = lookupSymbol( symbol );
1547             if ((void*)S != NULL) goto foundit;
1548             zapTrailingAtSign ( symbol );
1549             (void*)S = lookupLocalSymbol( oc, symbol );
1550             if ((void*)S != NULL) goto foundit;
1551             (void*)S = lookupSymbol( symbol );
1552             if ((void*)S != NULL) goto foundit;
1553             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
1554             return 0;
1555            foundit:
1556          }
1557          checkProddableBlock(oc, pP);
1558          switch (reltab_j->Type) {
1559             case MYIMAGE_REL_I386_DIR32:
1560                *pP = A + S;
1561                break;
1562             case MYIMAGE_REL_I386_REL32:
1563                /* Tricky.  We have to insert a displacement at
1564                   pP which, when added to the PC for the _next_
1565                   insn, gives the address of the target (S).
1566                   Problem is to know the address of the next insn
1567                   when we only know pP.  We assume that this
1568                   literal field is always the last in the insn,
1569                   so that the address of the next insn is pP+4
1570                   -- hence the constant 4.
1571                   Also I don't know if A should be added, but so
1572                   far it has always been zero.
1573                */
1574                ASSERT(A==0);
1575                *pP = S - ((UInt32)pP) - 4;
1576                break;
1577             default:
1578                belch("%s: unhandled PEi386 relocation type %d",
1579                      oc->fileName, reltab_j->Type);
1580                return 0;
1581          }
1582
1583       }
1584    }
1585
1586    IF_DEBUG(linker, belch("completed %s", oc->fileName));
1587    return 1;
1588 }
1589
1590 #endif /* defined(OBJFORMAT_PEi386) */
1591
1592
1593 /* --------------------------------------------------------------------------
1594  * ELF specifics
1595  * ------------------------------------------------------------------------*/
1596
1597 #if defined(OBJFORMAT_ELF)
1598
1599 #define FALSE 0
1600 #define TRUE  1
1601
1602 #if defined(sparc_TARGET_ARCH)
1603 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
1604 #elif defined(i386_TARGET_ARCH)
1605 #  define ELF_TARGET_386    /* Used inside <elf.h> */
1606 #endif
1607 /* There is a similar case for IA64 in the Solaris2 headers if this
1608  * ever becomes relevant.
1609  */
1610
1611 #include <elf.h>
1612
1613 static char *
1614 findElfSection ( void* objImage, Elf32_Word sh_type )
1615 {
1616    int i;
1617    char* ehdrC = (char*)objImage;
1618    Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
1619    Elf32_Shdr* shdr = (Elf32_Shdr*)(ehdrC + ehdr->e_shoff);
1620    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1621    char* ptr = NULL;
1622    for (i = 0; i < ehdr->e_shnum; i++) {
1623       if (shdr[i].sh_type == sh_type
1624           /* Ignore the section header's string table. */
1625           && i != ehdr->e_shstrndx
1626           /* Ignore string tables named .stabstr, as they contain
1627              debugging info. */
1628           && 0 != strcmp(".stabstr", sh_strtab + shdr[i].sh_name)
1629          ) {
1630          ptr = ehdrC + shdr[i].sh_offset;
1631          break;
1632       }
1633    }
1634    return ptr;
1635 }
1636
1637
1638 static int
1639 ocVerifyImage_ELF ( ObjectCode* oc )
1640 {
1641    Elf32_Shdr* shdr;
1642    Elf32_Sym*  stab;
1643    int i, j, nent, nstrtab, nsymtabs;
1644    char* sh_strtab;
1645    char* strtab;
1646
1647    char*       ehdrC = (char*)(oc->image);
1648    Elf32_Ehdr* ehdr  = ( Elf32_Ehdr*)ehdrC;
1649
1650    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
1651        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
1652        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
1653        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
1654       belch("%s: not an ELF header", oc->fileName);
1655       return 0;
1656    }
1657    IF_DEBUG(linker,belch( "Is an ELF header" ));
1658
1659    if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
1660       belch("%s: not 32 bit ELF", oc->fileName);
1661       return 0;
1662    }
1663
1664    IF_DEBUG(linker,belch( "Is 32 bit ELF" ));
1665
1666    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
1667        IF_DEBUG(linker,belch( "Is little-endian" ));
1668    } else
1669    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
1670        IF_DEBUG(linker,belch( "Is big-endian" ));
1671    } else {
1672        belch("%s: unknown endiannness", oc->fileName);
1673        return 0;
1674    }
1675
1676    if (ehdr->e_type != ET_REL) {
1677       belch("%s: not a relocatable object (.o) file", oc->fileName);
1678       return 0;
1679    }
1680    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
1681
1682    IF_DEBUG(linker,belch( "Architecture is " ));
1683    switch (ehdr->e_machine) {
1684       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
1685       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
1686       default:       IF_DEBUG(linker,belch( "unknown" ));
1687                      belch("%s: unknown architecture", oc->fileName);
1688                      return 0;
1689    }
1690
1691    IF_DEBUG(linker,belch(
1692              "\nSection header table: start %d, n_entries %d, ent_size %d",
1693              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
1694
1695    ASSERT (ehdr->e_shentsize == sizeof(Elf32_Shdr));
1696
1697    shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1698
1699    if (ehdr->e_shstrndx == SHN_UNDEF) {
1700       belch("%s: no section header string table", oc->fileName);
1701       return 0;
1702    } else {
1703       IF_DEBUG(linker,belch( "Section header string table is section %d",
1704                           ehdr->e_shstrndx));
1705       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1706    }
1707
1708    for (i = 0; i < ehdr->e_shnum; i++) {
1709       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
1710       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
1711       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
1712       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
1713       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
1714                ehdrC + shdr[i].sh_offset,
1715                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
1716
1717       if (shdr[i].sh_type == SHT_REL) {
1718           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
1719       } else if (shdr[i].sh_type == SHT_RELA) {
1720           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
1721       } else {
1722           IF_DEBUG(linker,fprintf(stderr,"     "));
1723       }
1724       if (sh_strtab) {
1725           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
1726       }
1727    }
1728
1729    IF_DEBUG(linker,belch( "\nString tables" ));
1730    strtab = NULL;
1731    nstrtab = 0;
1732    for (i = 0; i < ehdr->e_shnum; i++) {
1733       if (shdr[i].sh_type == SHT_STRTAB
1734           /* Ignore the section header's string table. */
1735           && i != ehdr->e_shstrndx
1736           /* Ignore string tables named .stabstr, as they contain
1737              debugging info. */
1738           && 0 != strcmp(".stabstr", sh_strtab + shdr[i].sh_name)
1739          ) {
1740          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
1741          strtab = ehdrC + shdr[i].sh_offset;
1742          nstrtab++;
1743       }
1744    }
1745    if (nstrtab != 1) {
1746       belch("%s: no string tables, or too many", oc->fileName);
1747       return 0;
1748    }
1749
1750    nsymtabs = 0;
1751    IF_DEBUG(linker,belch( "\nSymbol tables" ));
1752    for (i = 0; i < ehdr->e_shnum; i++) {
1753       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1754       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
1755       nsymtabs++;
1756       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1757       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1758       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
1759                nent,
1760                shdr[i].sh_size % sizeof(Elf32_Sym)
1761              ));
1762       if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
1763          belch("%s: non-integral number of symbol table entries", oc->fileName);
1764          return 0;
1765       }
1766       for (j = 0; j < nent; j++) {
1767          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
1768          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
1769                              (int)stab[j].st_shndx,
1770                              (int)stab[j].st_size,
1771                              (char*)stab[j].st_value ));
1772
1773          IF_DEBUG(linker,fprintf(stderr, "type=" ));
1774          switch (ELF32_ST_TYPE(stab[j].st_info)) {
1775             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
1776             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
1777             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
1778             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
1779             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
1780             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
1781          }
1782          IF_DEBUG(linker,fprintf(stderr, "  " ));
1783
1784          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
1785          switch (ELF32_ST_BIND(stab[j].st_info)) {
1786             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
1787             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
1788             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
1789             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
1790          }
1791          IF_DEBUG(linker,fprintf(stderr, "  " ));
1792
1793          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
1794       }
1795    }
1796
1797    if (nsymtabs == 0) {
1798       belch("%s: didn't find any symbol tables", oc->fileName);
1799       return 0;
1800    }
1801
1802    return 1;
1803 }
1804
1805
1806 static int
1807 ocGetNames_ELF ( ObjectCode* oc )
1808 {
1809    int i, j, k, nent;
1810    Elf32_Sym* stab;
1811
1812    char*       ehdrC      = (char*)(oc->image);
1813    Elf32_Ehdr* ehdr       = (Elf32_Ehdr*)ehdrC;
1814    char*       strtab     = findElfSection ( ehdrC, SHT_STRTAB );
1815    Elf32_Shdr* shdr       = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
1816    char*       sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
1817
1818    ASSERT(symhash != NULL);
1819
1820    if (!strtab) {
1821       belch("%s: no strtab", oc->fileName);
1822       return 0;
1823    }
1824
1825    k = 0;
1826    for (i = 0; i < ehdr->e_shnum; i++) {
1827
1828       /* make a section entry for relevant sections */
1829       SectionKind kind = SECTIONKIND_OTHER;
1830       if (!strcmp(".data",sh_strtab+shdr[i].sh_name) ||
1831           !strcmp(".data1",sh_strtab+shdr[i].sh_name) ||
1832           !strcmp(".bss",sh_strtab+shdr[i].sh_name))
1833           kind = SECTIONKIND_RWDATA;
1834       if (!strcmp(".text",sh_strtab+shdr[i].sh_name) ||
1835           !strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
1836           !strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
1837           kind = SECTIONKIND_CODE_OR_RODATA;
1838
1839       if (!strcmp(".bss",sh_strtab+shdr[i].sh_name) && shdr[i].sh_size > 0) {
1840          /* This is a non-empty .bss section.  Allocate zeroed space for
1841             it, and set its .sh_offset field such that
1842             ehdrC + .sh_offset == addr_of_zeroed_space.  */
1843          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
1844                                        "ocGetNames_ELF(BSS)");
1845          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
1846          /*
1847          fprintf(stderr, "BSS section at 0x%x, size %d\n",
1848                          zspace, shdr[i].sh_size);
1849          */
1850       }
1851
1852       /* fill in the section info */
1853       addSection(oc, kind, ehdrC + shdr[i].sh_offset,
1854                      ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
1855       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0)
1856          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
1857
1858       if (shdr[i].sh_type != SHT_SYMTAB) continue;
1859
1860       /* copy stuff into this module's object symbol table */
1861       stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
1862       nent = shdr[i].sh_size / sizeof(Elf32_Sym);
1863
1864       oc->n_symbols = nent;
1865       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
1866                                    "ocGetNames_ELF(oc->symbols)");
1867
1868       for (j = 0; j < nent; j++) {
1869
1870          char  isLocal = FALSE; /* avoids uninit-var warning */
1871          char* ad      = NULL;
1872          char* nm      = strtab + stab[j].st_name;
1873          int   secno   = stab[j].st_shndx;
1874
1875          /* Figure out if we want to add it; if so, set ad to its
1876             address.  Otherwise leave ad == NULL. */
1877
1878          if (secno == SHN_COMMON) {
1879             isLocal = FALSE;
1880             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
1881             /*
1882             fprintf(stderr, "COMMON symbol, size %d name %s\n",
1883                             stab[j].st_size, nm);
1884             */
1885             /* Pointless to do addProddableBlock() for this area,
1886                since the linker should never poke around in it. */
1887          }
1888          else
1889          if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL
1890                 || ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
1891               )
1892               /* and not an undefined symbol */
1893               && stab[j].st_shndx != SHN_UNDEF
1894               /* and not in a "special section" */
1895               && stab[j].st_shndx < SHN_LORESERVE
1896               &&
1897               /* and it's a not a section or string table or anything silly */
1898               ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
1899                 ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
1900                 ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE
1901               )
1902             ) {
1903             /* Section 0 is the undefined section, hence > and not >=. */
1904             ASSERT(secno > 0 && secno < ehdr->e_shnum);
1905             /*
1906             if (shdr[secno].sh_type == SHT_NOBITS) {
1907                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
1908                                stab[j].st_size, stab[j].st_value, nm);
1909             }
1910             */
1911             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
1912             if (ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL) {
1913                IF_DEBUG(linker,belch( "addOTabName(LOCL): %10p  %s %s",
1914                                       ad, oc->fileName, nm ));
1915                isLocal = TRUE;
1916             } else {
1917                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
1918                                       ad, oc->fileName, nm ));
1919                isLocal = FALSE;
1920             }
1921          }
1922
1923          /* And the decision is ... */
1924
1925          if (ad != NULL) {
1926             ASSERT(nm != NULL);
1927             oc->symbols[j] = nm;
1928             /* Acquire! */
1929             if (isLocal) {
1930                ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, ad);
1931             } else {
1932                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
1933             }
1934          } else {
1935             /* Skip. */
1936             IF_DEBUG(linker,belch( "skipping `%s'",
1937                                    strtab + stab[j].st_name ));
1938             /*
1939             fprintf(stderr,
1940                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
1941                     (int)ELF32_ST_BIND(stab[j].st_info),
1942                     (int)ELF32_ST_TYPE(stab[j].st_info),
1943                     (int)stab[j].st_shndx,
1944                     strtab + stab[j].st_name
1945                    );
1946             */
1947             oc->symbols[j] = NULL;
1948          }
1949
1950       }
1951    }
1952
1953    return 1;
1954 }
1955
1956
1957 /* Do ELF relocations which lack an explicit addend.  All x86-linux
1958    relocations appear to be of this form. */
1959 static int
1960 do_Elf32_Rel_relocations ( ObjectCode* oc, char* ehdrC,
1961                            Elf32_Shdr* shdr, int shnum,
1962                            Elf32_Sym*  stab, char* strtab )
1963 {
1964    int j;
1965    char *symbol;
1966    Elf32_Word* targ;
1967    Elf32_Rel*  rtab = (Elf32_Rel*) (ehdrC + shdr[shnum].sh_offset);
1968    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rel);
1969    int target_shndx = shdr[shnum].sh_info;
1970    int symtab_shndx = shdr[shnum].sh_link;
1971    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
1972    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
1973    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
1974                           target_shndx, symtab_shndx ));
1975    for (j = 0; j < nent; j++) {
1976       Elf32_Addr offset = rtab[j].r_offset;
1977       Elf32_Word info   = rtab[j].r_info;
1978
1979       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
1980       Elf32_Word* pP = (Elf32_Word*)P;
1981       Elf32_Addr  A  = *pP;
1982       Elf32_Addr  S;
1983
1984       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
1985                              j, (void*)offset, (void*)info ));
1986       if (!info) {
1987          IF_DEBUG(linker,belch( " ZERO" ));
1988          S = 0;
1989       } else {
1990          /* First see if it is a nameless local symbol. */
1991          if (stab[ ELF32_R_SYM(info)].st_name == 0) {
1992             symbol = "(noname)";
1993             S = (Elf32_Addr)
1994                 (ehdrC + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
1995                        + stab[ELF32_R_SYM(info)].st_value);
1996          } else {
1997             /* No?  Should be in a symbol table then; first try the
1998                local one. */
1999             symbol = strtab+stab[ ELF32_R_SYM(info)].st_name;
2000             (void*)S = lookupLocalSymbol( oc, symbol );
2001             if ((void*)S == NULL)
2002                (void*)S = lookupSymbol( symbol );
2003          }
2004          if (!S) {
2005             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2006             return 0;
2007          }
2008          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2009       }
2010       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2011                              (void*)P, (void*)S, (void*)A ));
2012       checkProddableBlock ( oc, pP );
2013       switch (ELF32_R_TYPE(info)) {
2014 #        ifdef i386_TARGET_ARCH
2015          case R_386_32:   *pP = S + A;     break;
2016          case R_386_PC32: *pP = S + A - P; break;
2017 #        endif
2018          default:
2019             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2020                   oc->fileName, ELF32_R_TYPE(info));
2021             return 0;
2022       }
2023
2024    }
2025    return 1;
2026 }
2027
2028
2029 /* Do ELF relocations for which explicit addends are supplied.
2030    sparc-solaris relocations appear to be of this form. */
2031 static int
2032 do_Elf32_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2033                             Elf32_Shdr* shdr, int shnum,
2034                             Elf32_Sym*  stab, char* strtab )
2035 {
2036    int j;
2037    char *symbol;
2038    Elf32_Word* targ;
2039    Elf32_Rela* rtab = (Elf32_Rela*) (ehdrC + shdr[shnum].sh_offset);
2040    int         nent = shdr[shnum].sh_size / sizeof(Elf32_Rela);
2041    int target_shndx = shdr[shnum].sh_info;
2042    int symtab_shndx = shdr[shnum].sh_link;
2043    stab  = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2044    targ  = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2045    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2046                           target_shndx, symtab_shndx ));
2047    for (j = 0; j < nent; j++) {
2048       Elf32_Addr  offset = rtab[j].r_offset;
2049       Elf32_Word  info   = rtab[j].r_info;
2050       Elf32_Sword addend = rtab[j].r_addend;
2051       Elf32_Addr  P  = ((Elf32_Addr)targ) + offset;
2052       Elf32_Addr  A  = addend;
2053       Elf32_Addr  S;
2054 #     if defined(sparc_TARGET_ARCH)
2055       /* This #ifdef only serves to avoid unused-var warnings. */
2056       Elf32_Word* pP = (Elf32_Word*)P;
2057       Elf32_Word  w1, w2;
2058 #     endif
2059
2060       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2061                              j, (void*)offset, (void*)info,
2062                                 (void*)addend ));
2063       if (!info) {
2064          IF_DEBUG(linker,belch( " ZERO" ));
2065          S = 0;
2066       } else {
2067          /* First see if it is a nameless local symbol. */
2068          if (stab[ ELF32_R_SYM(info)].st_name == 0) {
2069             symbol = "(noname)";
2070             S = (Elf32_Addr)
2071                 (ehdrC + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
2072                        + stab[ELF32_R_SYM(info)].st_value);
2073          } else {
2074             /* No?  Should be in a symbol table then; first try the
2075                local one. */
2076             symbol = strtab+stab[ ELF32_R_SYM(info)].st_name;
2077             (void*)S = lookupLocalSymbol( oc, symbol );
2078             if ((void*)S == NULL)
2079                (void*)S = lookupSymbol( symbol );
2080          }
2081          if (!S) {
2082            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2083            return 0;
2084            /*
2085            S = 0x11223344;
2086            fprintf ( stderr, "S %p A %p S+A %p S+A-P %p\n",S,A,S+A,S+A-P);
2087            */
2088          }
2089          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2090       }
2091       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2092                                         (void*)P, (void*)S, (void*)A ));
2093       checkProddableBlock ( oc, (void*)P );
2094       switch (ELF32_R_TYPE(info)) {
2095 #        if defined(sparc_TARGET_ARCH)
2096          case R_SPARC_WDISP30:
2097             w1 = *pP & 0xC0000000;
2098             w2 = (Elf32_Word)((S + A - P) >> 2);
2099             ASSERT((w2 & 0xC0000000) == 0);
2100             w1 |= w2;
2101             *pP = w1;
2102             break;
2103          case R_SPARC_HI22:
2104             w1 = *pP & 0xFFC00000;
2105             w2 = (Elf32_Word)((S + A) >> 10);
2106             ASSERT((w2 & 0xFFC00000) == 0);
2107             w1 |= w2;
2108             *pP = w1;
2109             break;
2110          case R_SPARC_LO10:
2111             w1 = *pP & ~0x3FF;
2112             w2 = (Elf32_Word)((S + A) & 0x3FF);
2113             ASSERT((w2 & ~0x3FF) == 0);
2114             w1 |= w2;
2115             *pP = w1;
2116             break;
2117          /* According to the Sun documentation:
2118             R_SPARC_UA32
2119             This relocation type resembles R_SPARC_32, except it refers to an
2120             unaligned word. That is, the word to be relocated must be treated
2121             as four separate bytes with arbitrary alignment, not as a word
2122             aligned according to the architecture requirements.
2123
2124             (JRS: which means that freeloading on the R_SPARC_32 case
2125             is probably wrong, but hey ...)
2126          */
2127          case R_SPARC_UA32:
2128          case R_SPARC_32:
2129             w2 = (Elf32_Word)(S + A);
2130             *pP = w2;
2131             break;
2132 #        endif
2133          default:
2134             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2135                   oc->fileName, ELF32_R_TYPE(info));
2136             return 0;
2137       }
2138
2139    }
2140    return 1;
2141 }
2142
2143
2144 static int
2145 ocResolve_ELF ( ObjectCode* oc )
2146 {
2147    char *strtab;
2148    int   shnum, ok;
2149    Elf32_Sym*  stab = NULL;
2150    char*       ehdrC = (char*)(oc->image);
2151    Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
2152    Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
2153    char* sh_strtab  = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2154
2155    /* first find "the" symbol table */
2156    stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2157
2158    /* also go find the string table */
2159    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2160
2161    if (stab == NULL || strtab == NULL) {
2162       belch("%s: can't find string or symbol table", oc->fileName);
2163       return 0;
2164    }
2165
2166    /* Process the relocation sections. */
2167    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2168
2169       /* Skip sections called ".rel.stab".  These appear to contain
2170          relocation entries that, when done, make the stabs debugging
2171          info point at the right places.  We ain't interested in all
2172          dat jazz, mun. */
2173       if (0 == strcmp(".rel.stab", sh_strtab + shdr[shnum].sh_name))
2174          continue;
2175
2176       if (shdr[shnum].sh_type == SHT_REL ) {
2177          ok = do_Elf32_Rel_relocations ( oc, ehdrC, shdr,
2178                                          shnum, stab, strtab );
2179          if (!ok) return ok;
2180       }
2181       else
2182       if (shdr[shnum].sh_type == SHT_RELA) {
2183          ok = do_Elf32_Rela_relocations ( oc, ehdrC, shdr,
2184                                           shnum, stab, strtab );
2185          if (!ok) return ok;
2186       }
2187
2188    }
2189
2190    /* Free the local symbol table; we won't need it again. */
2191    freeHashTable(oc->lochash, NULL);
2192    oc->lochash = NULL;
2193
2194    return 1;
2195 }
2196
2197
2198 #endif /* ELF */