ghc/rts/Linker.c

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