ghc/rts/Linker.c

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