ghc/rts/Linker.c

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