ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Linker.c,v 1.105 2002/10/12 23:12:08 wolfgang Exp $
   3  *
   4  * (c) The GHC Team, 2000, 2001
   5  *
   6  * RTS Object Linker
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #if 0
  11 #include "PosixSource.h"
  12 #endif
  13 #include "Rts.h"
  14 #include "RtsFlags.h"
  15 #include "HsFFI.h"
  16 #include "Hash.h"
  17 #include "Linker.h"
  18 #include "LinkerInternals.h"
  19 #include "RtsUtils.h"
  20 #include "StoragePriv.h"
  21 #include "Schedule.h"
  22
  23 #ifdef HAVE_SYS_TYPES_H
  24 #include <sys/types.h>
  25 #endif
  26
  27 #include <stdlib.h>
  28 #include <string.h>
  29
  30 #ifdef HAVE_SYS_STAT_H
  31 #include <sys/stat.h>
  32 #endif
  33
  34 #if defined(HAVE_FRAMEWORK_HASKELLSUPPORT)
  35 #include <HaskellSupport/dlfcn.h>
  36 #elif defined(HAVE_DLFCN_H)
  37 #include <dlfcn.h>
  38 #endif
  39
  40 #if defined(cygwin32_TARGET_OS)
  41 #ifdef HAVE_DIRENT_H
  42 #include <dirent.h>
  43 #endif
  44
  45 #ifdef HAVE_SYS_TIME_H
  46 #include <sys/time.h>
  47 #endif
  48 #include <regex.h>
  49 #include <sys/fcntl.h>
  50 #include <sys/termios.h>
  51 #include <sys/utime.h>
  52 #include <sys/utsname.h>
  53 #include <sys/wait.h>
  54 #endif
  55
  56 #if defined(ia64_TARGET_ARCH)
  57 #define USE_MMAP
  58 #include <fcntl.h>
  59 #include <sys/mman.h>
  60 #endif
  61
  62 #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) || defined(freebsd_TARGET_OS)
  63 #  define OBJFORMAT_ELF
  64 #elif defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
  65 #  define OBJFORMAT_PEi386
  66 #  include <windows.h>
  67 #  include <math.h>
  68 #elif defined(darwin_TARGET_OS)
  69 #  include <mach-o/ppc/reloc.h>
  70 #  define OBJFORMAT_MACHO
  71 #  include <mach-o/loader.h>
  72 #  include <mach-o/nlist.h>
  73 #  include <mach-o/reloc.h>
  74 #endif
  75
  76 /* Hash table mapping symbol names to Symbol */
  77 static /*Str*/HashTable *symhash;
  78
  79 #if defined(OBJFORMAT_ELF)
  80 static int ocVerifyImage_ELF    ( ObjectCode* oc );
  81 static int ocGetNames_ELF       ( ObjectCode* oc );
  82 static int ocResolve_ELF        ( ObjectCode* oc );
  83 #elif defined(OBJFORMAT_PEi386)
  84 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
  85 static int ocGetNames_PEi386    ( ObjectCode* oc );
  86 static int ocResolve_PEi386     ( ObjectCode* oc );
  87 #elif defined(OBJFORMAT_MACHO)
  88 static int ocVerifyImage_MachO    ( ObjectCode* oc );
  89 static int ocGetNames_MachO       ( ObjectCode* oc );
  90 static int ocResolve_MachO        ( ObjectCode* oc );
  91 #endif
  92
  93 /* -----------------------------------------------------------------------------
  94  * Built-in symbols from the RTS
  95  */
  96
  97 typedef struct _RtsSymbolVal {
  98     char   *lbl;
  99     void   *addr;
 100 } RtsSymbolVal;
 101
 102
 103 #if !defined(PAR)
 104 #define Maybe_ForeignObj        SymX(mkForeignObjzh_fast)
 105
 106 #define Maybe_Stable_Names      SymX(mkWeakzh_fast)                     \
 107                                 SymX(makeStableNamezh_fast)             \
 108                                 SymX(finalizzeWeakzh_fast)
 109 #else
 110 /* These are not available in GUM!!! -- HWL */
 111 #define Maybe_ForeignObj
 112 #define Maybe_Stable_Names
 113 #endif
 114
 115 #if !defined (mingw32_TARGET_OS)
 116 #define RTS_POSIX_ONLY_SYMBOLS                  \
 117       SymX(stg_sig_install)                     \
 118       Sym(nocldstop)
 119 #endif
 120
 121 #if defined (cygwin32_TARGET_OS)
 122 #define RTS_MINGW_ONLY_SYMBOLS /**/
 123 /* Don't have the ability to read import libs / archives, so
 124  * we have to stupidly list a lot of what libcygwin.a
 125  * exports; sigh.
 126  */
 127 #define RTS_CYGWIN_ONLY_SYMBOLS                 \
 128       SymX(regfree)                             \
 129       SymX(regexec)                             \
 130       SymX(regerror)                            \
 131       SymX(regcomp)                             \
 132       SymX(__errno)                             \
 133       SymX(access)                              \
 134       SymX(chmod)                               \
 135       SymX(chdir)                               \
 136       SymX(close)                               \
 137       SymX(creat)                               \
 138       SymX(dup)                                 \
 139       SymX(dup2)                                \
 140       SymX(fstat)                               \
 141       SymX(fcntl)                               \
 142       SymX(getcwd)                              \
 143       SymX(getenv)                              \
 144       SymX(lseek)                               \
 145       SymX(open)                                \
 146       SymX(fpathconf)                           \
 147       SymX(pathconf)                            \
 148       SymX(stat)                                \
 149       SymX(pow)                                 \
 150       SymX(tanh)                                \
 151       SymX(cosh)                                \
 152       SymX(sinh)                                \
 153       SymX(atan)                                \
 154       SymX(acos)                                \
 155       SymX(asin)                                \
 156       SymX(tan)                                 \
 157       SymX(cos)                                 \
 158       SymX(sin)                                 \
 159       SymX(exp)                                 \
 160       SymX(log)                                 \
 161       SymX(sqrt)                                \
 162       SymX(localtime_r)                         \
 163       SymX(gmtime_r)                            \
 164       SymX(mktime)                              \
 165       Sym(_imp___tzname)                        \
 166       SymX(gettimeofday)                        \
 167       SymX(timezone)                            \
 168       SymX(tcgetattr)                           \
 169       SymX(tcsetattr)                           \
 170       SymX(memcpy)                              \
 171       SymX(memmove)                             \
 172       SymX(realloc)                             \
 173       SymX(malloc)                              \
 174       SymX(free)                                \
 175       SymX(fork)                                \
 176       SymX(lstat)                               \
 177       SymX(isatty)                              \
 178       SymX(mkdir)                               \
 179       SymX(opendir)                             \
 180       SymX(readdir)                             \
 181       SymX(rewinddir)                           \
 182       SymX(closedir)                            \
 183       SymX(link)                                \
 184       SymX(mkfifo)                              \
 185       SymX(pipe)                                \
 186       SymX(read)                                \
 187       SymX(rename)                              \
 188       SymX(rmdir)                               \
 189       SymX(select)                              \
 190       SymX(system)                              \
 191       SymX(write)                               \
 192       SymX(strcmp)                              \
 193       SymX(strcpy)                              \
 194       SymX(strncpy)                             \
 195       SymX(strerror)                            \
 196       SymX(sigaddset)                           \
 197       SymX(sigemptyset)                         \
 198       SymX(sigprocmask)                         \
 199       SymX(umask)                               \
 200       SymX(uname)                               \
 201       SymX(unlink)                              \
 202       SymX(utime)                               \
 203       SymX(waitpid)                             \
 204       Sym(__divdi3)                             \
 205       Sym(__udivdi3)                            \
 206       Sym(__moddi3)                             \
 207       Sym(__umoddi3)
 208
 209 #elif !defined(mingw32_TARGET_OS)
 210 #define RTS_MINGW_ONLY_SYMBOLS /**/
 211 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 212 #else /* defined(mingw32_TARGET_OS) */
 213 #define RTS_POSIX_ONLY_SYMBOLS  /**/
 214 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 215
 216 /* These are statically linked from the mingw libraries into the ghc
 217    executable, so we have to employ this hack. */
 218 #define RTS_MINGW_ONLY_SYMBOLS                  \
 219       SymX(memset)                              \
 220       SymX(inet_ntoa)                           \
 221       SymX(inet_addr)                           \
 222       SymX(htonl)                               \
 223       SymX(recvfrom)                            \
 224       SymX(listen)                              \
 225       SymX(bind)                                \
 226       SymX(shutdown)                            \
 227       SymX(connect)                             \
 228       SymX(htons)                               \
 229       SymX(ntohs)                               \
 230       SymX(getservbyname)                       \
 231       SymX(getservbyport)                       \
 232       SymX(getprotobynumber)                    \
 233       SymX(getprotobyname)                      \
 234       SymX(gethostbyname)                       \
 235       SymX(gethostbyaddr)                       \
 236       SymX(gethostname)                         \
 237       SymX(strcpy)                              \
 238       SymX(strncpy)                             \
 239       SymX(abort)                               \
 240       Sym(_alloca)                              \
 241       Sym(isxdigit)                             \
 242       Sym(isupper)                              \
 243       Sym(ispunct)                              \
 244       Sym(islower)                              \
 245       Sym(isspace)                              \
 246       Sym(isprint)                              \
 247       Sym(isdigit)                              \
 248       Sym(iscntrl)                              \
 249       Sym(isalpha)                              \
 250       Sym(isalnum)                              \
 251       SymX(strcmp)                              \
 252       SymX(memmove)                             \
 253       SymX(realloc)                             \
 254       SymX(malloc)                              \
 255       SymX(pow)                                 \
 256       SymX(tanh)                                \
 257       SymX(cosh)                                \
 258       SymX(sinh)                                \
 259       SymX(atan)                                \
 260       SymX(acos)                                \
 261       SymX(asin)                                \
 262       SymX(tan)                                 \
 263       SymX(cos)                                 \
 264       SymX(sin)                                 \
 265       SymX(exp)                                 \
 266       SymX(log)                                 \
 267       SymX(sqrt)                                \
 268       SymX(memcpy)                              \
 269       Sym(mktime)                               \
 270       Sym(_imp___timezone)                      \
 271       Sym(_imp___tzname)                        \
 272       Sym(_imp___iob)                           \
 273       Sym(localtime)                            \
 274       Sym(gmtime)                               \
 275       Sym(opendir)                              \
 276       Sym(readdir)                              \
 277       Sym(rewinddir)                            \
 278       Sym(closedir)                             \
 279       Sym(__divdi3)                             \
 280       Sym(__udivdi3)                            \
 281       Sym(__moddi3)                             \
 282       Sym(__umoddi3)
 283 #endif
 284
 285 #ifndef SMP
 286 # define MAIN_CAP_SYM SymX(MainCapability)
 287 #else
 288 # define MAIN_CAP_SYM
 289 #endif
 290
 291 #define RTS_SYMBOLS                             \
 292       Maybe_ForeignObj                          \
 293       Maybe_Stable_Names                        \
 294       Sym(StgReturn)                            \
 295       Sym(init_stack)                           \
 296       SymX(__stg_chk_0)                         \
 297       SymX(__stg_chk_1)                         \
 298       SymX(stg_chk_2)                           \
 299       SymX(stg_chk_3)                           \
 300       SymX(stg_chk_4)                           \
 301       SymX(stg_chk_5)                           \
 302       SymX(stg_chk_6)                           \
 303       SymX(stg_chk_7)                           \
 304       SymX(stg_chk_8)                           \
 305       Sym(stg_enterStackTop)                    \
 306       SymX(stg_gc_d1)                           \
 307       SymX(stg_gc_l1)                           \
 308       SymX(__stg_gc_enter_1)                    \
 309       SymX(stg_gc_enter_2)                      \
 310       SymX(stg_gc_enter_3)                      \
 311       SymX(stg_gc_enter_4)                      \
 312       SymX(stg_gc_enter_5)                      \
 313       SymX(stg_gc_enter_6)                      \
 314       SymX(stg_gc_enter_7)                      \
 315       SymX(stg_gc_enter_8)                      \
 316       SymX(stg_gc_f1)                           \
 317       SymX(stg_gc_noregs)                       \
 318       SymX(stg_gc_seq_1)                        \
 319       SymX(stg_gc_unbx_r1)                      \
 320       SymX(stg_gc_unpt_r1)                      \
 321       SymX(stg_gc_ut_0_1)                       \
 322       SymX(stg_gc_ut_1_0)                       \
 323       SymX(stg_gen_chk)                         \
 324       SymX(stg_yield_to_interpreter)            \
 325       SymX(ErrorHdrHook)                        \
 326       MAIN_CAP_SYM                              \
 327       SymX(MallocFailHook)                      \
 328       SymX(NoRunnableThreadsHook)               \
 329       SymX(OnExitHook)                          \
 330       SymX(OutOfHeapHook)                       \
 331       SymX(PatErrorHdrHook)                     \
 332       SymX(PostTraceHook)                       \
 333       SymX(PreTraceHook)                        \
 334       SymX(StackOverflowHook)                   \
 335       SymX(__encodeDouble)                      \
 336       SymX(__encodeFloat)                       \
 337       SymX(__gmpn_gcd_1)                        \
 338       SymX(__gmpz_cmp)                          \
 339       SymX(__gmpz_cmp_si)                       \
 340       SymX(__gmpz_cmp_ui)                       \
 341       SymX(__gmpz_get_si)                       \
 342       SymX(__gmpz_get_ui)                       \
 343       SymX(__int_encodeDouble)                  \
 344       SymX(__int_encodeFloat)                   \
 345       SymX(andIntegerzh_fast)                   \
 346       SymX(blockAsyncExceptionszh_fast)         \
 347       SymX(catchzh_fast)                        \
 348       SymX(cmp_thread)                          \
 349       SymX(complementIntegerzh_fast)            \
 350       SymX(cmpIntegerzh_fast)                   \
 351       SymX(cmpIntegerIntzh_fast)                \
 352       SymX(createAdjustor)                      \
 353       SymX(decodeDoublezh_fast)                 \
 354       SymX(decodeFloatzh_fast)                  \
 355       SymX(defaultsHook)                        \
 356       SymX(delayzh_fast)                        \
 357       SymX(deRefWeakzh_fast)                    \
 358       SymX(deRefStablePtrzh_fast)               \
 359       SymX(divExactIntegerzh_fast)              \
 360       SymX(divModIntegerzh_fast)                \
 361       SymX(forkzh_fast)                         \
 362       SymX(forkProcesszh_fast)                  \
 363       SymX(freeHaskellFunctionPtr)              \
 364       SymX(freeStablePtr)                       \
 365       SymX(gcdIntegerzh_fast)                   \
 366       SymX(gcdIntegerIntzh_fast)                \
 367       SymX(gcdIntzh_fast)                       \
 368       SymX(getProgArgv)                         \
 369       SymX(getStablePtr)                        \
 370       SymX(int2Integerzh_fast)                  \
 371       SymX(integer2Intzh_fast)                  \
 372       SymX(integer2Wordzh_fast)                 \
 373       SymX(isDoubleDenormalized)                \
 374       SymX(isDoubleInfinite)                    \
 375       SymX(isDoubleNaN)                         \
 376       SymX(isDoubleNegativeZero)                \
 377       SymX(isEmptyMVarzh_fast)                  \
 378       SymX(isFloatDenormalized)                 \
 379       SymX(isFloatInfinite)                     \
 380       SymX(isFloatNaN)                          \
 381       SymX(isFloatNegativeZero)                 \
 382       SymX(killThreadzh_fast)                   \
 383       SymX(makeStablePtrzh_fast)                \
 384       SymX(minusIntegerzh_fast)                 \
 385       SymX(mkApUpd0zh_fast)                     \
 386       SymX(myThreadIdzh_fast)                   \
 387       SymX(labelThreadzh_fast)                  \
 388       SymX(newArrayzh_fast)                     \
 389       SymX(newBCOzh_fast)                       \
 390       SymX(newByteArrayzh_fast)                 \
 391       SymX(newCAF)                              \
 392       SymX(newMVarzh_fast)                      \
 393       SymX(newMutVarzh_fast)                    \
 394       SymX(newPinnedByteArrayzh_fast)           \
 395       SymX(orIntegerzh_fast)                    \
 396       SymX(performGC)                           \
 397       SymX(plusIntegerzh_fast)                  \
 398       SymX(prog_argc)                           \
 399       SymX(prog_argv)                           \
 400       SymX(putMVarzh_fast)                      \
 401       SymX(quotIntegerzh_fast)                  \
 402       SymX(quotRemIntegerzh_fast)               \
 403       SymX(raisezh_fast)                        \
 404       SymX(remIntegerzh_fast)                   \
 405       SymX(resetNonBlockingFd)                  \
 406       SymX(resumeThread)                        \
 407       SymX(rts_apply)                           \
 408       SymX(rts_checkSchedStatus)                \
 409       SymX(rts_eval)                            \
 410       SymX(rts_evalIO)                          \
 411       SymX(rts_evalLazyIO)                      \
 412       SymX(rts_eval_)                           \
 413       SymX(rts_getBool)                         \
 414       SymX(rts_getChar)                         \
 415       SymX(rts_getDouble)                       \
 416       SymX(rts_getFloat)                        \
 417       SymX(rts_getInt)                          \
 418       SymX(rts_getInt32)                        \
 419       SymX(rts_getPtr)                          \
 420       SymX(rts_getStablePtr)                    \
 421       SymX(rts_getThreadId)                     \
 422       SymX(rts_getWord)                         \
 423       SymX(rts_getWord32)                       \
 424       SymX(rts_mkBool)                          \
 425       SymX(rts_mkChar)                          \
 426       SymX(rts_mkDouble)                        \
 427       SymX(rts_mkFloat)                         \
 428       SymX(rts_mkInt)                           \
 429       SymX(rts_mkInt16)                         \
 430       SymX(rts_mkInt32)                         \
 431       SymX(rts_mkInt64)                         \
 432       SymX(rts_mkInt8)                          \
 433       SymX(rts_mkPtr)                           \
 434       SymX(rts_mkStablePtr)                     \
 435       SymX(rts_mkString)                        \
 436       SymX(rts_mkWord)                          \
 437       SymX(rts_mkWord16)                        \
 438       SymX(rts_mkWord32)                        \
 439       SymX(rts_mkWord64)                        \
 440       SymX(rts_mkWord8)                         \
 441       SymX(run_queue_hd)                        \
 442       SymX(setProgArgv)                         \
 443       SymX(shutdownHaskellAndExit)              \
 444       SymX(stable_ptr_table)                    \
 445       SymX(stackOverflow)                       \
 446       SymX(stg_CAF_BLACKHOLE_info)              \
 447       SymX(stg_CHARLIKE_closure)                \
 448       SymX(stg_EMPTY_MVAR_info)                 \
 449       SymX(stg_IND_STATIC_info)                 \
 450       SymX(stg_INTLIKE_closure)                 \
 451       SymX(stg_MUT_ARR_PTRS_FROZEN_info)        \
 452       SymX(stg_WEAK_info)                       \
 453       SymX(stg_ap_1_upd_info)                   \
 454       SymX(stg_ap_2_upd_info)                   \
 455       SymX(stg_ap_3_upd_info)                   \
 456       SymX(stg_ap_4_upd_info)                   \
 457       SymX(stg_ap_5_upd_info)                   \
 458       SymX(stg_ap_6_upd_info)                   \
 459       SymX(stg_ap_7_upd_info)                   \
 460       SymX(stg_ap_8_upd_info)                   \
 461       SymX(stg_exit)                            \
 462       SymX(stg_sel_0_upd_info)                  \
 463       SymX(stg_sel_10_upd_info)                 \
 464       SymX(stg_sel_11_upd_info)                 \
 465       SymX(stg_sel_12_upd_info)                 \
 466       SymX(stg_sel_13_upd_info)                 \
 467       SymX(stg_sel_14_upd_info)                 \
 468       SymX(stg_sel_15_upd_info)                 \
 469       SymX(stg_sel_1_upd_info)                  \
 470       SymX(stg_sel_2_upd_info)                  \
 471       SymX(stg_sel_3_upd_info)                  \
 472       SymX(stg_sel_4_upd_info)                  \
 473       SymX(stg_sel_5_upd_info)                  \
 474       SymX(stg_sel_6_upd_info)                  \
 475       SymX(stg_sel_7_upd_info)                  \
 476       SymX(stg_sel_8_upd_info)                  \
 477       SymX(stg_sel_9_upd_info)                  \
 478       SymX(stg_seq_frame_info)                  \
 479       SymX(stg_upd_frame_info)                  \
 480       SymX(__stg_update_PAP)                    \
 481       SymX(suspendThread)                       \
 482       SymX(takeMVarzh_fast)                     \
 483       SymX(timesIntegerzh_fast)                 \
 484       SymX(tryPutMVarzh_fast)                   \
 485       SymX(tryTakeMVarzh_fast)                  \
 486       SymX(unblockAsyncExceptionszh_fast)       \
 487       SymX(unsafeThawArrayzh_fast)              \
 488       SymX(waitReadzh_fast)                     \
 489       SymX(waitWritezh_fast)                    \
 490       SymX(word2Integerzh_fast)                 \
 491       SymX(xorIntegerzh_fast)                   \
 492       SymX(yieldzh_fast)
 493
 494 #ifdef SUPPORT_LONG_LONGS
 495 #define RTS_LONG_LONG_SYMS                      \
 496       SymX(int64ToIntegerzh_fast)               \
 497       SymX(word64ToIntegerzh_fast)
 498 #else
 499 #define RTS_LONG_LONG_SYMS /* nothing */
 500 #endif
 501
 502 #ifdef ia64_TARGET_ARCH
 503 /* force these symbols to be present */
 504 #define RTS_EXTRA_SYMBOLS                       \
 505       Sym(__divsf3)
 506 #elif defined(powerpc_TARGET_ARCH)
 507 #define RTS_EXTRA_SYMBOLS                       \
 508       Sym(__divdi3)                             \
 509       Sym(__udivdi3)                            \
 510       Sym(__moddi3)                             \
 511       Sym(__umoddi3)                            \
 512       Sym(__ashldi3)                            \
 513       Sym(__ashrdi3)                            \
 514       Sym(__lshrdi3)                            \
 515       Sym(__eprintf)
 516 #else
 517 #define RTS_EXTRA_SYMBOLS /* nothing */
 518 #endif
 519
 520 /* entirely bogus claims about types of these symbols */
 521 #define Sym(vvv)  extern void (vvv);
 522 #define SymX(vvv) /**/
 523 RTS_SYMBOLS
 524 RTS_LONG_LONG_SYMS
 525 RTS_EXTRA_SYMBOLS
 526 RTS_POSIX_ONLY_SYMBOLS
 527 RTS_MINGW_ONLY_SYMBOLS
 528 RTS_CYGWIN_ONLY_SYMBOLS
 529 #undef Sym
 530 #undef SymX
 531
 532 #ifdef LEADING_UNDERSCORE
 533 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
 534 #else
 535 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
 536 #endif
 537
 538 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 539                     (void*)(&(vvv)) },
 540 #define SymX(vvv) Sym(vvv)
 541
 542 static RtsSymbolVal rtsSyms[] = {
 543       RTS_SYMBOLS
 544       RTS_LONG_LONG_SYMS
 545       RTS_EXTRA_SYMBOLS
 546       RTS_POSIX_ONLY_SYMBOLS
 547       RTS_MINGW_ONLY_SYMBOLS
 548       RTS_CYGWIN_ONLY_SYMBOLS
 549       { 0, 0 } /* sentinel */
 550 };
 551
 552 /* -----------------------------------------------------------------------------
 553  * Insert symbols into hash tables, checking for duplicates.
 554  */
 555 static void ghciInsertStrHashTable ( char* obj_name,
 556                                      HashTable *table,
 557                                      char* key,
 558                                      void *data
 559                                    )
 560 {
 561    if (lookupHashTable(table, (StgWord)key) == NULL)
 562    {
 563       insertStrHashTable(table, (StgWord)key, data);
 564       return;
 565    }
 566    fprintf(stderr,
 567       "\n\n"
 568       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
 569       "   %s\n"
 570       "whilst processing object file\n"
 571       "   %s\n"
 572       "This could be caused by:\n"
 573       "   * Loading two different object files which export the same symbol\n"
 574       "   * Specifying the same object file twice on the GHCi command line\n"
 575       "   * An incorrect `package.conf' entry, causing some object to be\n"
 576       "     loaded twice.\n"
 577       "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
 578       "\n",
 579       (char*)key,
 580       obj_name
 581    );
 582    exit(1);
 583 }
 584
 585
 586 /* -----------------------------------------------------------------------------
 587  * initialize the object linker
 588  */
 589
 590
 591 static int linker_init_done = 0 ;
 592
 593 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 594 static void *dl_prog_handle;
 595 #endif
 596
 597 void
 598 initLinker( void )
 599 {
 600     RtsSymbolVal *sym;
 601
 602     /* Make initLinker idempotent, so we can call it
 603        before evey relevant operation; that means we
 604        don't need to initialise the linker separately */
 605     if (linker_init_done == 1) { return; } else {
 606       linker_init_done = 1;
 607     }
 608
 609     symhash = allocStrHashTable();
 610
 611     /* populate the symbol table with stuff from the RTS */
 612     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 613         ghciInsertStrHashTable("(GHCi built-in symbols)",
 614                                symhash, sym->lbl, sym->addr);
 615     }
 616 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 617     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
 618 #   endif
 619 }
 620
 621 /* -----------------------------------------------------------------------------
 622  *                  Loading DLL or .so dynamic libraries
 623  * -----------------------------------------------------------------------------
 624  *
 625  * Add a DLL from which symbols may be found.  In the ELF case, just
 626  * do RTLD_GLOBAL-style add, so no further messing around needs to
 627  * happen in order that symbols in the loaded .so are findable --
 628  * lookupSymbol() will subsequently see them by dlsym on the program's
 629  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
 630  *
 631  * In the PEi386 case, open the DLLs and put handles to them in a
 632  * linked list.  When looking for a symbol, try all handles in the
 633  * list.  This means that we need to load even DLLs that are guaranteed
 634  * to be in the ghc.exe image already, just so we can get a handle
 635  * to give to loadSymbol, so that we can find the symbols.  For such
 636  * libraries, the LoadLibrary call should be a no-op except for returning
 637  * the handle.
 638  *
 639  */
 640
 641 #if defined(OBJFORMAT_PEi386)
 642 /* A record for storing handles into DLLs. */
 643
 644 typedef
 645    struct _OpenedDLL {
 646       char*              name;
 647       struct _OpenedDLL* next;
 648       HINSTANCE instance;
 649    }
 650    OpenedDLL;
 651
 652 /* A list thereof. */
 653 static OpenedDLL* opened_dlls = NULL;
 654 #endif
 655
 656 char *
 657 addDLL( char *dll_name )
 658 {
 659 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 660    /* ------------------- ELF DLL loader ------------------- */
 661    void *hdl;
 662    char *errmsg;
 663
 664    initLinker();
 665
 666    hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
 667    if (hdl == NULL) {
 668       /* dlopen failed; return a ptr to the error msg. */
 669       errmsg = dlerror();
 670       if (errmsg == NULL) errmsg = "addDLL: unknown error";
 671       return errmsg;
 672    } else {
 673       return NULL;
 674    }
 675    /*NOTREACHED*/
 676
 677 #  elif defined(OBJFORMAT_PEi386)
 678    /* ------------------- Win32 DLL loader ------------------- */
 679
 680    char*      buf;
 681    OpenedDLL* o_dll;
 682    HINSTANCE  instance;
 683
 684    initLinker();
 685
 686    /* fprintf(stderr, "\naddDLL; dll_name = `%s'\n", dll_name); */
 687
 688    /* See if we've already got it, and ignore if so. */
 689    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 690       if (0 == strcmp(o_dll->name, dll_name))
 691          return NULL;
 692    }
 693
 694    /* The file name has no suffix (yet) so that we can try
 695       both foo.dll and foo.drv
 696
 697       The documentation for LoadLibrary says:
 698         If no file name extension is specified in the lpFileName
 699         parameter, the default library extension .dll is
 700         appended. However, the file name string can include a trailing
 701         point character (.) to indicate that the module name has no
 702         extension. */
 703
 704    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
 705    sprintf(buf, "%s.DLL", dll_name);
 706    instance = LoadLibrary(buf);
 707    if (instance == NULL) {
 708          sprintf(buf, "%s.DRV", dll_name);      // KAA: allow loading of drivers (like winspool.drv)
 709          instance = LoadLibrary(buf);
 710          if (instance == NULL) {
 711                 free(buf);
 712
 713             /* LoadLibrary failed; return a ptr to the error msg. */
 714             return "addDLL: unknown error";
 715          }
 716    }
 717    free(buf);
 718
 719    /* Add this DLL to the list of DLLs in which to search for symbols. */
 720    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
 721    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
 722    strcpy(o_dll->name, dll_name);
 723    o_dll->instance = instance;
 724    o_dll->next     = opened_dlls;
 725    opened_dlls     = o_dll;
 726
 727    return NULL;
 728 #  else
 729    barf("addDLL: not implemented on this platform");
 730 #  endif
 731 }
 732
 733 /* -----------------------------------------------------------------------------
 734  * lookup a symbol in the hash table
 735  */
 736 void *
 737 lookupSymbol( char *lbl )
 738 {
 739     void *val;
 740     initLinker() ;
 741     ASSERT(symhash != NULL);
 742     val = lookupStrHashTable(symhash, lbl);
 743
 744     if (val == NULL) {
 745 #       if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 746         return dlsym(dl_prog_handle, lbl);
 747 #       elif defined(OBJFORMAT_PEi386)
 748         OpenedDLL* o_dll;
 749         void* sym;
 750         for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 751           /* fprintf(stderr, "look in %s for %s\n", o_dll->name, lbl); */
 752            if (lbl[0] == '_') {
 753               /* HACK: if the name has an initial underscore, try stripping
 754                  it off & look that up first. I've yet to verify whether there's
 755                  a Rule that governs whether an initial '_' *should always* be
 756                  stripped off when mapping from import lib name to the DLL name.
 757               */
 758               sym = GetProcAddress(o_dll->instance, (lbl+1));
 759               if (sym != NULL) {
 760                 /*fprintf(stderr, "found %s in %s\n", lbl+1,o_dll->name); fflush(stderr);*/
 761                 return sym;
 762               }
 763            }
 764            sym = GetProcAddress(o_dll->instance, lbl);
 765            if (sym != NULL) {
 766              /*fprintf(stderr, "found %s in %s\n", lbl,o_dll->name); fflush(stderr);*/
 767              return sym;
 768            }
 769         }
 770         return NULL;
 771 #       else
 772         ASSERT(2+2 == 5);
 773         return NULL;
 774 #       endif
 775     } else {
 776         return val;
 777     }
 778 }
 779
 780 static
 781 __attribute((unused))
 782 void *
 783 lookupLocalSymbol( ObjectCode* oc, char *lbl )
 784 {
 785     void *val;
 786     initLinker() ;
 787     val = lookupStrHashTable(oc->lochash, lbl);
 788
 789     if (val == NULL) {
 790         return NULL;
 791     } else {
 792         return val;
 793     }
 794 }
 795
 796
 797 /* -----------------------------------------------------------------------------
 798  * Debugging aid: look in GHCi's object symbol tables for symbols
 799  * within DELTA bytes of the specified address, and show their names.
 800  */
 801 #ifdef DEBUG
 802 void ghci_enquire ( char* addr );
 803
 804 void ghci_enquire ( char* addr )
 805 {
 806    int   i;
 807    char* sym;
 808    char* a;
 809    const int DELTA = 64;
 810    ObjectCode* oc;
 811
 812    initLinker();
 813
 814    for (oc = objects; oc; oc = oc->next) {
 815       for (i = 0; i < oc->n_symbols; i++) {
 816          sym = oc->symbols[i];
 817          if (sym == NULL) continue;
 818          /* fprintf(stderr, "enquire %p %p\n", sym, oc->lochash); */
 819          a = NULL;
 820          if (oc->lochash != NULL)
 821             a = lookupStrHashTable(oc->lochash, sym);
 822          if (a == NULL)
 823             a = lookupStrHashTable(symhash, sym);
 824          if (a == NULL) {
 825             /* fprintf(stderr, "ghci_enquire: can't find %s\n", sym); */
 826          }
 827          else if (addr-DELTA <= a && a <= addr+DELTA) {
 828             fprintf(stderr, "%p + %3d  ==  `%s'\n", addr, a - addr, sym);
 829          }
 830       }
 831    }
 832 }
 833 #endif
 834
 835 #ifdef ia64_TARGET_ARCH
 836 static unsigned int PLTSize(void);
 837 #endif
 838
 839 /* -----------------------------------------------------------------------------
 840  * Load an obj (populate the global symbol table, but don't resolve yet)
 841  *
 842  * Returns: 1 if ok, 0 on error.
 843  */
 844 HsInt
 845 loadObj( char *path )
 846 {
 847    ObjectCode* oc;
 848    struct stat st;
 849    int r, n;
 850 #ifdef USE_MMAP
 851    int fd, pagesize;
 852    void *map_addr;
 853 #else
 854    FILE *f;
 855 #endif
 856
 857    initLinker();
 858
 859    /* fprintf(stderr, "loadObj %s\n", path ); */
 860
 861    /* Check that we haven't already loaded this object.  Don't give up
 862       at this stage; ocGetNames_* will barf later. */
 863    {
 864        ObjectCode *o;
 865        int is_dup = 0;
 866        for (o = objects; o; o = o->next) {
 867           if (0 == strcmp(o->fileName, path))
 868              is_dup = 1;
 869        }
 870        if (is_dup) {
 871          fprintf(stderr,
 872             "\n\n"
 873             "GHCi runtime linker: warning: looks like you're trying to load the\n"
 874             "same object file twice:\n"
 875             "   %s\n"
 876             "GHCi will continue, but a duplicate-symbol error may shortly follow.\n"
 877             "\n"
 878             , path);
 879        }
 880    }
 881
 882    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
 883
 884 #  if defined(OBJFORMAT_ELF)
 885    oc->formatName = "ELF";
 886 #  elif defined(OBJFORMAT_PEi386)
 887    oc->formatName = "PEi386";
 888 #  elif defined(OBJFORMAT_MACHO)
 889    oc->formatName = "Mach-O";
 890 #  else
 891    free(oc);
 892    barf("loadObj: not implemented on this platform");
 893 #  endif
 894
 895    r = stat(path, &st);
 896    if (r == -1) { return 0; }
 897
 898    /* sigh, strdup() isn't a POSIX function, so do it the long way */
 899    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
 900    strcpy(oc->fileName, path);
 901
 902    oc->fileSize          = st.st_size;
 903    oc->symbols           = NULL;
 904    oc->sections          = NULL;
 905    oc->lochash           = allocStrHashTable();
 906    oc->proddables        = NULL;
 907
 908    /* chain it onto the list of objects */
 909    oc->next              = objects;
 910    objects               = oc;
 911
 912 #ifdef USE_MMAP
 913 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
 914
 915    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
 916
 917    fd = open(path, O_RDONLY);
 918    if (fd == -1)
 919       barf("loadObj: can't open `%s'", path);
 920
 921    pagesize = getpagesize();
 922
 923 #ifdef ia64_TARGET_ARCH
 924    /* The PLT needs to be right before the object */
 925    n = ROUND_UP(PLTSize(), pagesize);
 926    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
 927    if (oc->plt == MAP_FAILED)
 928       barf("loadObj: can't allocate PLT");
 929
 930    oc->pltIndex = 0;
 931    map_addr = oc->plt + n;
 932 #endif
 933
 934    n = ROUND_UP(oc->fileSize, pagesize);
 935    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
 936    if (oc->image == MAP_FAILED)
 937       barf("loadObj: can't map `%s'", path);
 938
 939    close(fd);
 940
 941 #else /* !USE_MMAP */
 942
 943    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
 944
 945    /* load the image into memory */
 946    f = fopen(path, "rb");
 947    if (!f)
 948        barf("loadObj: can't read `%s'", path);
 949
 950    n = fread ( oc->image, 1, oc->fileSize, f );
 951    if (n != oc->fileSize)
 952       barf("loadObj: error whilst reading `%s'", path);
 953
 954    fclose(f);
 955
 956 #endif /* USE_MMAP */
 957
 958    /* verify the in-memory image */
 959 #  if defined(OBJFORMAT_ELF)
 960    r = ocVerifyImage_ELF ( oc );
 961 #  elif defined(OBJFORMAT_PEi386)
 962    r = ocVerifyImage_PEi386 ( oc );
 963 #  elif defined(OBJFORMAT_MACHO)
 964    r = ocVerifyImage_MachO ( oc );
 965 #  else
 966    barf("loadObj: no verify method");
 967 #  endif
 968    if (!r) { return r; }
 969
 970    /* build the symbol list for this image */
 971 #  if defined(OBJFORMAT_ELF)
 972    r = ocGetNames_ELF ( oc );
 973 #  elif defined(OBJFORMAT_PEi386)
 974    r = ocGetNames_PEi386 ( oc );
 975 #  elif defined(OBJFORMAT_MACHO)
 976    r = ocGetNames_MachO ( oc );
 977 #  else
 978    barf("loadObj: no getNames method");
 979 #  endif
 980    if (!r) { return r; }
 981
 982    /* loaded, but not resolved yet */
 983    oc->status = OBJECT_LOADED;
 984
 985    return 1;
 986 }
 987
 988 /* -----------------------------------------------------------------------------
 989  * resolve all the currently unlinked objects in memory
 990  *
 991  * Returns: 1 if ok, 0 on error.
 992  */
 993 HsInt
 994 resolveObjs( void )
 995 {
 996     ObjectCode *oc;
 997     int r;
 998
 999     initLinker();
1000
1001     for (oc = objects; oc; oc = oc->next) {
1002         if (oc->status != OBJECT_RESOLVED) {
1003 #           if defined(OBJFORMAT_ELF)
1004             r = ocResolve_ELF ( oc );
1005 #           elif defined(OBJFORMAT_PEi386)
1006             r = ocResolve_PEi386 ( oc );
1007 #           elif defined(OBJFORMAT_MACHO)
1008             r = ocResolve_MachO ( oc );
1009 #           else
1010             barf("resolveObjs: not implemented on this platform");
1011 #           endif
1012             if (!r) { return r; }
1013             oc->status = OBJECT_RESOLVED;
1014         }
1015     }
1016     return 1;
1017 }
1018
1019 /* -----------------------------------------------------------------------------
1020  * delete an object from the pool
1021  */
1022 HsInt
1023 unloadObj( char *path )
1024 {
1025     ObjectCode *oc, *prev;
1026
1027     ASSERT(symhash != NULL);
1028     ASSERT(objects != NULL);
1029
1030     initLinker();
1031
1032     prev = NULL;
1033     for (oc = objects; oc; prev = oc, oc = oc->next) {
1034         if (!strcmp(oc->fileName,path)) {
1035
1036             /* Remove all the mappings for the symbols within this
1037              * object..
1038              */
1039             {
1040                 int i;
1041                 for (i = 0; i < oc->n_symbols; i++) {
1042                    if (oc->symbols[i] != NULL) {
1043                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1044                    }
1045                 }
1046             }
1047
1048             if (prev == NULL) {
1049                 objects = oc->next;
1050             } else {
1051                 prev->next = oc->next;
1052             }
1053
1054             /* We're going to leave this in place, in case there are
1055                any pointers from the heap into it: */
1056             /* free(oc->image); */
1057             free(oc->fileName);
1058             free(oc->symbols);
1059             free(oc->sections);
1060             /* The local hash table should have been freed at the end
1061                of the ocResolve_ call on it. */
1062             ASSERT(oc->lochash == NULL);
1063             free(oc);
1064             return 1;
1065         }
1066     }
1067
1068     belch("unloadObj: can't find `%s' to unload", path);
1069     return 0;
1070 }
1071
1072 /* -----------------------------------------------------------------------------
1073  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1074  * which may be prodded during relocation, and abort if we try and write
1075  * outside any of these.
1076  */
1077 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1078 {
1079    ProddableBlock* pb
1080       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1081    /* fprintf(stderr, "aPB %p %p %d\n", oc, start, size); */
1082    ASSERT(size > 0);
1083    pb->start      = start;
1084    pb->size       = size;
1085    pb->next       = oc->proddables;
1086    oc->proddables = pb;
1087 }
1088
1089 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1090 {
1091    ProddableBlock* pb;
1092    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1093       char* s = (char*)(pb->start);
1094       char* e = s + pb->size - 1;
1095       char* a = (char*)addr;
1096       /* Assumes that the biggest fixup involves a 4-byte write.  This
1097          probably needs to be changed to 8 (ie, +7) on 64-bit
1098          plats. */
1099       if (a >= s && (a+3) <= e) return;
1100    }
1101    barf("checkProddableBlock: invalid fixup in runtime linker");
1102 }
1103
1104 /* -----------------------------------------------------------------------------
1105  * Section management.
1106  */
1107 static void addSection ( ObjectCode* oc, SectionKind kind,
1108                          void* start, void* end )
1109 {
1110    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1111    s->start     = start;
1112    s->end       = end;
1113    s->kind      = kind;
1114    s->next      = oc->sections;
1115    oc->sections = s;
1116    /*
1117    fprintf(stderr, "addSection: %p-%p (size %d), kind %d\n",
1118                    start, ((char*)end)-1, end - start + 1, kind );
1119    */
1120 }
1121
1122
1123
1124 /* --------------------------------------------------------------------------
1125  * PEi386 specifics (Win32 targets)
1126  * ------------------------------------------------------------------------*/
1127
1128 /* The information for this linker comes from
1129       Microsoft Portable Executable
1130       and Common Object File Format Specification
1131       revision 5.1 January 1998
1132    which SimonM says comes from the MS Developer Network CDs.
1133
1134    It can be found there (on older CDs), but can also be found
1135    online at:
1136
1137       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1138
1139    (this is Rev 6.0 from February 1999).
1140
1141    Things move, so if that fails, try searching for it via
1142
1143       http://www.google.com/search?q=PE+COFF+specification
1144
1145    The ultimate reference for the PE format is the Winnt.h
1146    header file that comes with the Platform SDKs; as always,
1147    implementations will drift wrt their documentation.
1148
1149    A good background article on the PE format is Matt Pietrek's
1150    March 1994 article in Microsoft System Journal (MSJ)
1151    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1152    Win32 Portable Executable File Format." The info in there
1153    has recently been updated in a two part article in
1154    MSDN magazine, issues Feb and March 2002,
1155    "Inside Windows: An In-Depth Look into the Win32 Portable
1156    Executable File Format"
1157
1158    John Levine's book "Linkers and Loaders" contains useful
1159    info on PE too.
1160 */
1161
1162
1163 #if defined(OBJFORMAT_PEi386)
1164
1165
1166
1167 typedef unsigned char  UChar;
1168 typedef unsigned short UInt16;
1169 typedef unsigned int   UInt32;
1170 typedef          int   Int32;
1171
1172
1173 typedef
1174    struct {
1175       UInt16 Machine;
1176       UInt16 NumberOfSections;
1177       UInt32 TimeDateStamp;
1178       UInt32 PointerToSymbolTable;
1179       UInt32 NumberOfSymbols;
1180       UInt16 SizeOfOptionalHeader;
1181       UInt16 Characteristics;
1182    }
1183    COFF_header;
1184
1185 #define sizeof_COFF_header 20
1186
1187
1188 typedef
1189    struct {
1190       UChar  Name[8];
1191       UInt32 VirtualSize;
1192       UInt32 VirtualAddress;
1193       UInt32 SizeOfRawData;
1194       UInt32 PointerToRawData;
1195       UInt32 PointerToRelocations;
1196       UInt32 PointerToLinenumbers;
1197       UInt16 NumberOfRelocations;
1198       UInt16 NumberOfLineNumbers;
1199       UInt32 Characteristics;
1200    }
1201    COFF_section;
1202
1203 #define sizeof_COFF_section 40
1204
1205
1206 typedef
1207    struct {
1208       UChar  Name[8];
1209       UInt32 Value;
1210       UInt16 SectionNumber;
1211       UInt16 Type;
1212       UChar  StorageClass;
1213       UChar  NumberOfAuxSymbols;
1214    }
1215    COFF_symbol;
1216
1217 #define sizeof_COFF_symbol 18
1218
1219
1220 typedef
1221    struct {
1222       UInt32 VirtualAddress;
1223       UInt32 SymbolTableIndex;
1224       UInt16 Type;
1225    }
1226    COFF_reloc;
1227
1228 #define sizeof_COFF_reloc 10
1229
1230
1231 /* From PE spec doc, section 3.3.2 */
1232 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1233    windows.h -- for the same purpose, but I want to know what I'm
1234    getting, here. */
1235 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1236 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1237 #define MYIMAGE_FILE_DLL                 0x2000
1238 #define MYIMAGE_FILE_SYSTEM              0x1000
1239 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1240 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1241 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1242
1243 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1244 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1245 #define MYIMAGE_SYM_CLASS_STATIC         3
1246 #define MYIMAGE_SYM_UNDEFINED            0
1247
1248 /* From PE spec doc, section 4.1 */
1249 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1250 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1251 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1252
1253 /* From PE spec doc, section 5.2.1 */
1254 #define MYIMAGE_REL_I386_DIR32           0x0006
1255 #define MYIMAGE_REL_I386_REL32           0x0014
1256
1257
1258 /* We use myindex to calculate array addresses, rather than
1259    simply doing the normal subscript thing.  That's because
1260    some of the above structs have sizes which are not
1261    a whole number of words.  GCC rounds their sizes up to a
1262    whole number of words, which means that the address calcs
1263    arising from using normal C indexing or pointer arithmetic
1264    are just plain wrong.  Sigh.
1265 */
1266 static UChar *
1267 myindex ( int scale, void* base, int index )
1268 {
1269    return
1270       ((UChar*)base) + scale * index;
1271 }
1272
1273
1274 static void
1275 printName ( UChar* name, UChar* strtab )
1276 {
1277    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1278       UInt32 strtab_offset = * (UInt32*)(name+4);
1279       fprintf ( stderr, "%s", strtab + strtab_offset );
1280    } else {
1281       int i;
1282       for (i = 0; i < 8; i++) {
1283          if (name[i] == 0) break;
1284          fprintf ( stderr, "%c", name[i] );
1285       }
1286    }
1287 }
1288
1289
1290 static void
1291 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1292 {
1293    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1294       UInt32 strtab_offset = * (UInt32*)(name+4);
1295       strncpy ( dst, strtab+strtab_offset, dstSize );
1296       dst[dstSize-1] = 0;
1297    } else {
1298       int i = 0;
1299       while (1) {
1300          if (i >= 8) break;
1301          if (name[i] == 0) break;
1302          dst[i] = name[i];
1303          i++;
1304       }
1305       dst[i] = 0;
1306    }
1307 }
1308
1309
1310 static UChar *
1311 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1312 {
1313    UChar* newstr;
1314    /* If the string is longer than 8 bytes, look in the
1315       string table for it -- this will be correctly zero terminated.
1316    */
1317    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1318       UInt32 strtab_offset = * (UInt32*)(name+4);
1319       return ((UChar*)strtab) + strtab_offset;
1320    }
1321    /* Otherwise, if shorter than 8 bytes, return the original,
1322       which by defn is correctly terminated.
1323    */
1324    if (name[7]==0) return name;
1325    /* The annoying case: 8 bytes.  Copy into a temporary
1326       (which is never freed ...)
1327    */
1328    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1329    ASSERT(newstr);
1330    strncpy(newstr,name,8);
1331    newstr[8] = 0;
1332    return newstr;
1333 }
1334
1335
1336 /* Just compares the short names (first 8 chars) */
1337 static COFF_section *
1338 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1339 {
1340    int i;
1341    COFF_header* hdr
1342       = (COFF_header*)(oc->image);
1343    COFF_section* sectab
1344       = (COFF_section*) (
1345            ((UChar*)(oc->image))
1346            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1347         );
1348    for (i = 0; i < hdr->NumberOfSections; i++) {
1349       UChar* n1;
1350       UChar* n2;
1351       COFF_section* section_i
1352          = (COFF_section*)
1353            myindex ( sizeof_COFF_section, sectab, i );
1354       n1 = (UChar*) &(section_i->Name);
1355       n2 = name;
1356       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1357           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1358           n1[6]==n2[6] && n1[7]==n2[7])
1359          return section_i;
1360    }
1361
1362    return NULL;
1363 }
1364
1365
1366 static void
1367 zapTrailingAtSign ( UChar* sym )
1368 {
1369 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1370    int i, j;
1371    if (sym[0] == 0) return;
1372    i = 0;
1373    while (sym[i] != 0) i++;
1374    i--;
1375    j = i;
1376    while (j > 0 && my_isdigit(sym[j])) j--;
1377    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1378 #  undef my_isdigit
1379 }
1380
1381
1382 static int
1383 ocVerifyImage_PEi386 ( ObjectCode* oc )
1384 {
1385    int i;
1386    UInt32 j, noRelocs;
1387    COFF_header*  hdr;
1388    COFF_section* sectab;
1389    COFF_symbol*  symtab;
1390    UChar*        strtab;
1391    /* fprintf(stderr, "\nLOADING %s\n", oc->fileName); */
1392    hdr = (COFF_header*)(oc->image);
1393    sectab = (COFF_section*) (
1394                ((UChar*)(oc->image))
1395                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1396             );
1397    symtab = (COFF_symbol*) (
1398                ((UChar*)(oc->image))
1399                + hdr->PointerToSymbolTable
1400             );
1401    strtab = ((UChar*)symtab)
1402             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1403
1404    if (hdr->Machine != 0x14c) {
1405       belch("Not x86 PEi386");
1406       return 0;
1407    }
1408    if (hdr->SizeOfOptionalHeader != 0) {
1409       belch("PEi386 with nonempty optional header");
1410       return 0;
1411    }
1412    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1413         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1414         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1415         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1416       belch("Not a PEi386 object file");
1417       return 0;
1418    }
1419    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1420         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1421       belch("Invalid PEi386 word size or endiannness: %d",
1422             (int)(hdr->Characteristics));
1423       return 0;
1424    }
1425    /* If the string table size is way crazy, this might indicate that
1426       there are more than 64k relocations, despite claims to the
1427       contrary.  Hence this test. */
1428    /* fprintf(stderr, "strtab size %d\n", * (UInt32*)strtab); */
1429 #if 0
1430    if ( (*(UInt32*)strtab) > 600000 ) {
1431       /* Note that 600k has no special significance other than being
1432          big enough to handle the almost-2MB-sized lumps that
1433          constitute HSwin32*.o. */
1434       belch("PEi386 object has suspiciously large string table; > 64k relocs?");
1435       return 0;
1436    }
1437 #endif
1438
1439    /* No further verification after this point; only debug printing. */
1440    i = 0;
1441    IF_DEBUG(linker, i=1);
1442    if (i == 0) return 1;
1443
1444    fprintf ( stderr,
1445              "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1446    fprintf ( stderr,
1447              "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1448    fprintf ( stderr,
1449              "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1450
1451    fprintf ( stderr, "\n" );
1452    fprintf ( stderr,
1453              "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1454    fprintf ( stderr,
1455              "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1456    fprintf ( stderr,
1457              "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1458    fprintf ( stderr,
1459              "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1460    fprintf ( stderr,
1461              "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1462    fprintf ( stderr,
1463              "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1464    fprintf ( stderr,
1465              "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1466
1467    /* Print the section table. */
1468    fprintf ( stderr, "\n" );
1469    for (i = 0; i < hdr->NumberOfSections; i++) {
1470       COFF_reloc* reltab;
1471       COFF_section* sectab_i
1472          = (COFF_section*)
1473            myindex ( sizeof_COFF_section, sectab, i );
1474       fprintf ( stderr,
1475                 "\n"
1476                 "section %d\n"
1477                 "     name `",
1478                 i
1479               );
1480       printName ( sectab_i->Name, strtab );
1481       fprintf ( stderr,
1482                 "'\n"
1483                 "    vsize %d\n"
1484                 "    vaddr %d\n"
1485                 "  data sz %d\n"
1486                 " data off %d\n"
1487                 "  num rel %d\n"
1488                 "  off rel %d\n"
1489                 "  ptr raw 0x%x\n",
1490                 sectab_i->VirtualSize,
1491                 sectab_i->VirtualAddress,
1492                 sectab_i->SizeOfRawData,
1493                 sectab_i->PointerToRawData,
1494                 sectab_i->NumberOfRelocations,
1495                 sectab_i->PointerToRelocations,
1496                 sectab_i->PointerToRawData
1497               );
1498       reltab = (COFF_reloc*) (
1499                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1500                );
1501
1502       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1503         /* If the relocation field (a short) has overflowed, the
1504          * real count can be found in the first reloc entry.
1505          *
1506          * See Section 4.1 (last para) of the PE spec (rev6.0).
1507          */
1508         COFF_reloc* rel = (COFF_reloc*)
1509                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1510         noRelocs = rel->VirtualAddress;
1511         j = 1;
1512       } else {
1513         noRelocs = sectab_i->NumberOfRelocations;
1514         j = 0;
1515       }
1516
1517       for (; j < noRelocs; j++) {
1518          COFF_symbol* sym;
1519          COFF_reloc* rel = (COFF_reloc*)
1520                            myindex ( sizeof_COFF_reloc, reltab, j );
1521          fprintf ( stderr,
1522                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1523                    (UInt32)rel->Type,
1524                    rel->VirtualAddress );
1525          sym = (COFF_symbol*)
1526                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1527          /* Hmm..mysterious looking offset - what's it for? SOF */
1528          printName ( sym->Name, strtab -10 );
1529          fprintf ( stderr, "'\n" );
1530       }
1531
1532       fprintf ( stderr, "\n" );
1533    }
1534    fprintf ( stderr, "\n" );
1535    fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
1536    fprintf ( stderr, "---START of string table---\n");
1537    for (i = 4; i < *(Int32*)strtab; i++) {
1538       if (strtab[i] == 0)
1539          fprintf ( stderr, "\n"); else
1540          fprintf( stderr, "%c", strtab[i] );
1541    }
1542    fprintf ( stderr, "--- END  of string table---\n");
1543
1544    fprintf ( stderr, "\n" );
1545    i = 0;
1546    while (1) {
1547       COFF_symbol* symtab_i;
1548       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1549       symtab_i = (COFF_symbol*)
1550                  myindex ( sizeof_COFF_symbol, symtab, i );
1551       fprintf ( stderr,
1552                 "symbol %d\n"
1553                 "     name `",
1554                 i
1555               );
1556       printName ( symtab_i->Name, strtab );
1557       fprintf ( stderr,
1558                 "'\n"
1559                 "    value 0x%x\n"
1560                 "   1+sec# %d\n"
1561                 "     type 0x%x\n"
1562                 "   sclass 0x%x\n"
1563                 "     nAux %d\n",
1564                 symtab_i->Value,
1565                 (Int32)(symtab_i->SectionNumber),
1566                 (UInt32)symtab_i->Type,
1567                 (UInt32)symtab_i->StorageClass,
1568                 (UInt32)symtab_i->NumberOfAuxSymbols
1569               );
1570       i += symtab_i->NumberOfAuxSymbols;
1571       i++;
1572    }
1573
1574    fprintf ( stderr, "\n" );
1575    return 1;
1576 }
1577
1578
1579 static int
1580 ocGetNames_PEi386 ( ObjectCode* oc )
1581 {
1582    COFF_header*  hdr;
1583    COFF_section* sectab;
1584    COFF_symbol*  symtab;
1585    UChar*        strtab;
1586
1587    UChar* sname;
1588    void*  addr;
1589    int    i;
1590
1591    hdr = (COFF_header*)(oc->image);
1592    sectab = (COFF_section*) (
1593                ((UChar*)(oc->image))
1594                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1595             );
1596    symtab = (COFF_symbol*) (
1597                ((UChar*)(oc->image))
1598                + hdr->PointerToSymbolTable
1599             );
1600    strtab = ((UChar*)(oc->image))
1601             + hdr->PointerToSymbolTable
1602             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1603
1604    /* Allocate space for any (local, anonymous) .bss sections. */
1605
1606    for (i = 0; i < hdr->NumberOfSections; i++) {
1607       UChar* zspace;
1608       COFF_section* sectab_i
1609          = (COFF_section*)
1610            myindex ( sizeof_COFF_section, sectab, i );
1611       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1612       if (sectab_i->VirtualSize == 0) continue;
1613       /* This is a non-empty .bss section.  Allocate zeroed space for
1614          it, and set its PointerToRawData field such that oc->image +
1615          PointerToRawData == addr_of_zeroed_space.  */
1616       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1617                               "ocGetNames_PEi386(anonymous bss)");
1618       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1619       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1620       /* fprintf(stderr, "BSS anon section at 0x%x\n", zspace); */
1621    }
1622
1623    /* Copy section information into the ObjectCode. */
1624
1625    for (i = 0; i < hdr->NumberOfSections; i++) {
1626       UChar* start;
1627       UChar* end;
1628       UInt32 sz;
1629
1630       SectionKind kind
1631          = SECTIONKIND_OTHER;
1632       COFF_section* sectab_i
1633          = (COFF_section*)
1634            myindex ( sizeof_COFF_section, sectab, i );
1635       IF_DEBUG(linker, belch("section name = %s\n", sectab_i->Name ));
1636
1637 #     if 0
1638       /* I'm sure this is the Right Way to do it.  However, the
1639          alternative of testing the sectab_i->Name field seems to
1640          work ok with Cygwin.
1641       */
1642       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1643           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1644          kind = SECTIONKIND_CODE_OR_RODATA;
1645 #     endif
1646
1647       if (0==strcmp(".text",sectab_i->Name) ||
1648           0==strcmp(".rodata",sectab_i->Name))
1649          kind = SECTIONKIND_CODE_OR_RODATA;
1650       if (0==strcmp(".data",sectab_i->Name) ||
1651           0==strcmp(".bss",sectab_i->Name))
1652          kind = SECTIONKIND_RWDATA;
1653
1654       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
1655       sz = sectab_i->SizeOfRawData;
1656       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
1657
1658       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
1659       end   = start + sz - 1;
1660
1661       if (kind == SECTIONKIND_OTHER
1662           /* Ignore sections called which contain stabs debugging
1663              information. */
1664           && 0 != strcmp(".stab", sectab_i->Name)
1665           && 0 != strcmp(".stabstr", sectab_i->Name)
1666          ) {
1667          belch("Unknown PEi386 section name `%s'", sectab_i->Name);
1668          return 0;
1669       }
1670
1671       if (kind != SECTIONKIND_OTHER && end >= start) {
1672          addSection(oc, kind, start, end);
1673          addProddableBlock(oc, start, end - start + 1);
1674       }
1675    }
1676
1677    /* Copy exported symbols into the ObjectCode. */
1678
1679    oc->n_symbols = hdr->NumberOfSymbols;
1680    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
1681                                   "ocGetNames_PEi386(oc->symbols)");
1682    /* Call me paranoid; I don't care. */
1683    for (i = 0; i < oc->n_symbols; i++)
1684       oc->symbols[i] = NULL;
1685
1686    i = 0;
1687    while (1) {
1688       COFF_symbol* symtab_i;
1689       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1690       symtab_i = (COFF_symbol*)
1691                  myindex ( sizeof_COFF_symbol, symtab, i );
1692
1693       addr  = NULL;
1694
1695       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
1696           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
1697          /* This symbol is global and defined, viz, exported */
1698          /* for MYIMAGE_SYMCLASS_EXTERNAL
1699                 && !MYIMAGE_SYM_UNDEFINED,
1700             the address of the symbol is:
1701                 address of relevant section + offset in section
1702          */
1703          COFF_section* sectabent
1704             = (COFF_section*) myindex ( sizeof_COFF_section,
1705                                         sectab,
1706                                         symtab_i->SectionNumber-1 );
1707          addr = ((UChar*)(oc->image))
1708                 + (sectabent->PointerToRawData
1709                    + symtab_i->Value);
1710       }
1711       else
1712       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
1713           && symtab_i->Value > 0) {
1714          /* This symbol isn't in any section at all, ie, global bss.
1715             Allocate zeroed space for it. */
1716          addr = stgCallocBytes(1, symtab_i->Value,
1717                                "ocGetNames_PEi386(non-anonymous bss)");
1718          addSection(oc, SECTIONKIND_RWDATA, addr,
1719                         ((UChar*)addr) + symtab_i->Value - 1);
1720          addProddableBlock(oc, addr, symtab_i->Value);
1721          /* fprintf(stderr, "BSS      section at 0x%x\n", addr); */
1722       }
1723
1724       if (addr != NULL ) {
1725          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
1726          /* fprintf(stderr,"addSymbol %p `%s \n", addr,sname);  */
1727          IF_DEBUG(linker, belch("addSymbol %p `%s'\n", addr,sname);)
1728          ASSERT(i >= 0 && i < oc->n_symbols);
1729          /* cstring_from_COFF_symbol_name always succeeds. */
1730          oc->symbols[i] = sname;
1731          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
1732       } else {
1733 #        if 0
1734          fprintf ( stderr,
1735                    "IGNORING symbol %d\n"
1736                    "     name `",
1737                    i
1738                  );
1739          printName ( symtab_i->Name, strtab );
1740          fprintf ( stderr,
1741                    "'\n"
1742                    "    value 0x%x\n"
1743                    "   1+sec# %d\n"
1744                    "     type 0x%x\n"
1745                    "   sclass 0x%x\n"
1746                    "     nAux %d\n",
1747                    symtab_i->Value,
1748                    (Int32)(symtab_i->SectionNumber),
1749                    (UInt32)symtab_i->Type,
1750                    (UInt32)symtab_i->StorageClass,
1751                    (UInt32)symtab_i->NumberOfAuxSymbols
1752                  );
1753 #        endif
1754       }
1755
1756       i += symtab_i->NumberOfAuxSymbols;
1757       i++;
1758    }
1759
1760    return 1;
1761 }
1762
1763
1764 static int
1765 ocResolve_PEi386 ( ObjectCode* oc )
1766 {
1767    COFF_header*  hdr;
1768    COFF_section* sectab;
1769    COFF_symbol*  symtab;
1770    UChar*        strtab;
1771
1772    UInt32        A;
1773    UInt32        S;
1774    UInt32*       pP;
1775
1776    int i;
1777    UInt32 j, noRelocs;
1778
1779    /* ToDo: should be variable-sized?  But is at least safe in the
1780       sense of buffer-overrun-proof. */
1781    char symbol[1000];
1782    /* fprintf(stderr, "resolving for %s\n", oc->fileName); */
1783
1784    hdr = (COFF_header*)(oc->image);
1785    sectab = (COFF_section*) (
1786                ((UChar*)(oc->image))
1787                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1788             );
1789    symtab = (COFF_symbol*) (
1790                ((UChar*)(oc->image))
1791                + hdr->PointerToSymbolTable
1792             );
1793    strtab = ((UChar*)(oc->image))
1794             + hdr->PointerToSymbolTable
1795             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1796
1797    for (i = 0; i < hdr->NumberOfSections; i++) {
1798       COFF_section* sectab_i
1799          = (COFF_section*)
1800            myindex ( sizeof_COFF_section, sectab, i );
1801       COFF_reloc* reltab
1802          = (COFF_reloc*) (
1803               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1804            );
1805
1806       /* Ignore sections called which contain stabs debugging
1807          information. */
1808       if (0 == strcmp(".stab", sectab_i->Name)
1809           || 0 == strcmp(".stabstr", sectab_i->Name))
1810          continue;
1811
1812       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1813         /* If the relocation field (a short) has overflowed, the
1814          * real count can be found in the first reloc entry.
1815          *
1816          * See Section 4.1 (last para) of the PE spec (rev6.0).
1817          */
1818         COFF_reloc* rel = (COFF_reloc*)
1819                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1820         noRelocs = rel->VirtualAddress;
1821         fprintf(stderr, "Overflown relocs: %u\n", noRelocs);
1822         j = 1;
1823       } else {
1824         noRelocs = sectab_i->NumberOfRelocations;
1825         j = 0;
1826       }
1827
1828
1829       for (; j < noRelocs; j++) {
1830          COFF_symbol* sym;
1831          COFF_reloc* reltab_j
1832             = (COFF_reloc*)
1833               myindex ( sizeof_COFF_reloc, reltab, j );
1834
1835          /* the location to patch */
1836          pP = (UInt32*)(
1837                  ((UChar*)(oc->image))
1838                  + (sectab_i->PointerToRawData
1839                     + reltab_j->VirtualAddress
1840                     - sectab_i->VirtualAddress )
1841               );
1842          /* the existing contents of pP */
1843          A = *pP;
1844          /* the symbol to connect to */
1845          sym = (COFF_symbol*)
1846                myindex ( sizeof_COFF_symbol,
1847                          symtab, reltab_j->SymbolTableIndex );
1848          IF_DEBUG(linker,
1849                   fprintf ( stderr,
1850                             "reloc sec %2d num %3d:  type 0x%-4x   "
1851                             "vaddr 0x%-8x   name `",
1852                             i, j,
1853                             (UInt32)reltab_j->Type,
1854                             reltab_j->VirtualAddress );
1855                             printName ( sym->Name, strtab );
1856                             fprintf ( stderr, "'\n" ));
1857
1858          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1859             COFF_section* section_sym
1860                = findPEi386SectionCalled ( oc, sym->Name );
1861             if (!section_sym) {
1862                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
1863                return 0;
1864             }
1865             S = ((UInt32)(oc->image))
1866                 + (section_sym->PointerToRawData
1867                    + sym->Value);
1868          } else {
1869             copyName ( sym->Name, strtab, symbol, 1000-1 );
1870             (void*)S = lookupLocalSymbol( oc, symbol );
1871             if ((void*)S != NULL) goto foundit;
1872             (void*)S = lookupSymbol( symbol );
1873             if ((void*)S != NULL) goto foundit;
1874             zapTrailingAtSign ( symbol );
1875             (void*)S = lookupLocalSymbol( oc, symbol );
1876             if ((void*)S != NULL) goto foundit;
1877             (void*)S = lookupSymbol( symbol );
1878             if ((void*)S != NULL) goto foundit;
1879             /* Newline first because the interactive linker has printed "linking..." */
1880             belch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
1881             return 0;
1882            foundit:
1883          }
1884          checkProddableBlock(oc, pP);
1885          switch (reltab_j->Type) {
1886             case MYIMAGE_REL_I386_DIR32:
1887                *pP = A + S;
1888                break;
1889             case MYIMAGE_REL_I386_REL32:
1890                /* Tricky.  We have to insert a displacement at
1891                   pP which, when added to the PC for the _next_
1892                   insn, gives the address of the target (S).
1893                   Problem is to know the address of the next insn
1894                   when we only know pP.  We assume that this
1895                   literal field is always the last in the insn,
1896                   so that the address of the next insn is pP+4
1897                   -- hence the constant 4.
1898                   Also I don't know if A should be added, but so
1899                   far it has always been zero.
1900                */
1901                ASSERT(A==0);
1902                *pP = S - ((UInt32)pP) - 4;
1903                break;
1904             default:
1905                belch("%s: unhandled PEi386 relocation type %d",
1906                      oc->fileName, reltab_j->Type);
1907                return 0;
1908          }
1909
1910       }
1911    }
1912
1913    IF_DEBUG(linker, belch("completed %s", oc->fileName));
1914    return 1;
1915 }
1916
1917 #endif /* defined(OBJFORMAT_PEi386) */
1918
1919
1920 /* --------------------------------------------------------------------------
1921  * ELF specifics
1922  * ------------------------------------------------------------------------*/
1923
1924 #if defined(OBJFORMAT_ELF)
1925
1926 #define FALSE 0
1927 #define TRUE  1
1928
1929 #if defined(sparc_TARGET_ARCH)
1930 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
1931 #elif defined(i386_TARGET_ARCH)
1932 #  define ELF_TARGET_386    /* Used inside <elf.h> */
1933 #elif defined (ia64_TARGET_ARCH)
1934 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
1935 #  define ELF_64BIT
1936 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
1937 #  define ELF_NEED_GOT      /* needs Global Offset Table */
1938 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
1939 #endif
1940
1941 #include <elf.h>
1942
1943 /*
1944  * Define a set of types which can be used for both ELF32 and ELF64
1945  */
1946
1947 #ifdef ELF_64BIT
1948 #define ELFCLASS    ELFCLASS64
1949 #define Elf_Addr    Elf64_Addr
1950 #define Elf_Word    Elf64_Word
1951 #define Elf_Sword   Elf64_Sword
1952 #define Elf_Ehdr    Elf64_Ehdr
1953 #define Elf_Phdr    Elf64_Phdr
1954 #define Elf_Shdr    Elf64_Shdr
1955 #define Elf_Sym     Elf64_Sym
1956 #define Elf_Rel     Elf64_Rel
1957 #define Elf_Rela    Elf64_Rela
1958 #define ELF_ST_TYPE ELF64_ST_TYPE
1959 #define ELF_ST_BIND ELF64_ST_BIND
1960 #define ELF_R_TYPE  ELF64_R_TYPE
1961 #define ELF_R_SYM   ELF64_R_SYM
1962 #else
1963 #define ELFCLASS    ELFCLASS32
1964 #define Elf_Addr    Elf32_Addr
1965 #define Elf_Word    Elf32_Word
1966 #define Elf_Sword   Elf32_Sword
1967 #define Elf_Ehdr    Elf32_Ehdr
1968 #define Elf_Phdr    Elf32_Phdr
1969 #define Elf_Shdr    Elf32_Shdr
1970 #define Elf_Sym     Elf32_Sym
1971 #define Elf_Rel     Elf32_Rel
1972 #define Elf_Rela    Elf32_Rela
1973 #define ELF_ST_TYPE ELF32_ST_TYPE
1974 #define ELF_ST_BIND ELF32_ST_BIND
1975 #define ELF_R_TYPE  ELF32_R_TYPE
1976 #define ELF_R_SYM   ELF32_R_SYM
1977 #endif
1978
1979
1980 /*
1981  * Functions to allocate entries in dynamic sections.  Currently we simply
1982  * preallocate a large number, and we don't check if a entry for the given
1983  * target already exists (a linear search is too slow).  Ideally these
1984  * entries would be associated with symbols.
1985  */
1986
1987 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
1988 #define GOT_SIZE            0x20000
1989 #define FUNCTION_TABLE_SIZE 0x10000
1990 #define PLT_SIZE            0x08000
1991
1992 #ifdef ELF_NEED_GOT
1993 static Elf_Addr got[GOT_SIZE];
1994 static unsigned int gotIndex;
1995 static Elf_Addr gp_val = (Elf_Addr)got;
1996
1997 static Elf_Addr
1998 allocateGOTEntry(Elf_Addr target)
1999 {
2000    Elf_Addr *entry;
2001
2002    if (gotIndex >= GOT_SIZE)
2003       barf("Global offset table overflow");
2004
2005    entry = &got[gotIndex++];
2006    *entry = target;
2007    return (Elf_Addr)entry;
2008 }
2009 #endif
2010
2011 #ifdef ELF_FUNCTION_DESC
2012 typedef struct {
2013    Elf_Addr ip;
2014    Elf_Addr gp;
2015 } FunctionDesc;
2016
2017 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2018 static unsigned int functionTableIndex;
2019
2020 static Elf_Addr
2021 allocateFunctionDesc(Elf_Addr target)
2022 {
2023    FunctionDesc *entry;
2024
2025    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2026       barf("Function table overflow");
2027
2028    entry = &functionTable[functionTableIndex++];
2029    entry->ip = target;
2030    entry->gp = (Elf_Addr)gp_val;
2031    return (Elf_Addr)entry;
2032 }
2033
2034 static Elf_Addr
2035 copyFunctionDesc(Elf_Addr target)
2036 {
2037    FunctionDesc *olddesc = (FunctionDesc *)target;
2038    FunctionDesc *newdesc;
2039
2040    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2041    newdesc->gp = olddesc->gp;
2042    return (Elf_Addr)newdesc;
2043 }
2044 #endif
2045
2046 #ifdef ELF_NEED_PLT
2047 #ifdef ia64_TARGET_ARCH
2048 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2049 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2050
2051 static unsigned char plt_code[] =
2052 {
2053    /* taken from binutils bfd/elfxx-ia64.c */
2054    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2055    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2056    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2057    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2058    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2059    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2060 };
2061
2062 /* If we can't get to the function descriptor via gp, take a local copy of it */
2063 #define PLT_RELOC(code, target) { \
2064    Elf64_Sxword rel_value = target - gp_val; \
2065    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2066       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2067    else \
2068       ia64_reloc_gprel22((Elf_Addr)code, target); \
2069    }
2070 #endif
2071
2072 typedef struct {
2073    unsigned char code[sizeof(plt_code)];
2074 } PLTEntry;
2075
2076 static Elf_Addr
2077 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2078 {
2079    PLTEntry *plt = (PLTEntry *)oc->plt;
2080    PLTEntry *entry;
2081
2082    if (oc->pltIndex >= PLT_SIZE)
2083       barf("Procedure table overflow");
2084
2085    entry = &plt[oc->pltIndex++];
2086    memcpy(entry->code, plt_code, sizeof(entry->code));
2087    PLT_RELOC(entry->code, target);
2088    return (Elf_Addr)entry;
2089 }
2090
2091 static unsigned int
2092 PLTSize(void)
2093 {
2094    return (PLT_SIZE * sizeof(PLTEntry));
2095 }
2096 #endif
2097
2098
2099 /*
2100  * Generic ELF functions
2101  */
2102
2103 static char *
2104 findElfSection ( void* objImage, Elf_Word sh_type )
2105 {
2106    char* ehdrC = (char*)objImage;
2107    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2108    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2109    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2110    char* ptr = NULL;
2111    int i;
2112
2113    for (i = 0; i < ehdr->e_shnum; i++) {
2114       if (shdr[i].sh_type == sh_type
2115           /* Ignore the section header's string table. */
2116           && i != ehdr->e_shstrndx
2117           /* Ignore string tables named .stabstr, as they contain
2118              debugging info. */
2119           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2120          ) {
2121          ptr = ehdrC + shdr[i].sh_offset;
2122          break;
2123       }
2124    }
2125    return ptr;
2126 }
2127
2128 #if defined(ia64_TARGET_ARCH)
2129 static Elf_Addr
2130 findElfSegment ( void* objImage, Elf_Addr vaddr )
2131 {
2132    char* ehdrC = (char*)objImage;
2133    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2134    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2135    Elf_Addr segaddr = 0;
2136    int i;
2137
2138    for (i = 0; i < ehdr->e_phnum; i++) {
2139       segaddr = phdr[i].p_vaddr;
2140       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2141               break;
2142    }
2143    return segaddr;
2144 }
2145 #endif
2146
2147 static int
2148 ocVerifyImage_ELF ( ObjectCode* oc )
2149 {
2150    Elf_Shdr* shdr;
2151    Elf_Sym*  stab;
2152    int i, j, nent, nstrtab, nsymtabs;
2153    char* sh_strtab;
2154    char* strtab;
2155
2156    char*     ehdrC = (char*)(oc->image);
2157    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2158
2159    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2160        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2161        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2162        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2163       belch("%s: not an ELF object", oc->fileName);
2164       return 0;
2165    }
2166
2167    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2168       belch("%s: unsupported ELF format", oc->fileName);
2169       return 0;
2170    }
2171
2172    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2173        IF_DEBUG(linker,belch( "Is little-endian" ));
2174    } else
2175    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2176        IF_DEBUG(linker,belch( "Is big-endian" ));
2177    } else {
2178        belch("%s: unknown endiannness", oc->fileName);
2179        return 0;
2180    }
2181
2182    if (ehdr->e_type != ET_REL) {
2183       belch("%s: not a relocatable object (.o) file", oc->fileName);
2184       return 0;
2185    }
2186    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
2187
2188    IF_DEBUG(linker,belch( "Architecture is " ));
2189    switch (ehdr->e_machine) {
2190       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
2191       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
2192 #ifdef EM_IA_64
2193       case EM_IA_64: IF_DEBUG(linker,belch( "ia64" )); break;
2194 #endif
2195       default:       IF_DEBUG(linker,belch( "unknown" ));
2196                      belch("%s: unknown architecture", oc->fileName);
2197                      return 0;
2198    }
2199
2200    IF_DEBUG(linker,belch(
2201              "\nSection header table: start %d, n_entries %d, ent_size %d",
2202              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2203
2204    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2205
2206    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2207
2208    if (ehdr->e_shstrndx == SHN_UNDEF) {
2209       belch("%s: no section header string table", oc->fileName);
2210       return 0;
2211    } else {
2212       IF_DEBUG(linker,belch( "Section header string table is section %d",
2213                           ehdr->e_shstrndx));
2214       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2215    }
2216
2217    for (i = 0; i < ehdr->e_shnum; i++) {
2218       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
2219       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
2220       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
2221       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
2222       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
2223                ehdrC + shdr[i].sh_offset,
2224                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2225
2226       if (shdr[i].sh_type == SHT_REL) {
2227           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
2228       } else if (shdr[i].sh_type == SHT_RELA) {
2229           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
2230       } else {
2231           IF_DEBUG(linker,fprintf(stderr,"     "));
2232       }
2233       if (sh_strtab) {
2234           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
2235       }
2236    }
2237
2238    IF_DEBUG(linker,belch( "\nString tables" ));
2239    strtab = NULL;
2240    nstrtab = 0;
2241    for (i = 0; i < ehdr->e_shnum; i++) {
2242       if (shdr[i].sh_type == SHT_STRTAB
2243           /* Ignore the section header's string table. */
2244           && i != ehdr->e_shstrndx
2245           /* Ignore string tables named .stabstr, as they contain
2246              debugging info. */
2247           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2248          ) {
2249          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
2250          strtab = ehdrC + shdr[i].sh_offset;
2251          nstrtab++;
2252       }
2253    }
2254    if (nstrtab != 1) {
2255       belch("%s: no string tables, or too many", oc->fileName);
2256       return 0;
2257    }
2258
2259    nsymtabs = 0;
2260    IF_DEBUG(linker,belch( "\nSymbol tables" ));
2261    for (i = 0; i < ehdr->e_shnum; i++) {
2262       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2263       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
2264       nsymtabs++;
2265       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2266       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2267       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
2268                nent,
2269                shdr[i].sh_size % sizeof(Elf_Sym)
2270              ));
2271       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2272          belch("%s: non-integral number of symbol table entries", oc->fileName);
2273          return 0;
2274       }
2275       for (j = 0; j < nent; j++) {
2276          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
2277          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
2278                              (int)stab[j].st_shndx,
2279                              (int)stab[j].st_size,
2280                              (char*)stab[j].st_value ));
2281
2282          IF_DEBUG(linker,fprintf(stderr, "type=" ));
2283          switch (ELF_ST_TYPE(stab[j].st_info)) {
2284             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
2285             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
2286             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
2287             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
2288             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
2289             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
2290          }
2291          IF_DEBUG(linker,fprintf(stderr, "  " ));
2292
2293          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
2294          switch (ELF_ST_BIND(stab[j].st_info)) {
2295             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
2296             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
2297             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
2298             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
2299          }
2300          IF_DEBUG(linker,fprintf(stderr, "  " ));
2301
2302          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
2303       }
2304    }
2305
2306    if (nsymtabs == 0) {
2307       belch("%s: didn't find any symbol tables", oc->fileName);
2308       return 0;
2309    }
2310
2311    return 1;
2312 }
2313
2314
2315 static int
2316 ocGetNames_ELF ( ObjectCode* oc )
2317 {
2318    int i, j, k, nent;
2319    Elf_Sym* stab;
2320
2321    char*     ehdrC    = (char*)(oc->image);
2322    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2323    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2324    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2325
2326    ASSERT(symhash != NULL);
2327
2328    if (!strtab) {
2329       belch("%s: no strtab", oc->fileName);
2330       return 0;
2331    }
2332
2333    k = 0;
2334    for (i = 0; i < ehdr->e_shnum; i++) {
2335       /* Figure out what kind of section it is.  Logic derived from
2336          Figure 1.14 ("Special Sections") of the ELF document
2337          ("Portable Formats Specification, Version 1.1"). */
2338       Elf_Shdr    hdr    = shdr[i];
2339       SectionKind kind   = SECTIONKIND_OTHER;
2340       int         is_bss = FALSE;
2341
2342       if (hdr.sh_type == SHT_PROGBITS
2343           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_EXECINSTR)) {
2344          /* .text-style section */
2345          kind = SECTIONKIND_CODE_OR_RODATA;
2346       }
2347       else
2348       if (hdr.sh_type == SHT_PROGBITS
2349           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2350          /* .data-style section */
2351          kind = SECTIONKIND_RWDATA;
2352       }
2353       else
2354       if (hdr.sh_type == SHT_PROGBITS
2355           && (hdr.sh_flags & SHF_ALLOC) && !(hdr.sh_flags & SHF_WRITE)) {
2356          /* .rodata-style section */
2357          kind = SECTIONKIND_CODE_OR_RODATA;
2358       }
2359       else
2360       if (hdr.sh_type == SHT_NOBITS
2361           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2362          /* .bss-style section */
2363          kind = SECTIONKIND_RWDATA;
2364          is_bss = TRUE;
2365       }
2366
2367       if (is_bss && shdr[i].sh_size > 0) {
2368          /* This is a non-empty .bss section.  Allocate zeroed space for
2369             it, and set its .sh_offset field such that
2370             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2371          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2372                                        "ocGetNames_ELF(BSS)");
2373          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2374          /*
2375          fprintf(stderr, "BSS section at 0x%x, size %d\n",
2376                          zspace, shdr[i].sh_size);
2377          */
2378       }
2379
2380       /* fill in the section info */
2381       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2382          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2383          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2384                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2385       }
2386
2387       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2388
2389       /* copy stuff into this module's object symbol table */
2390       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2391       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2392
2393       oc->n_symbols = nent;
2394       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2395                                    "ocGetNames_ELF(oc->symbols)");
2396
2397       for (j = 0; j < nent; j++) {
2398
2399          char  isLocal = FALSE; /* avoids uninit-var warning */
2400          char* ad      = NULL;
2401          char* nm      = strtab + stab[j].st_name;
2402          int   secno   = stab[j].st_shndx;
2403
2404          /* Figure out if we want to add it; if so, set ad to its
2405             address.  Otherwise leave ad == NULL. */
2406
2407          if (secno == SHN_COMMON) {
2408             isLocal = FALSE;
2409             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2410             /*
2411             fprintf(stderr, "COMMON symbol, size %d name %s\n",
2412                             stab[j].st_size, nm);
2413             */
2414             /* Pointless to do addProddableBlock() for this area,
2415                since the linker should never poke around in it. */
2416          }
2417          else
2418          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2419                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2420               )
2421               /* and not an undefined symbol */
2422               && stab[j].st_shndx != SHN_UNDEF
2423               /* and not in a "special section" */
2424               && stab[j].st_shndx < SHN_LORESERVE
2425               &&
2426               /* and it's a not a section or string table or anything silly */
2427               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2428                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2429                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2430               )
2431             ) {
2432             /* Section 0 is the undefined section, hence > and not >=. */
2433             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2434             /*
2435             if (shdr[secno].sh_type == SHT_NOBITS) {
2436                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
2437                                stab[j].st_size, stab[j].st_value, nm);
2438             }
2439             */
2440             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2441             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2442                isLocal = TRUE;
2443             } else {
2444 #ifdef ELF_FUNCTION_DESC
2445                /* dlsym() and the initialisation table both give us function
2446                 * descriptors, so to be consistent we store function descriptors
2447                 * in the symbol table */
2448                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2449                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2450 #endif
2451                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
2452                                       ad, oc->fileName, nm ));
2453                isLocal = FALSE;
2454             }
2455          }
2456
2457          /* And the decision is ... */
2458
2459          if (ad != NULL) {
2460             ASSERT(nm != NULL);
2461             oc->symbols[j] = nm;
2462             /* Acquire! */
2463             if (isLocal) {
2464                /* Ignore entirely. */
2465             } else {
2466                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2467             }
2468          } else {
2469             /* Skip. */
2470             IF_DEBUG(linker,belch( "skipping `%s'",
2471                                    strtab + stab[j].st_name ));
2472             /*
2473             fprintf(stderr,
2474                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2475                     (int)ELF_ST_BIND(stab[j].st_info),
2476                     (int)ELF_ST_TYPE(stab[j].st_info),
2477                     (int)stab[j].st_shndx,
2478                     strtab + stab[j].st_name
2479                    );
2480             */
2481             oc->symbols[j] = NULL;
2482          }
2483
2484       }
2485    }
2486
2487    return 1;
2488 }
2489
2490 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2491    relocations appear to be of this form. */
2492 static int
2493 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2494                          Elf_Shdr* shdr, int shnum,
2495                          Elf_Sym*  stab, char* strtab )
2496 {
2497    int j;
2498    char *symbol;
2499    Elf_Word* targ;
2500    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
2501    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
2502    int target_shndx = shdr[shnum].sh_info;
2503    int symtab_shndx = shdr[shnum].sh_link;
2504
2505    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2506    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2507    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2508                           target_shndx, symtab_shndx ));
2509
2510    for (j = 0; j < nent; j++) {
2511       Elf_Addr offset = rtab[j].r_offset;
2512       Elf_Addr info   = rtab[j].r_info;
2513
2514       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
2515       Elf_Word* pP = (Elf_Word*)P;
2516       Elf_Addr  A  = *pP;
2517       Elf_Addr  S;
2518       Elf_Addr  value;
2519
2520       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
2521                              j, (void*)offset, (void*)info ));
2522       if (!info) {
2523          IF_DEBUG(linker,belch( " ZERO" ));
2524          S = 0;
2525       } else {
2526          Elf_Sym sym = stab[ELF_R_SYM(info)];
2527          /* First see if it is a local symbol. */
2528          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2529             /* Yes, so we can get the address directly from the ELF symbol
2530                table. */
2531             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2532             S = (Elf_Addr)
2533                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2534                        + stab[ELF_R_SYM(info)].st_value);
2535
2536          } else {
2537             /* No, so look up the name in our global table. */
2538             symbol = strtab + sym.st_name;
2539             (void*)S = lookupSymbol( symbol );
2540          }
2541          if (!S) {
2542             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2543             return 0;
2544          }
2545          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2546       }
2547
2548       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2549                              (void*)P, (void*)S, (void*)A ));
2550       checkProddableBlock ( oc, pP );
2551
2552       value = S + A;
2553
2554       switch (ELF_R_TYPE(info)) {
2555 #        ifdef i386_TARGET_ARCH
2556          case R_386_32:   *pP = value;     break;
2557          case R_386_PC32: *pP = value - P; break;
2558 #        endif
2559          default:
2560             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2561                   oc->fileName, ELF_R_TYPE(info));
2562             return 0;
2563       }
2564
2565    }
2566    return 1;
2567 }
2568
2569 /* Do ELF relocations for which explicit addends are supplied.
2570    sparc-solaris relocations appear to be of this form. */
2571 static int
2572 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2573                           Elf_Shdr* shdr, int shnum,
2574                           Elf_Sym*  stab, char* strtab )
2575 {
2576    int j;
2577    char *symbol;
2578    Elf_Addr targ;
2579    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
2580    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
2581    int target_shndx = shdr[shnum].sh_info;
2582    int symtab_shndx = shdr[shnum].sh_link;
2583
2584    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2585    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
2586    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2587                           target_shndx, symtab_shndx ));
2588
2589    for (j = 0; j < nent; j++) {
2590 #if defined(DEBUG) || defined(sparc_TARGET_ARCH) || defined(ia64_TARGET_ARCH)
2591       /* This #ifdef only serves to avoid unused-var warnings. */
2592       Elf_Addr  offset = rtab[j].r_offset;
2593       Elf_Addr  P      = targ + offset;
2594 #endif
2595       Elf_Addr  info   = rtab[j].r_info;
2596       Elf_Addr  A      = rtab[j].r_addend;
2597       Elf_Addr  S;
2598       Elf_Addr  value;
2599 #     if defined(sparc_TARGET_ARCH)
2600       Elf_Word* pP = (Elf_Word*)P;
2601       Elf_Word  w1, w2;
2602 #     elif defined(ia64_TARGET_ARCH)
2603       Elf64_Xword *pP = (Elf64_Xword *)P;
2604       Elf_Addr addr;
2605 #     endif
2606
2607       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2608                              j, (void*)offset, (void*)info,
2609                                 (void*)A ));
2610       if (!info) {
2611          IF_DEBUG(linker,belch( " ZERO" ));
2612          S = 0;
2613       } else {
2614          Elf_Sym sym = stab[ELF_R_SYM(info)];
2615          /* First see if it is a local symbol. */
2616          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2617             /* Yes, so we can get the address directly from the ELF symbol
2618                table. */
2619             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2620             S = (Elf_Addr)
2621                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2622                        + stab[ELF_R_SYM(info)].st_value);
2623 #ifdef ELF_FUNCTION_DESC
2624             /* Make a function descriptor for this function */
2625             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
2626                S = allocateFunctionDesc(S + A);
2627                A = 0;
2628             }
2629 #endif
2630          } else {
2631             /* No, so look up the name in our global table. */
2632             symbol = strtab + sym.st_name;
2633             (void*)S = lookupSymbol( symbol );
2634
2635 #ifdef ELF_FUNCTION_DESC
2636             /* If a function, already a function descriptor - we would
2637                have to copy it to add an offset. */
2638             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC)
2639                assert(A == 0);
2640 #endif
2641          }
2642          if (!S) {
2643            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2644            return 0;
2645          }
2646          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2647       }
2648
2649       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2650                                         (void*)P, (void*)S, (void*)A ));
2651       /* checkProddableBlock ( oc, (void*)P ); */
2652
2653       value = S + A;
2654
2655       switch (ELF_R_TYPE(info)) {
2656 #        if defined(sparc_TARGET_ARCH)
2657          case R_SPARC_WDISP30:
2658             w1 = *pP & 0xC0000000;
2659             w2 = (Elf_Word)((value - P) >> 2);
2660             ASSERT((w2 & 0xC0000000) == 0);
2661             w1 |= w2;
2662             *pP = w1;
2663             break;
2664          case R_SPARC_HI22:
2665             w1 = *pP & 0xFFC00000;
2666             w2 = (Elf_Word)(value >> 10);
2667             ASSERT((w2 & 0xFFC00000) == 0);
2668             w1 |= w2;
2669             *pP = w1;
2670             break;
2671          case R_SPARC_LO10:
2672             w1 = *pP & ~0x3FF;
2673             w2 = (Elf_Word)(value & 0x3FF);
2674             ASSERT((w2 & ~0x3FF) == 0);
2675             w1 |= w2;
2676             *pP = w1;
2677             break;
2678          /* According to the Sun documentation:
2679             R_SPARC_UA32
2680             This relocation type resembles R_SPARC_32, except it refers to an
2681             unaligned word. That is, the word to be relocated must be treated
2682             as four separate bytes with arbitrary alignment, not as a word
2683             aligned according to the architecture requirements.
2684
2685             (JRS: which means that freeloading on the R_SPARC_32 case
2686             is probably wrong, but hey ...)
2687          */
2688          case R_SPARC_UA32:
2689          case R_SPARC_32:
2690             w2 = (Elf_Word)value;
2691             *pP = w2;
2692             break;
2693 #        elif defined(ia64_TARGET_ARCH)
2694          case R_IA64_DIR64LSB:
2695          case R_IA64_FPTR64LSB:
2696             *pP = value;
2697             break;
2698          case R_IA64_SEGREL64LSB:
2699             addr = findElfSegment(ehdrC, value);
2700             *pP = value - addr;
2701             break;
2702          case R_IA64_GPREL22:
2703             ia64_reloc_gprel22(P, value);
2704             break;
2705          case R_IA64_LTOFF22:
2706          case R_IA64_LTOFF_FPTR22:
2707             addr = allocateGOTEntry(value);
2708             ia64_reloc_gprel22(P, addr);
2709             break;
2710          case R_IA64_PCREL21B:
2711             ia64_reloc_pcrel21(P, S, oc);
2712             break;
2713 #        endif
2714          default:
2715             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2716                   oc->fileName, ELF_R_TYPE(info));
2717             return 0;
2718       }
2719
2720    }
2721    return 1;
2722 }
2723
2724 static int
2725 ocResolve_ELF ( ObjectCode* oc )
2726 {
2727    char *strtab;
2728    int   shnum, ok;
2729    Elf_Sym*  stab  = NULL;
2730    char*     ehdrC = (char*)(oc->image);
2731    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
2732    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2733    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2734
2735    /* first find "the" symbol table */
2736    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2737
2738    /* also go find the string table */
2739    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2740
2741    if (stab == NULL || strtab == NULL) {
2742       belch("%s: can't find string or symbol table", oc->fileName);
2743       return 0;
2744    }
2745
2746    /* Process the relocation sections. */
2747    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2748
2749       /* Skip sections called ".rel.stab".  These appear to contain
2750          relocation entries that, when done, make the stabs debugging
2751          info point at the right places.  We ain't interested in all
2752          dat jazz, mun. */
2753       if (0 == memcmp(".rel.stab", sh_strtab + shdr[shnum].sh_name, 9))
2754          continue;
2755
2756       if (shdr[shnum].sh_type == SHT_REL ) {
2757          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
2758                                        shnum, stab, strtab );
2759          if (!ok) return ok;
2760       }
2761       else
2762       if (shdr[shnum].sh_type == SHT_RELA) {
2763          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
2764                                         shnum, stab, strtab );
2765          if (!ok) return ok;
2766       }
2767    }
2768
2769    /* Free the local symbol table; we won't need it again. */
2770    freeHashTable(oc->lochash, NULL);
2771    oc->lochash = NULL;
2772
2773    return 1;
2774 }
2775
2776 /*
2777  * IA64 specifics
2778  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
2779  * at the front.  The following utility functions pack and unpack instructions, and
2780  * take care of the most common relocations.
2781  */
2782
2783 #ifdef ia64_TARGET_ARCH
2784
2785 static Elf64_Xword
2786 ia64_extract_instruction(Elf64_Xword *target)
2787 {
2788    Elf64_Xword w1, w2;
2789    int slot = (Elf_Addr)target & 3;
2790    (Elf_Addr)target &= ~3;
2791
2792    w1 = *target;
2793    w2 = *(target+1);
2794
2795    switch (slot)
2796    {
2797       case 0:
2798          return ((w1 >> 5) & 0x1ffffffffff);
2799       case 1:
2800          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
2801       case 2:
2802          return (w2 >> 23);
2803       default:
2804          barf("ia64_extract_instruction: invalid slot %p", target);
2805    }
2806 }
2807
2808 static void
2809 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
2810 {
2811    int slot = (Elf_Addr)target & 3;
2812    (Elf_Addr)target &= ~3;
2813
2814    switch (slot)
2815    {
2816       case 0:
2817          *target |= value << 5;
2818          break;
2819       case 1:
2820          *target |= value << 46;
2821          *(target+1) |= value >> 18;
2822          break;
2823       case 2:
2824          *(target+1) |= value << 23;
2825          break;
2826    }
2827 }
2828
2829 static void
2830 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
2831 {
2832    Elf64_Xword instruction;
2833    Elf64_Sxword rel_value;
2834
2835    rel_value = value - gp_val;
2836    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
2837       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
2838
2839    instruction = ia64_extract_instruction((Elf64_Xword *)target);
2840    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
2841                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
2842                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
2843                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
2844    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
2845 }
2846
2847 static void
2848 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
2849 {
2850    Elf64_Xword instruction;
2851    Elf64_Sxword rel_value;
2852    Elf_Addr entry;
2853
2854    entry = allocatePLTEntry(value, oc);
2855
2856    rel_value = (entry >> 4) - (target >> 4);
2857    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
2858       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
2859
2860    instruction = ia64_extract_instruction((Elf64_Xword *)target);
2861    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
2862                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
2863    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
2864 }
2865
2866 #endif /* ia64 */
2867
2868 #endif /* ELF */
2869
2870 /* --------------------------------------------------------------------------
2871  * Mach-O specifics
2872  * ------------------------------------------------------------------------*/
2873
2874 #if defined(OBJFORMAT_MACHO)
2875
2876 /*
2877   Initial support for MachO linking on Darwin/MacOS X on PowerPC chips
2878   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
2879
2880   I hereby formally apologize for the hackish nature of this code.
2881   Things that need to be done:
2882   *) get common symbols and .bss sections to work properly.
2883         Haskell modules seem to work, but C modules can cause problems
2884   *) implement ocVerifyImage_MachO
2885   *) add more sanity checks. The current code just has to segfault if there's a
2886      broken .o file.
2887 */
2888
2889 static int ocVerifyImage_MachO(ObjectCode* oc)
2890 {
2891     // FIXME: do some verifying here
2892     return 1;
2893 }
2894
2895 static void resolveImports(
2896     ObjectCode* oc,
2897     char *image,
2898     struct symtab_command *symLC,
2899     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
2900     unsigned long *indirectSyms,
2901     struct nlist *nlist)
2902 {
2903     unsigned i;
2904
2905     for(i=0;i*4<sect->size;i++)
2906     {
2907         // according to otool, reserved1 contains the first index into the indirect symbol table
2908         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
2909         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
2910         void *addr = NULL;
2911
2912         if((symbol->n_type & N_TYPE) == N_UNDF
2913             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
2914             addr = (void*) (symbol->n_value);
2915         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
2916             ;
2917         else
2918             addr = lookupSymbol(nm);
2919         if(!addr)
2920         {
2921             fprintf(stderr, "not found: %s\n", nm);
2922             abort();
2923         }
2924         ASSERT(addr);
2925         ((void**)(image + sect->offset))[i] = addr;
2926     }
2927 }
2928
2929 static void relocateSection(char *image,
2930     struct symtab_command *symLC, struct nlist *nlist,
2931     struct section* sections, struct section *sect)
2932 {
2933     struct relocation_info *relocs;
2934     int i,n;
2935
2936     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
2937         return;
2938     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
2939         return;
2940
2941     n = sect->nreloc;
2942     relocs = (struct relocation_info*) (image + sect->reloff);
2943
2944     for(i=0;i<n;i++)
2945     {
2946         if(relocs[i].r_address & R_SCATTERED)
2947         {
2948             struct scattered_relocation_info *scat =
2949                 (struct scattered_relocation_info*) &relocs[i];
2950
2951             if(!scat->r_pcrel)
2952             {
2953                 if(scat->r_length == 2 && scat->r_type == GENERIC_RELOC_VANILLA)
2954                 {
2955                     unsigned long* word = (unsigned long*) (image + sect->offset + scat->r_address);
2956
2957                     *word = scat->r_value + sect->offset + ((long) image);
2958                 }
2959             }
2960
2961             continue; // FIXME: I hope it's OK to ignore all the others.
2962         }
2963         else
2964         {
2965             struct relocation_info *reloc = &relocs[i];
2966             if(reloc->r_pcrel && !reloc->r_extern)
2967                 continue;
2968
2969             if(!reloc->r_pcrel && reloc->r_length == 2)
2970             {
2971                 unsigned long word;
2972
2973                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
2974
2975                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
2976                 {
2977                     word = *wordPtr;
2978                 }
2979                 else if(reloc->r_type == PPC_RELOC_LO16)
2980                 {
2981                     word = ((unsigned short*) wordPtr)[1];
2982                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
2983                 }
2984                 else if(reloc->r_type == PPC_RELOC_HI16)
2985                 {
2986                     word = ((unsigned short*) wordPtr)[1] << 16;
2987                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
2988                 }
2989                 else if(reloc->r_type == PPC_RELOC_HA16)
2990                 {
2991                     word = ((unsigned short*) wordPtr)[1] << 16;
2992                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
2993                 }
2994
2995                 if(!reloc->r_extern)
2996                 {
2997                     long delta =
2998                         sections[reloc->r_symbolnum-1].offset
2999                         - sections[reloc->r_symbolnum-1].addr
3000                         + ((long) image);
3001
3002                     word += delta;
3003                 }
3004                 else
3005                 {
3006                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3007                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3008                     word = (unsigned long) (lookupSymbol(nm));
3009                     ASSERT(word);
3010                 }
3011
3012                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3013                 {
3014                     *wordPtr = word;
3015                     continue;
3016                 }
3017                 else if(reloc->r_type == PPC_RELOC_LO16)
3018                 {
3019                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3020                     i++; continue;
3021                 }
3022                 else if(reloc->r_type == PPC_RELOC_HI16)
3023                 {
3024                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3025                     i++; continue;
3026                 }
3027                 else if(reloc->r_type == PPC_RELOC_HA16)
3028                 {
3029                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3030                         + ((word & (1<<15)) ? 1 : 0);
3031                     i++; continue;
3032                 }
3033                 continue;
3034             }
3035             fprintf(stderr, "unknown reloc\n");
3036             abort();
3037             ASSERT(2 + 2 == 5);
3038         }
3039     }
3040 }
3041
3042 static int ocGetNames_MachO(ObjectCode* oc)
3043 {
3044     char *image = (char*) oc->image;
3045     struct mach_header *header = (struct mach_header*) image;
3046     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3047     unsigned i,curSymbol;
3048     struct segment_command *segLC = NULL;
3049     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3050     struct symtab_command *symLC = NULL;
3051     struct dysymtab_command *dsymLC = NULL;
3052     struct nlist *nlist;
3053     unsigned long commonSize = 0;
3054     char    *commonStorage = NULL;
3055     unsigned long commonCounter;
3056
3057     for(i=0;i<header->ncmds;i++)
3058     {
3059         if(lc->cmd == LC_SEGMENT)
3060             segLC = (struct segment_command*) lc;
3061         else if(lc->cmd == LC_SYMTAB)
3062             symLC = (struct symtab_command*) lc;
3063         else if(lc->cmd == LC_DYSYMTAB)
3064             dsymLC = (struct dysymtab_command*) lc;
3065         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3066     }
3067
3068     sections = (struct section*) (segLC+1);
3069     nlist = (struct nlist*) (image + symLC->symoff);
3070
3071     for(i=0;i<segLC->nsects;i++)
3072     {
3073         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3074             la_ptrs = &sections[i];
3075         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3076             nl_ptrs = &sections[i];
3077
3078             // for now, only add __text and __const to the sections table
3079         else if(!strcmp(sections[i].sectname,"__text"))
3080             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3081                 (void*) (image + sections[i].offset),
3082                 (void*) (image + sections[i].offset + sections[i].size));
3083         else if(!strcmp(sections[i].sectname,"__const"))
3084             addSection(oc, SECTIONKIND_RWDATA,
3085                 (void*) (image + sections[i].offset),
3086                 (void*) (image + sections[i].offset + sections[i].size));
3087         else if(!strcmp(sections[i].sectname,"__data"))
3088             addSection(oc, SECTIONKIND_RWDATA,
3089                 (void*) (image + sections[i].offset),
3090                 (void*) (image + sections[i].offset + sections[i].size));
3091     }
3092
3093         // count external symbols defined here
3094     oc->n_symbols = 0;
3095     for(i=dsymLC->iextdefsym;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3096     {
3097         if((nlist[i].n_type & N_TYPE) == N_SECT)
3098             oc->n_symbols++;
3099     }
3100     for(i=0;i<symLC->nsyms;i++)
3101     {
3102         if((nlist[i].n_type & N_TYPE) == N_UNDF
3103                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3104         {
3105             commonSize += nlist[i].n_value;
3106             oc->n_symbols++;
3107         }
3108     }
3109     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3110                                    "ocGetNames_MachO(oc->symbols)");
3111
3112         // insert symbols into hash table
3113     for(i=dsymLC->iextdefsym,curSymbol=0;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3114     {
3115         if((nlist[i].n_type & N_TYPE) == N_SECT)
3116         {
3117             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3118             ghciInsertStrHashTable(oc->fileName, symhash, nm, image +
3119                 sections[nlist[i].n_sect-1].offset
3120                 - sections[nlist[i].n_sect-1].addr
3121                 + nlist[i].n_value);
3122             oc->symbols[curSymbol++] = nm;
3123         }
3124     }
3125
3126         // insert local symbols into lochash
3127     for(i=dsymLC->ilocalsym;i<dsymLC->ilocalsym+dsymLC->nlocalsym;i++)
3128     {
3129         if((nlist[i].n_type & N_TYPE) == N_SECT)
3130         {
3131             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3132             ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, image +
3133                 sections[nlist[i].n_sect-1].offset
3134                 - sections[nlist[i].n_sect-1].addr
3135                 + nlist[i].n_value);
3136         }
3137     }
3138
3139
3140     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
3141     commonCounter = (unsigned long)commonStorage;
3142     for(i=0;i<symLC->nsyms;i++)
3143     {
3144         if((nlist[i].n_type & N_TYPE) == N_UNDF
3145                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3146         {
3147             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3148             unsigned long sz = nlist[i].n_value;
3149
3150             nlist[i].n_value = commonCounter;
3151
3152             ghciInsertStrHashTable(oc->fileName, symhash, nm, (void*)commonCounter);
3153             oc->symbols[curSymbol++] = nm;
3154
3155             commonCounter += sz;
3156         }
3157     }
3158     return 1;
3159 }
3160
3161 static int ocResolve_MachO(ObjectCode* oc)
3162 {
3163     char *image = (char*) oc->image;
3164     struct mach_header *header = (struct mach_header*) image;
3165     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3166     unsigned i;
3167     struct segment_command *segLC = NULL;
3168     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3169     struct symtab_command *symLC = NULL;
3170     struct dysymtab_command *dsymLC = NULL;
3171     struct nlist *nlist;
3172     unsigned long *indirectSyms;
3173
3174     for(i=0;i<header->ncmds;i++)
3175     {
3176         if(lc->cmd == LC_SEGMENT)
3177             segLC = (struct segment_command*) lc;
3178         else if(lc->cmd == LC_SYMTAB)
3179             symLC = (struct symtab_command*) lc;
3180         else if(lc->cmd == LC_DYSYMTAB)
3181             dsymLC = (struct dysymtab_command*) lc;
3182         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3183     }
3184
3185     sections = (struct section*) (segLC+1);
3186     nlist = (struct nlist*) (image + symLC->symoff);
3187
3188     for(i=0;i<segLC->nsects;i++)
3189     {
3190         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3191             la_ptrs = &sections[i];
3192         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3193             nl_ptrs = &sections[i];
3194     }
3195
3196     indirectSyms = (unsigned long*) (image + dsymLC->indirectsymoff);
3197
3198     if(la_ptrs)
3199         resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist);
3200     if(nl_ptrs)
3201         resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist);
3202
3203     for(i=0;i<segLC->nsects;i++)
3204     {
3205         relocateSection(image,symLC,nlist,sections,&sections[i]);
3206     }
3207
3208     /* Free the local symbol table; we won't need it again. */
3209     freeHashTable(oc->lochash, NULL);
3210     oc->lochash = NULL;
3211     return 1;
3212 }
3213
3214 #endif