ghc/rts/Linker.c

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