ghc/rts/Linker.c

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