ghc/rts/Linker.c

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