ghc/rts/Linker.c

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