ghc/rts/Linker.c

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