ghc/rts/Linker.c

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