ghc/rts/Linker.c

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