ghc/rts/Linker.c

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