ghc/rts/Linker.c

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