ghc/rts/Linker.c

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