ghc/rts/Linker.c

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