ghc/rts/Linker.c

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