ghc/rts/Linker.c

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