ghc/rts/Linker.c

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