ghc/rts/Linker.c

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