ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 2000-2004
   4  *
   5  * RTS Object Linker
   6  *
   7  * ---------------------------------------------------------------------------*/
   8
   9 #if 0
  10 #include "PosixSource.h"
  11 #endif
  12
  13 /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from <dlfcn.h> and
  14    MREMAP_MAYMOVE from <sys/mman.h>.
  15  */
  16 #ifdef __linux__
  17 #define _GNU_SOURCE
  18 #endif
  19
  20 #include "Rts.h"
  21 #include "RtsFlags.h"
  22 #include "HsFFI.h"
  23 #include "Hash.h"
  24 #include "Linker.h"
  25 #include "LinkerInternals.h"
  26 #include "RtsUtils.h"
  27 #include "Schedule.h"
  28 #include "Storage.h"
  29
  30 #ifdef HAVE_SYS_TYPES_H
  31 #include <sys/types.h>
  32 #endif
  33
  34 #include <stdlib.h>
  35 #include <string.h>
  36
  37 #ifdef HAVE_SYS_STAT_H
  38 #include <sys/stat.h>
  39 #endif
  40
  41 #if defined(HAVE_DLFCN_H)
  42 #include <dlfcn.h>
  43 #endif
  44
  45 #if defined(cygwin32_HOST_OS)
  46 #ifdef HAVE_DIRENT_H
  47 #include <dirent.h>
  48 #endif
  49
  50 #ifdef HAVE_SYS_TIME_H
  51 #include <sys/time.h>
  52 #endif
  53 #include <regex.h>
  54 #include <sys/fcntl.h>
  55 #include <sys/termios.h>
  56 #include <sys/utime.h>
  57 #include <sys/utsname.h>
  58 #include <sys/wait.h>
  59 #endif
  60
  61 #if defined(ia64_HOST_ARCH) || defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
  62 #define USE_MMAP
  63 #include <fcntl.h>
  64 #include <sys/mman.h>
  65
  66 #if defined(openbsd_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS)
  67 #ifdef HAVE_UNISTD_H
  68 #include <unistd.h>
  69 #endif
  70 #endif
  71
  72 #endif
  73
  74 #if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS)
  75 #  define OBJFORMAT_ELF
  76 #elif defined(cygwin32_HOST_OS) || defined (mingw32_HOST_OS)
  77 #  define OBJFORMAT_PEi386
  78 #  include <windows.h>
  79 #  include <math.h>
  80 #elif defined(darwin_HOST_OS)
  81 #  define OBJFORMAT_MACHO
  82 #  include <mach-o/loader.h>
  83 #  include <mach-o/nlist.h>
  84 #  include <mach-o/reloc.h>
  85 #  include <mach-o/dyld.h>
  86 #if defined(powerpc_HOST_ARCH)
  87 #  include <mach-o/ppc/reloc.h>
  88 #endif
  89 #endif
  90
  91 /* Hash table mapping symbol names to Symbol */
  92 static /*Str*/HashTable *symhash;
  93
  94 /* List of currently loaded objects */
  95 ObjectCode *objects = NULL;     /* initially empty */
  96
  97 #if defined(OBJFORMAT_ELF)
  98 static int ocVerifyImage_ELF    ( ObjectCode* oc );
  99 static int ocGetNames_ELF       ( ObjectCode* oc );
 100 static int ocResolve_ELF        ( ObjectCode* oc );
 101 #if defined(powerpc_HOST_ARCH)
 102 static int ocAllocateJumpIslands_ELF ( ObjectCode* oc );
 103 #endif
 104 #elif defined(OBJFORMAT_PEi386)
 105 static int ocVerifyImage_PEi386 ( ObjectCode* oc );
 106 static int ocGetNames_PEi386    ( ObjectCode* oc );
 107 static int ocResolve_PEi386     ( ObjectCode* oc );
 108 #elif defined(OBJFORMAT_MACHO)
 109 static int ocVerifyImage_MachO    ( ObjectCode* oc );
 110 static int ocGetNames_MachO       ( ObjectCode* oc );
 111 static int ocResolve_MachO        ( ObjectCode* oc );
 112
 113 static int machoGetMisalignment( FILE * );
 114 #ifdef powerpc_HOST_ARCH
 115 static int ocAllocateJumpIslands_MachO ( ObjectCode* oc );
 116 static void machoInitSymbolsWithoutUnderscore( void );
 117 #endif
 118 #endif
 119
 120 /* -----------------------------------------------------------------------------
 121  * Built-in symbols from the RTS
 122  */
 123
 124 typedef struct _RtsSymbolVal {
 125     char   *lbl;
 126     void   *addr;
 127 } RtsSymbolVal;
 128
 129
 130 #if !defined(PAR)
 131 #define Maybe_ForeignObj        SymX(mkForeignObjzh_fast)
 132
 133 #define Maybe_Stable_Names      SymX(mkWeakzh_fast)                     \
 134                                 SymX(makeStableNamezh_fast)             \
 135                                 SymX(finalizzeWeakzh_fast)
 136 #else
 137 /* These are not available in GUM!!! -- HWL */
 138 #define Maybe_ForeignObj
 139 #define Maybe_Stable_Names
 140 #endif
 141
 142 #if !defined (mingw32_HOST_OS)
 143 #define RTS_POSIX_ONLY_SYMBOLS                  \
 144       SymX(stg_sig_install)                     \
 145       Sym(nocldstop)
 146 #endif
 147
 148 #if defined (cygwin32_HOST_OS)
 149 #define RTS_MINGW_ONLY_SYMBOLS /**/
 150 /* Don't have the ability to read import libs / archives, so
 151  * we have to stupidly list a lot of what libcygwin.a
 152  * exports; sigh.
 153  */
 154 #define RTS_CYGWIN_ONLY_SYMBOLS                 \
 155       SymX(regfree)                             \
 156       SymX(regexec)                             \
 157       SymX(regerror)                            \
 158       SymX(regcomp)                             \
 159       SymX(__errno)                             \
 160       SymX(access)                              \
 161       SymX(chmod)                               \
 162       SymX(chdir)                               \
 163       SymX(close)                               \
 164       SymX(creat)                               \
 165       SymX(dup)                                 \
 166       SymX(dup2)                                \
 167       SymX(fstat)                               \
 168       SymX(fcntl)                               \
 169       SymX(getcwd)                              \
 170       SymX(getenv)                              \
 171       SymX(lseek)                               \
 172       SymX(open)                                \
 173       SymX(fpathconf)                           \
 174       SymX(pathconf)                            \
 175       SymX(stat)                                \
 176       SymX(pow)                                 \
 177       SymX(tanh)                                \
 178       SymX(cosh)                                \
 179       SymX(sinh)                                \
 180       SymX(atan)                                \
 181       SymX(acos)                                \
 182       SymX(asin)                                \
 183       SymX(tan)                                 \
 184       SymX(cos)                                 \
 185       SymX(sin)                                 \
 186       SymX(exp)                                 \
 187       SymX(log)                                 \
 188       SymX(sqrt)                                \
 189       SymX(localtime_r)                         \
 190       SymX(gmtime_r)                            \
 191       SymX(mktime)                              \
 192       Sym(_imp___tzname)                        \
 193       SymX(gettimeofday)                        \
 194       SymX(timezone)                            \
 195       SymX(tcgetattr)                           \
 196       SymX(tcsetattr)                           \
 197       SymX(memcpy)                              \
 198       SymX(memmove)                             \
 199       SymX(realloc)                             \
 200       SymX(malloc)                              \
 201       SymX(free)                                \
 202       SymX(fork)                                \
 203       SymX(lstat)                               \
 204       SymX(isatty)                              \
 205       SymX(mkdir)                               \
 206       SymX(opendir)                             \
 207       SymX(readdir)                             \
 208       SymX(rewinddir)                           \
 209       SymX(closedir)                            \
 210       SymX(link)                                \
 211       SymX(mkfifo)                              \
 212       SymX(pipe)                                \
 213       SymX(read)                                \
 214       SymX(rename)                              \
 215       SymX(rmdir)                               \
 216       SymX(select)                              \
 217       SymX(system)                              \
 218       SymX(write)                               \
 219       SymX(strcmp)                              \
 220       SymX(strcpy)                              \
 221       SymX(strncpy)                             \
 222       SymX(strerror)                            \
 223       SymX(sigaddset)                           \
 224       SymX(sigemptyset)                         \
 225       SymX(sigprocmask)                         \
 226       SymX(umask)                               \
 227       SymX(uname)                               \
 228       SymX(unlink)                              \
 229       SymX(utime)                               \
 230       SymX(waitpid)
 231
 232 #elif !defined(mingw32_HOST_OS)
 233 #define RTS_MINGW_ONLY_SYMBOLS /**/
 234 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 235 #else /* defined(mingw32_HOST_OS) */
 236 #define RTS_POSIX_ONLY_SYMBOLS  /**/
 237 #define RTS_CYGWIN_ONLY_SYMBOLS /**/
 238
 239 /* Extra syms gen'ed by mingw-2's gcc-3.2: */
 240 #if __GNUC__>=3
 241 #define RTS_MINGW_EXTRA_SYMS                    \
 242       Sym(_imp____mb_cur_max)                   \
 243       Sym(_imp___pctype)
 244 #else
 245 #define RTS_MINGW_EXTRA_SYMS
 246 #endif
 247
 248 /* These are statically linked from the mingw libraries into the ghc
 249    executable, so we have to employ this hack. */
 250 #define RTS_MINGW_ONLY_SYMBOLS                  \
 251       SymX(asyncReadzh_fast)                    \
 252       SymX(asyncWritezh_fast)                   \
 253       SymX(asyncDoProczh_fast)                  \
 254       SymX(memset)                              \
 255       SymX(inet_ntoa)                           \
 256       SymX(inet_addr)                           \
 257       SymX(htonl)                               \
 258       SymX(recvfrom)                            \
 259       SymX(listen)                              \
 260       SymX(bind)                                \
 261       SymX(shutdown)                            \
 262       SymX(connect)                             \
 263       SymX(htons)                               \
 264       SymX(ntohs)                               \
 265       SymX(getservbyname)                       \
 266       SymX(getservbyport)                       \
 267       SymX(getprotobynumber)                    \
 268       SymX(getprotobyname)                      \
 269       SymX(gethostbyname)                       \
 270       SymX(gethostbyaddr)                       \
 271       SymX(gethostname)                         \
 272       SymX(strcpy)                              \
 273       SymX(strncpy)                             \
 274       SymX(abort)                               \
 275       Sym(_alloca)                              \
 276       Sym(isxdigit)                             \
 277       Sym(isupper)                              \
 278       Sym(ispunct)                              \
 279       Sym(islower)                              \
 280       Sym(isspace)                              \
 281       Sym(isprint)                              \
 282       Sym(isdigit)                              \
 283       Sym(iscntrl)                              \
 284       Sym(isalpha)                              \
 285       Sym(isalnum)                              \
 286       SymX(strcmp)                              \
 287       SymX(memmove)                             \
 288       SymX(realloc)                             \
 289       SymX(malloc)                              \
 290       SymX(pow)                                 \
 291       SymX(tanh)                                \
 292       SymX(cosh)                                \
 293       SymX(sinh)                                \
 294       SymX(atan)                                \
 295       SymX(acos)                                \
 296       SymX(asin)                                \
 297       SymX(tan)                                 \
 298       SymX(cos)                                 \
 299       SymX(sin)                                 \
 300       SymX(exp)                                 \
 301       SymX(log)                                 \
 302       SymX(sqrt)                                \
 303       SymX(memcpy)                              \
 304       SymX(rts_InstallConsoleEvent)             \
 305       SymX(rts_ConsoleHandlerDone)              \
 306       Sym(mktime)                               \
 307       Sym(_imp___timezone)                      \
 308       Sym(_imp___tzname)                        \
 309       Sym(_imp___iob)                           \
 310       Sym(_imp___osver)                         \
 311       Sym(localtime)                            \
 312       Sym(gmtime)                               \
 313       Sym(opendir)                              \
 314       Sym(readdir)                              \
 315       Sym(rewinddir)                            \
 316       RTS_MINGW_EXTRA_SYMS                      \
 317       Sym(closedir)
 318 #endif
 319
 320 #ifndef SMP
 321 # define MAIN_CAP_SYM SymX(MainCapability)
 322 #else
 323 # define MAIN_CAP_SYM
 324 #endif
 325
 326 #if !defined(mingw32_HOST_OS)
 327 #define RTS_USER_SIGNALS_SYMBOLS \
 328    SymX(startSignalHandler) \
 329    SymX(setIOManagerPipe)
 330 #else
 331 #define RTS_USER_SIGNALS_SYMBOLS /* nothing */
 332 #endif
 333
 334 #ifdef TABLES_NEXT_TO_CODE
 335 #define RTS_RET_SYMBOLS /* nothing */
 336 #else
 337 #define RTS_RET_SYMBOLS                         \
 338       SymX(stg_enter_ret)                       \
 339       SymX(stg_gc_fun_ret)                      \
 340       SymX(stg_ap_0_ret)                        \
 341       SymX(stg_ap_v_ret)                        \
 342       SymX(stg_ap_f_ret)                        \
 343       SymX(stg_ap_d_ret)                        \
 344       SymX(stg_ap_l_ret)                        \
 345       SymX(stg_ap_n_ret)                        \
 346       SymX(stg_ap_p_ret)                        \
 347       SymX(stg_ap_pv_ret)                       \
 348       SymX(stg_ap_pp_ret)                       \
 349       SymX(stg_ap_ppv_ret)                      \
 350       SymX(stg_ap_ppp_ret)                      \
 351       SymX(stg_ap_pppv_ret)                     \
 352       SymX(stg_ap_pppp_ret)                     \
 353       SymX(stg_ap_ppppp_ret)                    \
 354       SymX(stg_ap_pppppp_ret)
 355 #endif
 356
 357 #define RTS_SYMBOLS                             \
 358       Maybe_ForeignObj                          \
 359       Maybe_Stable_Names                        \
 360       Sym(StgReturn)                            \
 361       SymX(stg_enter_info)                      \
 362       SymX(stg_gc_void_info)                    \
 363       SymX(__stg_gc_enter_1)                    \
 364       SymX(stg_gc_noregs)                       \
 365       SymX(stg_gc_unpt_r1_info)                 \
 366       SymX(stg_gc_unpt_r1)                      \
 367       SymX(stg_gc_unbx_r1_info)                 \
 368       SymX(stg_gc_unbx_r1)                      \
 369       SymX(stg_gc_f1_info)                      \
 370       SymX(stg_gc_f1)                           \
 371       SymX(stg_gc_d1_info)                      \
 372       SymX(stg_gc_d1)                           \
 373       SymX(stg_gc_l1_info)                      \
 374       SymX(stg_gc_l1)                           \
 375       SymX(__stg_gc_fun)                        \
 376       SymX(stg_gc_fun_info)                     \
 377       SymX(stg_gc_gen)                          \
 378       SymX(stg_gc_gen_info)                     \
 379       SymX(stg_gc_gen_hp)                       \
 380       SymX(stg_gc_ut)                           \
 381       SymX(stg_gen_yield)                       \
 382       SymX(stg_yield_noregs)                    \
 383       SymX(stg_yield_to_interpreter)            \
 384       SymX(stg_gen_block)                       \
 385       SymX(stg_block_noregs)                    \
 386       SymX(stg_block_1)                         \
 387       SymX(stg_block_takemvar)                  \
 388       SymX(stg_block_putmvar)                   \
 389       SymX(stg_seq_frame_info)                  \
 390       MAIN_CAP_SYM                              \
 391       SymX(MallocFailHook)                      \
 392       SymX(OnExitHook)                          \
 393       SymX(OutOfHeapHook)                       \
 394       SymX(StackOverflowHook)                   \
 395       SymX(__encodeDouble)                      \
 396       SymX(__encodeFloat)                       \
 397       SymX(addDLL)                              \
 398       SymX(__gmpn_gcd_1)                        \
 399       SymX(__gmpz_cmp)                          \
 400       SymX(__gmpz_cmp_si)                       \
 401       SymX(__gmpz_cmp_ui)                       \
 402       SymX(__gmpz_get_si)                       \
 403       SymX(__gmpz_get_ui)                       \
 404       SymX(__int_encodeDouble)                  \
 405       SymX(__int_encodeFloat)                   \
 406       SymX(andIntegerzh_fast)                   \
 407       SymX(atomicallyzh_fast)                   \
 408       SymX(barf)                                \
 409       SymX(debugBelch)                          \
 410       SymX(errorBelch)                          \
 411       SymX(blockAsyncExceptionszh_fast)         \
 412       SymX(catchzh_fast)                        \
 413       SymX(catchRetryzh_fast)                   \
 414       SymX(catchSTMzh_fast)                     \
 415       SymX(closure_flags)                       \
 416       SymX(cmp_thread)                          \
 417       SymX(cmpIntegerzh_fast)                   \
 418       SymX(cmpIntegerIntzh_fast)                \
 419       SymX(complementIntegerzh_fast)            \
 420       SymX(createAdjustor)                      \
 421       SymX(decodeDoublezh_fast)                 \
 422       SymX(decodeFloatzh_fast)                  \
 423       SymX(defaultsHook)                        \
 424       SymX(delayzh_fast)                        \
 425       SymX(deRefWeakzh_fast)                    \
 426       SymX(deRefStablePtrzh_fast)               \
 427       SymX(divExactIntegerzh_fast)              \
 428       SymX(divModIntegerzh_fast)                \
 429       SymX(forkzh_fast)                         \
 430       SymX(forkProcess)                         \
 431       SymX(forkOS_createThread)                 \
 432       SymX(freeHaskellFunctionPtr)              \
 433       SymX(freeStablePtr)                       \
 434       SymX(gcdIntegerzh_fast)                   \
 435       SymX(gcdIntegerIntzh_fast)                \
 436       SymX(gcdIntzh_fast)                       \
 437       SymX(genSymZh)                            \
 438       SymX(genericRaise)                        \
 439       SymX(getProgArgv)                         \
 440       SymX(getStablePtr)                        \
 441       SymX(hs_init)                             \
 442       SymX(hs_exit)                             \
 443       SymX(hs_set_argv)                         \
 444       SymX(hs_add_root)                         \
 445       SymX(hs_perform_gc)                       \
 446       SymX(hs_free_stable_ptr)                  \
 447       SymX(hs_free_fun_ptr)                     \
 448       SymX(initLinker)                          \
 449       SymX(int2Integerzh_fast)                  \
 450       SymX(integer2Intzh_fast)                  \
 451       SymX(integer2Wordzh_fast)                 \
 452       SymX(isCurrentThreadBoundzh_fast)         \
 453       SymX(isDoubleDenormalized)                \
 454       SymX(isDoubleInfinite)                    \
 455       SymX(isDoubleNaN)                         \
 456       SymX(isDoubleNegativeZero)                \
 457       SymX(isEmptyMVarzh_fast)                  \
 458       SymX(isFloatDenormalized)                 \
 459       SymX(isFloatInfinite)                     \
 460       SymX(isFloatNaN)                          \
 461       SymX(isFloatNegativeZero)                 \
 462       SymX(killThreadzh_fast)                   \
 463       SymX(loadObj)                             \
 464       SymX(lookupSymbol)                        \
 465       SymX(makeStablePtrzh_fast)                \
 466       SymX(minusIntegerzh_fast)                 \
 467       SymX(mkApUpd0zh_fast)                     \
 468       SymX(myThreadIdzh_fast)                   \
 469       SymX(labelThreadzh_fast)                  \
 470       SymX(newArrayzh_fast)                     \
 471       SymX(newBCOzh_fast)                       \
 472       SymX(newByteArrayzh_fast)                 \
 473       SymX_redirect(newCAF, newDynCAF)          \
 474       SymX(newMVarzh_fast)                      \
 475       SymX(newMutVarzh_fast)                    \
 476       SymX(newTVarzh_fast)                      \
 477       SymX(atomicModifyMutVarzh_fast)           \
 478       SymX(newPinnedByteArrayzh_fast)           \
 479       SymX(orIntegerzh_fast)                    \
 480       SymX(performGC)                           \
 481       SymX(performMajorGC)                      \
 482       SymX(plusIntegerzh_fast)                  \
 483       SymX(prog_argc)                           \
 484       SymX(prog_argv)                           \
 485       SymX(putMVarzh_fast)                      \
 486       SymX(quotIntegerzh_fast)                  \
 487       SymX(quotRemIntegerzh_fast)               \
 488       SymX(raisezh_fast)                        \
 489       SymX(raiseIOzh_fast)                      \
 490       SymX(readTVarzh_fast)                     \
 491       SymX(remIntegerzh_fast)                   \
 492       SymX(resetNonBlockingFd)                  \
 493       SymX(resumeThread)                        \
 494       SymX(resolveObjs)                         \
 495       SymX(retryzh_fast)                        \
 496       SymX(rts_apply)                           \
 497       SymX(rts_checkSchedStatus)                \
 498       SymX(rts_eval)                            \
 499       SymX(rts_evalIO)                          \
 500       SymX(rts_evalLazyIO)                      \
 501       SymX(rts_evalStableIO)                    \
 502       SymX(rts_eval_)                           \
 503       SymX(rts_getBool)                         \
 504       SymX(rts_getChar)                         \
 505       SymX(rts_getDouble)                       \
 506       SymX(rts_getFloat)                        \
 507       SymX(rts_getInt)                          \
 508       SymX(rts_getInt32)                        \
 509       SymX(rts_getPtr)                          \
 510       SymX(rts_getFunPtr)                       \
 511       SymX(rts_getStablePtr)                    \
 512       SymX(rts_getThreadId)                     \
 513       SymX(rts_getWord)                         \
 514       SymX(rts_getWord32)                       \
 515       SymX(rts_lock)                            \
 516       SymX(rts_mkBool)                          \
 517       SymX(rts_mkChar)                          \
 518       SymX(rts_mkDouble)                        \
 519       SymX(rts_mkFloat)                         \
 520       SymX(rts_mkInt)                           \
 521       SymX(rts_mkInt16)                         \
 522       SymX(rts_mkInt32)                         \
 523       SymX(rts_mkInt64)                         \
 524       SymX(rts_mkInt8)                          \
 525       SymX(rts_mkPtr)                           \
 526       SymX(rts_mkFunPtr)                        \
 527       SymX(rts_mkStablePtr)                     \
 528       SymX(rts_mkString)                        \
 529       SymX(rts_mkWord)                          \
 530       SymX(rts_mkWord16)                        \
 531       SymX(rts_mkWord32)                        \
 532       SymX(rts_mkWord64)                        \
 533       SymX(rts_mkWord8)                         \
 534       SymX(rts_unlock)                          \
 535       SymX(rtsSupportsBoundThreads)             \
 536       SymX(run_queue_hd)                        \
 537       SymX(__hscore_get_saved_termios)          \
 538       SymX(__hscore_set_saved_termios)          \
 539       SymX(setProgArgv)                         \
 540       SymX(startupHaskell)                      \
 541       SymX(shutdownHaskell)                     \
 542       SymX(shutdownHaskellAndExit)              \
 543       SymX(stable_ptr_table)                    \
 544       SymX(stackOverflow)                       \
 545       SymX(stg_CAF_BLACKHOLE_info)              \
 546       SymX(awakenBlockedQueue)                  \
 547       SymX(stg_CHARLIKE_closure)                \
 548       SymX(stg_EMPTY_MVAR_info)                 \
 549       SymX(stg_IND_STATIC_info)                 \
 550       SymX(stg_INTLIKE_closure)                 \
 551       SymX(stg_MUT_ARR_PTRS_FROZEN_info)        \
 552       SymX(stg_MUT_ARR_PTRS_FROZEN0_info)       \
 553       SymX(stg_WEAK_info)                       \
 554       SymX(stg_ap_0_info)                       \
 555       SymX(stg_ap_v_info)                       \
 556       SymX(stg_ap_f_info)                       \
 557       SymX(stg_ap_d_info)                       \
 558       SymX(stg_ap_l_info)                       \
 559       SymX(stg_ap_n_info)                       \
 560       SymX(stg_ap_p_info)                       \
 561       SymX(stg_ap_pv_info)                      \
 562       SymX(stg_ap_pp_info)                      \
 563       SymX(stg_ap_ppv_info)                     \
 564       SymX(stg_ap_ppp_info)                     \
 565       SymX(stg_ap_pppv_info)                    \
 566       SymX(stg_ap_pppp_info)                    \
 567       SymX(stg_ap_ppppp_info)                   \
 568       SymX(stg_ap_pppppp_info)                  \
 569       SymX(stg_ap_1_upd_info)                   \
 570       SymX(stg_ap_2_upd_info)                   \
 571       SymX(stg_ap_3_upd_info)                   \
 572       SymX(stg_ap_4_upd_info)                   \
 573       SymX(stg_ap_5_upd_info)                   \
 574       SymX(stg_ap_6_upd_info)                   \
 575       SymX(stg_ap_7_upd_info)                   \
 576       SymX(stg_exit)                            \
 577       SymX(stg_sel_0_upd_info)                  \
 578       SymX(stg_sel_10_upd_info)                 \
 579       SymX(stg_sel_11_upd_info)                 \
 580       SymX(stg_sel_12_upd_info)                 \
 581       SymX(stg_sel_13_upd_info)                 \
 582       SymX(stg_sel_14_upd_info)                 \
 583       SymX(stg_sel_15_upd_info)                 \
 584       SymX(stg_sel_1_upd_info)                  \
 585       SymX(stg_sel_2_upd_info)                  \
 586       SymX(stg_sel_3_upd_info)                  \
 587       SymX(stg_sel_4_upd_info)                  \
 588       SymX(stg_sel_5_upd_info)                  \
 589       SymX(stg_sel_6_upd_info)                  \
 590       SymX(stg_sel_7_upd_info)                  \
 591       SymX(stg_sel_8_upd_info)                  \
 592       SymX(stg_sel_9_upd_info)                  \
 593       SymX(stg_upd_frame_info)                  \
 594       SymX(suspendThread)                       \
 595       SymX(takeMVarzh_fast)                     \
 596       SymX(timesIntegerzh_fast)                 \
 597       SymX(tryPutMVarzh_fast)                   \
 598       SymX(tryTakeMVarzh_fast)                  \
 599       SymX(unblockAsyncExceptionszh_fast)       \
 600       SymX(unloadObj)                           \
 601       SymX(unsafeThawArrayzh_fast)              \
 602       SymX(waitReadzh_fast)                     \
 603       SymX(waitWritezh_fast)                    \
 604       SymX(word2Integerzh_fast)                 \
 605       SymX(writeTVarzh_fast)                    \
 606       SymX(xorIntegerzh_fast)                   \
 607       SymX(yieldzh_fast)                        \
 608       RTS_USER_SIGNALS_SYMBOLS
 609
 610 #ifdef SUPPORT_LONG_LONGS
 611 #define RTS_LONG_LONG_SYMS                      \
 612       SymX(int64ToIntegerzh_fast)               \
 613       SymX(word64ToIntegerzh_fast)
 614 #else
 615 #define RTS_LONG_LONG_SYMS /* nothing */
 616 #endif
 617
 618 // 64-bit support functions in libgcc.a
 619 #if defined(__GNUC__) && SIZEOF_VOID_P <= 4
 620 #define RTS_LIBGCC_SYMBOLS                      \
 621       Sym(__divdi3)                             \
 622       Sym(__udivdi3)                            \
 623       Sym(__moddi3)                             \
 624       Sym(__umoddi3)                            \
 625       Sym(__muldi3)                             \
 626       Sym(__ashldi3)                            \
 627       Sym(__ashrdi3)                            \
 628       Sym(__lshrdi3)                            \
 629       Sym(__eprintf)
 630 #elif defined(ia64_HOST_ARCH)
 631 #define RTS_LIBGCC_SYMBOLS                      \
 632       Sym(__divdi3)                             \
 633       Sym(__udivdi3)                            \
 634       Sym(__moddi3)                             \
 635       Sym(__umoddi3)                            \
 636       Sym(__divsf3)                             \
 637       Sym(__divdf3)
 638 #else
 639 #define RTS_LIBGCC_SYMBOLS
 640 #endif
 641
 642 #if defined(darwin_HOST_OS) && defined(powerpc_HOST_ARCH)
 643       // Symbols that don't have a leading underscore
 644       // on Mac OS X. They have to receive special treatment,
 645       // see machoInitSymbolsWithoutUnderscore()
 646 #define RTS_MACHO_NOUNDERLINE_SYMBOLS           \
 647       Sym(saveFP)                               \
 648       Sym(restFP)
 649 #endif
 650
 651 /* entirely bogus claims about types of these symbols */
 652 #define Sym(vvv)  extern void vvv(void);
 653 #define SymX(vvv) /**/
 654 #define SymX_redirect(vvv,xxx) /**/
 655 RTS_SYMBOLS
 656 RTS_RET_SYMBOLS
 657 RTS_LONG_LONG_SYMS
 658 RTS_POSIX_ONLY_SYMBOLS
 659 RTS_MINGW_ONLY_SYMBOLS
 660 RTS_CYGWIN_ONLY_SYMBOLS
 661 RTS_LIBGCC_SYMBOLS
 662 #undef Sym
 663 #undef SymX
 664 #undef SymX_redirect
 665
 666 #ifdef LEADING_UNDERSCORE
 667 #define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
 668 #else
 669 #define MAYBE_LEADING_UNDERSCORE_STR(s) (s)
 670 #endif
 671
 672 #define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 673                     (void*)(&(vvv)) },
 674 #define SymX(vvv) Sym(vvv)
 675
 676 // SymX_redirect allows us to redirect references to one symbol to
 677 // another symbol.  See newCAF/newDynCAF for an example.
 678 #define SymX_redirect(vvv,xxx) \
 679     { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
 680       (void*)(&(xxx)) },
 681
 682 static RtsSymbolVal rtsSyms[] = {
 683       RTS_SYMBOLS
 684       RTS_RET_SYMBOLS
 685       RTS_LONG_LONG_SYMS
 686       RTS_POSIX_ONLY_SYMBOLS
 687       RTS_MINGW_ONLY_SYMBOLS
 688       RTS_CYGWIN_ONLY_SYMBOLS
 689       RTS_LIBGCC_SYMBOLS
 690 #if defined(darwin_HOST_OS) && defined(i386_HOST_ARCH)
 691       // dyld stub code contains references to this,
 692       // but it should never be called because we treat
 693       // lazy pointers as nonlazy.
 694       { "dyld_stub_binding_helper", (void*)0xDEADBEEF },
 695 #endif
 696       { 0, 0 } /* sentinel */
 697 };
 698
 699 /* -----------------------------------------------------------------------------
 700  * Insert symbols into hash tables, checking for duplicates.
 701  */
 702 static void ghciInsertStrHashTable ( char* obj_name,
 703                                      HashTable *table,
 704                                      char* key,
 705                                      void *data
 706                                    )
 707 {
 708    if (lookupHashTable(table, (StgWord)key) == NULL)
 709    {
 710       insertStrHashTable(table, (StgWord)key, data);
 711       return;
 712    }
 713    debugBelch(
 714       "\n\n"
 715       "GHCi runtime linker: fatal error: I found a duplicate definition for symbol\n"
 716       "   %s\n"
 717       "whilst processing object file\n"
 718       "   %s\n"
 719       "This could be caused by:\n"
 720       "   * Loading two different object files which export the same symbol\n"
 721       "   * Specifying the same object file twice on the GHCi command line\n"
 722       "   * An incorrect `package.conf' entry, causing some object to be\n"
 723       "     loaded twice.\n"
 724       "GHCi cannot safely continue in this situation.  Exiting now.  Sorry.\n"
 725       "\n",
 726       (char*)key,
 727       obj_name
 728    );
 729    exit(1);
 730 }
 731
 732
 733 /* -----------------------------------------------------------------------------
 734  * initialize the object linker
 735  */
 736
 737
 738 static int linker_init_done = 0 ;
 739
 740 #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 741 static void *dl_prog_handle;
 742 #endif
 743
 744 /* dlopen(NULL,..) doesn't work so we grab libc explicitly */
 745 #if defined(openbsd_HOST_OS)
 746 static void *dl_libc_handle;
 747 #endif
 748
 749 void
 750 initLinker( void )
 751 {
 752     RtsSymbolVal *sym;
 753
 754     /* Make initLinker idempotent, so we can call it
 755        before evey relevant operation; that means we
 756        don't need to initialise the linker separately */
 757     if (linker_init_done == 1) { return; } else {
 758       linker_init_done = 1;
 759     }
 760
 761     symhash = allocStrHashTable();
 762
 763     /* populate the symbol table with stuff from the RTS */
 764     for (sym = rtsSyms; sym->lbl != NULL; sym++) {
 765         ghciInsertStrHashTable("(GHCi built-in symbols)",
 766                                symhash, sym->lbl, sym->addr);
 767     }
 768 #   if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
 769     machoInitSymbolsWithoutUnderscore();
 770 #   endif
 771
 772 #   if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 773 #   if defined(RTLD_DEFAULT)
 774     dl_prog_handle = RTLD_DEFAULT;
 775 #   else
 776     dl_prog_handle = dlopen(NULL, RTLD_LAZY);
 777 #   if defined(openbsd_HOST_OS)
 778     dl_libc_handle = dlopen("libc.so", RTLD_LAZY);
 779 #   endif
 780 #   endif /* RTLD_DEFAULT */
 781 #   endif
 782 }
 783
 784 /* -----------------------------------------------------------------------------
 785  *                  Loading DLL or .so dynamic libraries
 786  * -----------------------------------------------------------------------------
 787  *
 788  * Add a DLL from which symbols may be found.  In the ELF case, just
 789  * do RTLD_GLOBAL-style add, so no further messing around needs to
 790  * happen in order that symbols in the loaded .so are findable --
 791  * lookupSymbol() will subsequently see them by dlsym on the program's
 792  * dl-handle.  Returns NULL if success, otherwise ptr to an err msg.
 793  *
 794  * In the PEi386 case, open the DLLs and put handles to them in a
 795  * linked list.  When looking for a symbol, try all handles in the
 796  * list.  This means that we need to load even DLLs that are guaranteed
 797  * to be in the ghc.exe image already, just so we can get a handle
 798  * to give to loadSymbol, so that we can find the symbols.  For such
 799  * libraries, the LoadLibrary call should be a no-op except for returning
 800  * the handle.
 801  *
 802  */
 803
 804 #if defined(OBJFORMAT_PEi386)
 805 /* A record for storing handles into DLLs. */
 806
 807 typedef
 808    struct _OpenedDLL {
 809       char*              name;
 810       struct _OpenedDLL* next;
 811       HINSTANCE instance;
 812    }
 813    OpenedDLL;
 814
 815 /* A list thereof. */
 816 static OpenedDLL* opened_dlls = NULL;
 817 #endif
 818
 819 char *
 820 addDLL( char *dll_name )
 821 {
 822 #  if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
 823    /* ------------------- ELF DLL loader ------------------- */
 824    void *hdl;
 825    char *errmsg;
 826
 827    initLinker();
 828
 829    hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
 830
 831    if (hdl == NULL) {
 832       /* dlopen failed; return a ptr to the error msg. */
 833       errmsg = dlerror();
 834       if (errmsg == NULL) errmsg = "addDLL: unknown error";
 835       return errmsg;
 836    } else {
 837       return NULL;
 838    }
 839    /*NOTREACHED*/
 840
 841 #  elif defined(OBJFORMAT_PEi386)
 842    /* ------------------- Win32 DLL loader ------------------- */
 843
 844    char*      buf;
 845    OpenedDLL* o_dll;
 846    HINSTANCE  instance;
 847
 848    initLinker();
 849
 850    /* debugBelch("\naddDLL; dll_name = `%s'\n", dll_name); */
 851
 852    /* See if we've already got it, and ignore if so. */
 853    for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 854       if (0 == strcmp(o_dll->name, dll_name))
 855          return NULL;
 856    }
 857
 858    /* The file name has no suffix (yet) so that we can try
 859       both foo.dll and foo.drv
 860
 861       The documentation for LoadLibrary says:
 862         If no file name extension is specified in the lpFileName
 863         parameter, the default library extension .dll is
 864         appended. However, the file name string can include a trailing
 865         point character (.) to indicate that the module name has no
 866         extension. */
 867
 868    buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
 869    sprintf(buf, "%s.DLL", dll_name);
 870    instance = LoadLibrary(buf);
 871    if (instance == NULL) {
 872          sprintf(buf, "%s.DRV", dll_name);      // KAA: allow loading of drivers (like winspool.drv)
 873          instance = LoadLibrary(buf);
 874          if (instance == NULL) {
 875                 stgFree(buf);
 876
 877             /* LoadLibrary failed; return a ptr to the error msg. */
 878             return "addDLL: unknown error";
 879          }
 880    }
 881    stgFree(buf);
 882
 883    /* Add this DLL to the list of DLLs in which to search for symbols. */
 884    o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
 885    o_dll->name     = stgMallocBytes(1+strlen(dll_name), "addDLL");
 886    strcpy(o_dll->name, dll_name);
 887    o_dll->instance = instance;
 888    o_dll->next     = opened_dlls;
 889    opened_dlls     = o_dll;
 890
 891    return NULL;
 892 #  else
 893    barf("addDLL: not implemented on this platform");
 894 #  endif
 895 }
 896
 897 /* -----------------------------------------------------------------------------
 898  * lookup a symbol in the hash table
 899  */
 900 void *
 901 lookupSymbol( char *lbl )
 902 {
 903     void *val;
 904     initLinker() ;
 905     ASSERT(symhash != NULL);
 906     val = lookupStrHashTable(symhash, lbl);
 907
 908     if (val == NULL) {
 909 #       if defined(OBJFORMAT_ELF)
 910 #       if defined(openbsd_HOST_OS)
 911         val = dlsym(dl_prog_handle, lbl);
 912         return (val != NULL) ? val : dlsym(dl_libc_handle,lbl);
 913 #       else /* not openbsd */
 914         return dlsym(dl_prog_handle, lbl);
 915 #       endif
 916 #       elif defined(OBJFORMAT_MACHO)
 917         if(NSIsSymbolNameDefined(lbl)) {
 918             NSSymbol symbol = NSLookupAndBindSymbol(lbl);
 919             return NSAddressOfSymbol(symbol);
 920         } else {
 921             return NULL;
 922         }
 923 #       elif defined(OBJFORMAT_PEi386)
 924         OpenedDLL* o_dll;
 925         void* sym;
 926         for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
 927           /* debugBelch("look in %s for %s\n", o_dll->name, lbl); */
 928            if (lbl[0] == '_') {
 929               /* HACK: if the name has an initial underscore, try stripping
 930                  it off & look that up first. I've yet to verify whether there's
 931                  a Rule that governs whether an initial '_' *should always* be
 932                  stripped off when mapping from import lib name to the DLL name.
 933               */
 934               sym = GetProcAddress(o_dll->instance, (lbl+1));
 935               if (sym != NULL) {
 936                 /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/
 937                 return sym;
 938               }
 939            }
 940            sym = GetProcAddress(o_dll->instance, lbl);
 941            if (sym != NULL) {
 942              /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/
 943              return sym;
 944            }
 945         }
 946         return NULL;
 947 #       else
 948         ASSERT(2+2 == 5);
 949         return NULL;
 950 #       endif
 951     } else {
 952         return val;
 953     }
 954 }
 955
 956 static
 957 __attribute((unused))
 958 void *
 959 lookupLocalSymbol( ObjectCode* oc, char *lbl )
 960 {
 961     void *val;
 962     initLinker() ;
 963     val = lookupStrHashTable(oc->lochash, lbl);
 964
 965     if (val == NULL) {
 966         return NULL;
 967     } else {
 968         return val;
 969     }
 970 }
 971
 972
 973 /* -----------------------------------------------------------------------------
 974  * Debugging aid: look in GHCi's object symbol tables for symbols
 975  * within DELTA bytes of the specified address, and show their names.
 976  */
 977 #ifdef DEBUG
 978 void ghci_enquire ( char* addr );
 979
 980 void ghci_enquire ( char* addr )
 981 {
 982    int   i;
 983    char* sym;
 984    char* a;
 985    const int DELTA = 64;
 986    ObjectCode* oc;
 987
 988    initLinker();
 989
 990    for (oc = objects; oc; oc = oc->next) {
 991       for (i = 0; i < oc->n_symbols; i++) {
 992          sym = oc->symbols[i];
 993          if (sym == NULL) continue;
 994          // debugBelch("enquire %p %p\n", sym, oc->lochash);
 995          a = NULL;
 996          if (oc->lochash != NULL) {
 997             a = lookupStrHashTable(oc->lochash, sym);
 998          }
 999          if (a == NULL) {
1000             a = lookupStrHashTable(symhash, sym);
1001          }
1002          if (a == NULL) {
1003              // debugBelch("ghci_enquire: can't find %s\n", sym);
1004          }
1005          else if (addr-DELTA <= a && a <= addr+DELTA) {
1006             debugBelch("%p + %3d  ==  `%s'\n", addr, a - addr, sym);
1007          }
1008       }
1009    }
1010 }
1011 #endif
1012
1013 #ifdef ia64_HOST_ARCH
1014 static unsigned int PLTSize(void);
1015 #endif
1016
1017 /* -----------------------------------------------------------------------------
1018  * Load an obj (populate the global symbol table, but don't resolve yet)
1019  *
1020  * Returns: 1 if ok, 0 on error.
1021  */
1022 HsInt
1023 loadObj( char *path )
1024 {
1025    ObjectCode* oc;
1026    struct stat st;
1027    int r, n;
1028 #ifdef USE_MMAP
1029    int fd, pagesize;
1030    void *map_addr = NULL;
1031 #else
1032    FILE *f;
1033    int misalignment;
1034 #endif
1035    initLinker();
1036
1037    /* debugBelch("loadObj %s\n", path ); */
1038
1039    /* Check that we haven't already loaded this object.
1040       Ignore requests to load multiple times */
1041    {
1042        ObjectCode *o;
1043        int is_dup = 0;
1044        for (o = objects; o; o = o->next) {
1045           if (0 == strcmp(o->fileName, path)) {
1046              is_dup = 1;
1047              break; /* don't need to search further */
1048           }
1049        }
1050        if (is_dup) {
1051           IF_DEBUG(linker, debugBelch(
1052             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1053             "same object file twice:\n"
1054             "   %s\n"
1055             "GHCi will ignore this, but be warned.\n"
1056             , path));
1057           return 1; /* success */
1058        }
1059    }
1060
1061    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
1062
1063 #  if defined(OBJFORMAT_ELF)
1064    oc->formatName = "ELF";
1065 #  elif defined(OBJFORMAT_PEi386)
1066    oc->formatName = "PEi386";
1067 #  elif defined(OBJFORMAT_MACHO)
1068    oc->formatName = "Mach-O";
1069 #  else
1070    stgFree(oc);
1071    barf("loadObj: not implemented on this platform");
1072 #  endif
1073
1074    r = stat(path, &st);
1075    if (r == -1) { return 0; }
1076
1077    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1078    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1079    strcpy(oc->fileName, path);
1080
1081    oc->fileSize          = st.st_size;
1082    oc->symbols           = NULL;
1083    oc->sections          = NULL;
1084    oc->lochash           = allocStrHashTable();
1085    oc->proddables        = NULL;
1086
1087    /* chain it onto the list of objects */
1088    oc->next              = objects;
1089    objects               = oc;
1090
1091 #ifdef USE_MMAP
1092 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1093
1094    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1095
1096 #if defined(openbsd_HOST_OS)
1097    fd = open(path, O_RDONLY, S_IRUSR);
1098 #else
1099    fd = open(path, O_RDONLY);
1100 #endif
1101    if (fd == -1)
1102       barf("loadObj: can't open `%s'", path);
1103
1104    pagesize = getpagesize();
1105
1106 #ifdef ia64_HOST_ARCH
1107    /* The PLT needs to be right before the object */
1108    n = ROUND_UP(PLTSize(), pagesize);
1109    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1110    if (oc->plt == MAP_FAILED)
1111       barf("loadObj: can't allocate PLT");
1112
1113    oc->pltIndex = 0;
1114    map_addr = oc->plt + n;
1115 #endif
1116
1117    n = ROUND_UP(oc->fileSize, pagesize);
1118
1119    /* Link objects into the lower 2Gb on x86_64.  GHC assumes the
1120     * small memory model on this architecture (see gcc docs,
1121     * -mcmodel=small).
1122     */
1123 #ifdef x86_64_HOST_ARCH
1124 #define EXTRA_MAP_FLAGS MAP_32BIT
1125 #else
1126 #define EXTRA_MAP_FLAGS 0
1127 #endif
1128
1129    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE,
1130                     MAP_PRIVATE|EXTRA_MAP_FLAGS, fd, 0);
1131    if (oc->image == MAP_FAILED)
1132       barf("loadObj: can't map `%s'", path);
1133
1134    close(fd);
1135
1136 #else /* !USE_MMAP */
1137
1138    /* load the image into memory */
1139    f = fopen(path, "rb");
1140    if (!f)
1141        barf("loadObj: can't read `%s'", path);
1142
1143 #ifdef darwin_HOST_OS
1144     // In a Mach-O .o file, all sections can and will be misaligned
1145     // if the total size of the headers is not a multiple of the
1146     // desired alignment. This is fine for .o files that only serve
1147     // as input for the static linker, but it's not fine for us,
1148     // as SSE (used by gcc for floating point) and Altivec require
1149     // 16-byte alignment.
1150     // We calculate the correct alignment from the header before
1151     // reading the file, and then we misalign oc->image on purpose so
1152     // that the actual sections end up aligned again.
1153    misalignment = machoGetMisalignment(f);
1154 #else
1155    misalignment = 0;
1156 #endif
1157
1158    oc->image = stgMallocBytes(oc->fileSize + misalignment, "loadObj(image)");
1159    oc->image += misalignment;
1160
1161    n = fread ( oc->image, 1, oc->fileSize, f );
1162    if (n != oc->fileSize)
1163       barf("loadObj: error whilst reading `%s'", path);
1164
1165    fclose(f);
1166
1167 #endif /* USE_MMAP */
1168
1169 #  if defined(OBJFORMAT_MACHO) && defined(powerpc_HOST_ARCH)
1170    r = ocAllocateJumpIslands_MachO ( oc );
1171    if (!r) { return r; }
1172 #  elif defined(OBJFORMAT_ELF) && defined(powerpc_HOST_ARCH)
1173    r = ocAllocateJumpIslands_ELF ( oc );
1174    if (!r) { return r; }
1175 #endif
1176
1177    /* verify the in-memory image */
1178 #  if defined(OBJFORMAT_ELF)
1179    r = ocVerifyImage_ELF ( oc );
1180 #  elif defined(OBJFORMAT_PEi386)
1181    r = ocVerifyImage_PEi386 ( oc );
1182 #  elif defined(OBJFORMAT_MACHO)
1183    r = ocVerifyImage_MachO ( oc );
1184 #  else
1185    barf("loadObj: no verify method");
1186 #  endif
1187    if (!r) { return r; }
1188
1189    /* build the symbol list for this image */
1190 #  if defined(OBJFORMAT_ELF)
1191    r = ocGetNames_ELF ( oc );
1192 #  elif defined(OBJFORMAT_PEi386)
1193    r = ocGetNames_PEi386 ( oc );
1194 #  elif defined(OBJFORMAT_MACHO)
1195    r = ocGetNames_MachO ( oc );
1196 #  else
1197    barf("loadObj: no getNames method");
1198 #  endif
1199    if (!r) { return r; }
1200
1201    /* loaded, but not resolved yet */
1202    oc->status = OBJECT_LOADED;
1203
1204    return 1;
1205 }
1206
1207 /* -----------------------------------------------------------------------------
1208  * resolve all the currently unlinked objects in memory
1209  *
1210  * Returns: 1 if ok, 0 on error.
1211  */
1212 HsInt
1213 resolveObjs( void )
1214 {
1215     ObjectCode *oc;
1216     int r;
1217
1218     initLinker();
1219
1220     for (oc = objects; oc; oc = oc->next) {
1221         if (oc->status != OBJECT_RESOLVED) {
1222 #           if defined(OBJFORMAT_ELF)
1223             r = ocResolve_ELF ( oc );
1224 #           elif defined(OBJFORMAT_PEi386)
1225             r = ocResolve_PEi386 ( oc );
1226 #           elif defined(OBJFORMAT_MACHO)
1227             r = ocResolve_MachO ( oc );
1228 #           else
1229             barf("resolveObjs: not implemented on this platform");
1230 #           endif
1231             if (!r) { return r; }
1232             oc->status = OBJECT_RESOLVED;
1233         }
1234     }
1235     return 1;
1236 }
1237
1238 /* -----------------------------------------------------------------------------
1239  * delete an object from the pool
1240  */
1241 HsInt
1242 unloadObj( char *path )
1243 {
1244     ObjectCode *oc, *prev;
1245
1246     ASSERT(symhash != NULL);
1247     ASSERT(objects != NULL);
1248
1249     initLinker();
1250
1251     prev = NULL;
1252     for (oc = objects; oc; prev = oc, oc = oc->next) {
1253         if (!strcmp(oc->fileName,path)) {
1254
1255             /* Remove all the mappings for the symbols within this
1256              * object..
1257              */
1258             {
1259                 int i;
1260                 for (i = 0; i < oc->n_symbols; i++) {
1261                    if (oc->symbols[i] != NULL) {
1262                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1263                    }
1264                 }
1265             }
1266
1267             if (prev == NULL) {
1268                 objects = oc->next;
1269             } else {
1270                 prev->next = oc->next;
1271             }
1272
1273             /* We're going to leave this in place, in case there are
1274                any pointers from the heap into it: */
1275             /* stgFree(oc->image); */
1276             stgFree(oc->fileName);
1277             stgFree(oc->symbols);
1278             stgFree(oc->sections);
1279             /* The local hash table should have been freed at the end
1280                of the ocResolve_ call on it. */
1281             ASSERT(oc->lochash == NULL);
1282             stgFree(oc);
1283             return 1;
1284         }
1285     }
1286
1287     errorBelch("unloadObj: can't find `%s' to unload", path);
1288     return 0;
1289 }
1290
1291 /* -----------------------------------------------------------------------------
1292  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1293  * which may be prodded during relocation, and abort if we try and write
1294  * outside any of these.
1295  */
1296 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1297 {
1298    ProddableBlock* pb
1299       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1300    /* debugBelch("aPB %p %p %d\n", oc, start, size); */
1301    ASSERT(size > 0);
1302    pb->start      = start;
1303    pb->size       = size;
1304    pb->next       = oc->proddables;
1305    oc->proddables = pb;
1306 }
1307
1308 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1309 {
1310    ProddableBlock* pb;
1311    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1312       char* s = (char*)(pb->start);
1313       char* e = s + pb->size - 1;
1314       char* a = (char*)addr;
1315       /* Assumes that the biggest fixup involves a 4-byte write.  This
1316          probably needs to be changed to 8 (ie, +7) on 64-bit
1317          plats. */
1318       if (a >= s && (a+3) <= e) return;
1319    }
1320    barf("checkProddableBlock: invalid fixup in runtime linker");
1321 }
1322
1323 /* -----------------------------------------------------------------------------
1324  * Section management.
1325  */
1326 static void addSection ( ObjectCode* oc, SectionKind kind,
1327                          void* start, void* end )
1328 {
1329    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1330    s->start     = start;
1331    s->end       = end;
1332    s->kind      = kind;
1333    s->next      = oc->sections;
1334    oc->sections = s;
1335    /*
1336    debugBelch("addSection: %p-%p (size %d), kind %d\n",
1337                    start, ((char*)end)-1, end - start + 1, kind );
1338    */
1339 }
1340
1341
1342 /* --------------------------------------------------------------------------
1343  * PowerPC specifics (jump islands)
1344  * ------------------------------------------------------------------------*/
1345
1346 #if defined(powerpc_HOST_ARCH)
1347
1348 /*
1349   ocAllocateJumpIslands
1350
1351   Allocate additional space at the end of the object file image to make room
1352   for jump islands.
1353
1354   PowerPC relative branch instructions have a 24 bit displacement field.
1355   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
1356   If a particular imported symbol is outside this range, we have to redirect
1357   the jump to a short piece of new code that just loads the 32bit absolute
1358   address and jumps there.
1359   This function just allocates space for one 16 byte ppcJumpIsland for every
1360   undefined symbol in the object file. The code for the islands is filled in by
1361   makeJumpIsland below.
1362 */
1363
1364 static int ocAllocateJumpIslands( ObjectCode* oc, int count, int first )
1365 {
1366 #ifdef USE_MMAP
1367   int pagesize, n, m;
1368 #endif
1369   int aligned;
1370
1371   if( count > 0 )
1372   {
1373     // round up to the nearest 4
1374     aligned = (oc->fileSize + 3) & ~3;
1375
1376 #ifdef USE_MMAP
1377     #ifndef linux_HOST_OS /* mremap is a linux extension */
1378         #error ocAllocateJumpIslands doesnt want USE_MMAP to be defined
1379     #endif
1380
1381     pagesize = getpagesize();
1382     n = ROUND_UP( oc->fileSize, pagesize );
1383     m = ROUND_UP( aligned + sizeof (ppcJumpIsland) * count, pagesize );
1384
1385     /* The effect of this mremap() call is only the ensure that we have
1386      * a sufficient number of virtually contiguous pages.  As returned from
1387      * mremap, the pages past the end of the file are not backed.  We give
1388      * them a backing by using MAP_FIXED to map in anonymous pages.
1389      */
1390     if( (oc->image = mremap( oc->image, n, m, MREMAP_MAYMOVE )) == MAP_FAILED )
1391     {
1392       errorBelch( "Unable to mremap for Jump Islands\n" );
1393       return 0;
1394     }
1395
1396     if( mmap( oc->image + n, m - n, PROT_READ | PROT_WRITE | PROT_EXEC,
1397               MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, 0, 0 ) == MAP_FAILED )
1398     {
1399       errorBelch( "Unable to mmap( MAP_FIXED ) for Jump Islands\n" );
1400       return 0;
1401     }
1402
1403 #else
1404     oc->image = stgReallocBytes( oc->image,
1405                                  aligned + sizeof (ppcJumpIsland) * count,
1406                                  "ocAllocateJumpIslands" );
1407 #endif /* USE_MMAP */
1408
1409     oc->jump_islands = (ppcJumpIsland *) (oc->image + aligned);
1410     memset( oc->jump_islands, 0, sizeof (ppcJumpIsland) * count );
1411   }
1412   else
1413     oc->jump_islands = NULL;
1414
1415   oc->island_start_symbol = first;
1416   oc->n_islands = count;
1417
1418   return 1;
1419 }
1420
1421 static unsigned long makeJumpIsland( ObjectCode* oc,
1422                                      unsigned long symbolNumber,
1423                                      unsigned long target )
1424 {
1425   ppcJumpIsland *island;
1426
1427   if( symbolNumber < oc->island_start_symbol ||
1428       symbolNumber - oc->island_start_symbol > oc->n_islands)
1429     return 0;
1430
1431   island = &oc->jump_islands[symbolNumber - oc->island_start_symbol];
1432
1433   // lis r12, hi16(target)
1434   island->lis_r12     = 0x3d80;
1435   island->hi_addr     = target >> 16;
1436
1437   // ori r12, r12, lo16(target)
1438   island->ori_r12_r12 = 0x618c;
1439   island->lo_addr     = target & 0xffff;
1440
1441   // mtctr r12
1442   island->mtctr_r12   = 0x7d8903a6;
1443
1444   // bctr
1445   island->bctr        = 0x4e800420;
1446
1447   return (unsigned long) island;
1448 }
1449
1450 /*
1451    ocFlushInstructionCache
1452
1453    Flush the data & instruction caches.
1454    Because the PPC has split data/instruction caches, we have to
1455    do that whenever we modify code at runtime.
1456  */
1457
1458 static void ocFlushInstructionCache( ObjectCode *oc )
1459 {
1460     int n = (oc->fileSize + sizeof( ppcJumpIsland ) * oc->n_islands + 3) / 4;
1461     unsigned long *p = (unsigned long *) oc->image;
1462
1463     while( n-- )
1464     {
1465         __asm__ volatile ( "dcbf 0,%0\n\t"
1466                            "sync\n\t"
1467                            "icbi 0,%0"
1468                            :
1469                            : "r" (p)
1470                          );
1471         p++;
1472     }
1473     __asm__ volatile ( "sync\n\t"
1474                        "isync"
1475                      );
1476 }
1477 #endif
1478
1479 /* --------------------------------------------------------------------------
1480  * PEi386 specifics (Win32 targets)
1481  * ------------------------------------------------------------------------*/
1482
1483 /* The information for this linker comes from
1484       Microsoft Portable Executable
1485       and Common Object File Format Specification
1486       revision 5.1 January 1998
1487    which SimonM says comes from the MS Developer Network CDs.
1488
1489    It can be found there (on older CDs), but can also be found
1490    online at:
1491
1492       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1493
1494    (this is Rev 6.0 from February 1999).
1495
1496    Things move, so if that fails, try searching for it via
1497
1498       http://www.google.com/search?q=PE+COFF+specification
1499
1500    The ultimate reference for the PE format is the Winnt.h
1501    header file that comes with the Platform SDKs; as always,
1502    implementations will drift wrt their documentation.
1503
1504    A good background article on the PE format is Matt Pietrek's
1505    March 1994 article in Microsoft System Journal (MSJ)
1506    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1507    Win32 Portable Executable File Format." The info in there
1508    has recently been updated in a two part article in
1509    MSDN magazine, issues Feb and March 2002,
1510    "Inside Windows: An In-Depth Look into the Win32 Portable
1511    Executable File Format"
1512
1513    John Levine's book "Linkers and Loaders" contains useful
1514    info on PE too.
1515 */
1516
1517
1518 #if defined(OBJFORMAT_PEi386)
1519
1520
1521
1522 typedef unsigned char  UChar;
1523 typedef unsigned short UInt16;
1524 typedef unsigned int   UInt32;
1525 typedef          int   Int32;
1526
1527
1528 typedef
1529    struct {
1530       UInt16 Machine;
1531       UInt16 NumberOfSections;
1532       UInt32 TimeDateStamp;
1533       UInt32 PointerToSymbolTable;
1534       UInt32 NumberOfSymbols;
1535       UInt16 SizeOfOptionalHeader;
1536       UInt16 Characteristics;
1537    }
1538    COFF_header;
1539
1540 #define sizeof_COFF_header 20
1541
1542
1543 typedef
1544    struct {
1545       UChar  Name[8];
1546       UInt32 VirtualSize;
1547       UInt32 VirtualAddress;
1548       UInt32 SizeOfRawData;
1549       UInt32 PointerToRawData;
1550       UInt32 PointerToRelocations;
1551       UInt32 PointerToLinenumbers;
1552       UInt16 NumberOfRelocations;
1553       UInt16 NumberOfLineNumbers;
1554       UInt32 Characteristics;
1555    }
1556    COFF_section;
1557
1558 #define sizeof_COFF_section 40
1559
1560
1561 typedef
1562    struct {
1563       UChar  Name[8];
1564       UInt32 Value;
1565       UInt16 SectionNumber;
1566       UInt16 Type;
1567       UChar  StorageClass;
1568       UChar  NumberOfAuxSymbols;
1569    }
1570    COFF_symbol;
1571
1572 #define sizeof_COFF_symbol 18
1573
1574
1575 typedef
1576    struct {
1577       UInt32 VirtualAddress;
1578       UInt32 SymbolTableIndex;
1579       UInt16 Type;
1580    }
1581    COFF_reloc;
1582
1583 #define sizeof_COFF_reloc 10
1584
1585
1586 /* From PE spec doc, section 3.3.2 */
1587 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1588    windows.h -- for the same purpose, but I want to know what I'm
1589    getting, here. */
1590 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1591 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1592 #define MYIMAGE_FILE_DLL                 0x2000
1593 #define MYIMAGE_FILE_SYSTEM              0x1000
1594 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1595 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1596 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1597
1598 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1599 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1600 #define MYIMAGE_SYM_CLASS_STATIC         3
1601 #define MYIMAGE_SYM_UNDEFINED            0
1602
1603 /* From PE spec doc, section 4.1 */
1604 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1605 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1606 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1607
1608 /* From PE spec doc, section 5.2.1 */
1609 #define MYIMAGE_REL_I386_DIR32           0x0006
1610 #define MYIMAGE_REL_I386_REL32           0x0014
1611
1612
1613 /* We use myindex to calculate array addresses, rather than
1614    simply doing the normal subscript thing.  That's because
1615    some of the above structs have sizes which are not
1616    a whole number of words.  GCC rounds their sizes up to a
1617    whole number of words, which means that the address calcs
1618    arising from using normal C indexing or pointer arithmetic
1619    are just plain wrong.  Sigh.
1620 */
1621 static UChar *
1622 myindex ( int scale, void* base, int index )
1623 {
1624    return
1625       ((UChar*)base) + scale * index;
1626 }
1627
1628
1629 static void
1630 printName ( UChar* name, UChar* strtab )
1631 {
1632    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1633       UInt32 strtab_offset = * (UInt32*)(name+4);
1634       debugBelch("%s", strtab + strtab_offset );
1635    } else {
1636       int i;
1637       for (i = 0; i < 8; i++) {
1638          if (name[i] == 0) break;
1639          debugBelch("%c", name[i] );
1640       }
1641    }
1642 }
1643
1644
1645 static void
1646 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1647 {
1648    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1649       UInt32 strtab_offset = * (UInt32*)(name+4);
1650       strncpy ( dst, strtab+strtab_offset, dstSize );
1651       dst[dstSize-1] = 0;
1652    } else {
1653       int i = 0;
1654       while (1) {
1655          if (i >= 8) break;
1656          if (name[i] == 0) break;
1657          dst[i] = name[i];
1658          i++;
1659       }
1660       dst[i] = 0;
1661    }
1662 }
1663
1664
1665 static UChar *
1666 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1667 {
1668    UChar* newstr;
1669    /* If the string is longer than 8 bytes, look in the
1670       string table for it -- this will be correctly zero terminated.
1671    */
1672    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1673       UInt32 strtab_offset = * (UInt32*)(name+4);
1674       return ((UChar*)strtab) + strtab_offset;
1675    }
1676    /* Otherwise, if shorter than 8 bytes, return the original,
1677       which by defn is correctly terminated.
1678    */
1679    if (name[7]==0) return name;
1680    /* The annoying case: 8 bytes.  Copy into a temporary
1681       (which is never freed ...)
1682    */
1683    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1684    ASSERT(newstr);
1685    strncpy(newstr,name,8);
1686    newstr[8] = 0;
1687    return newstr;
1688 }
1689
1690
1691 /* Just compares the short names (first 8 chars) */
1692 static COFF_section *
1693 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1694 {
1695    int i;
1696    COFF_header* hdr
1697       = (COFF_header*)(oc->image);
1698    COFF_section* sectab
1699       = (COFF_section*) (
1700            ((UChar*)(oc->image))
1701            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1702         );
1703    for (i = 0; i < hdr->NumberOfSections; i++) {
1704       UChar* n1;
1705       UChar* n2;
1706       COFF_section* section_i
1707          = (COFF_section*)
1708            myindex ( sizeof_COFF_section, sectab, i );
1709       n1 = (UChar*) &(section_i->Name);
1710       n2 = name;
1711       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1712           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1713           n1[6]==n2[6] && n1[7]==n2[7])
1714          return section_i;
1715    }
1716
1717    return NULL;
1718 }
1719
1720
1721 static void
1722 zapTrailingAtSign ( UChar* sym )
1723 {
1724 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1725    int i, j;
1726    if (sym[0] == 0) return;
1727    i = 0;
1728    while (sym[i] != 0) i++;
1729    i--;
1730    j = i;
1731    while (j > 0 && my_isdigit(sym[j])) j--;
1732    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1733 #  undef my_isdigit
1734 }
1735
1736
1737 static int
1738 ocVerifyImage_PEi386 ( ObjectCode* oc )
1739 {
1740    int i;
1741    UInt32 j, noRelocs;
1742    COFF_header*  hdr;
1743    COFF_section* sectab;
1744    COFF_symbol*  symtab;
1745    UChar*        strtab;
1746    /* debugBelch("\nLOADING %s\n", oc->fileName); */
1747    hdr = (COFF_header*)(oc->image);
1748    sectab = (COFF_section*) (
1749                ((UChar*)(oc->image))
1750                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1751             );
1752    symtab = (COFF_symbol*) (
1753                ((UChar*)(oc->image))
1754                + hdr->PointerToSymbolTable
1755             );
1756    strtab = ((UChar*)symtab)
1757             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1758
1759    if (hdr->Machine != 0x14c) {
1760       errorBelch("%s: Not x86 PEi386", oc->fileName);
1761       return 0;
1762    }
1763    if (hdr->SizeOfOptionalHeader != 0) {
1764       errorBelch("%s: PEi386 with nonempty optional header", oc->fileName);
1765       return 0;
1766    }
1767    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1768         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1769         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1770         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1771       errorBelch("%s: Not a PEi386 object file", oc->fileName);
1772       return 0;
1773    }
1774    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1775         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1776       errorBelch("%s: Invalid PEi386 word size or endiannness: %d",
1777                  oc->fileName,
1778                  (int)(hdr->Characteristics));
1779       return 0;
1780    }
1781    /* If the string table size is way crazy, this might indicate that
1782       there are more than 64k relocations, despite claims to the
1783       contrary.  Hence this test. */
1784    /* debugBelch("strtab size %d\n", * (UInt32*)strtab); */
1785 #if 0
1786    if ( (*(UInt32*)strtab) > 600000 ) {
1787       /* Note that 600k has no special significance other than being
1788          big enough to handle the almost-2MB-sized lumps that
1789          constitute HSwin32*.o. */
1790       debugBelch("PEi386 object has suspiciously large string table; > 64k relocs?");
1791       return 0;
1792    }
1793 #endif
1794
1795    /* No further verification after this point; only debug printing. */
1796    i = 0;
1797    IF_DEBUG(linker, i=1);
1798    if (i == 0) return 1;
1799
1800    debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1801    debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1802    debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1803
1804    debugBelch("\n" );
1805    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1806    debugBelch( "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1807    debugBelch( "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1808    debugBelch( "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1809    debugBelch( "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1810    debugBelch( "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1811    debugBelch( "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1812
1813    /* Print the section table. */
1814    debugBelch("\n" );
1815    for (i = 0; i < hdr->NumberOfSections; i++) {
1816       COFF_reloc* reltab;
1817       COFF_section* sectab_i
1818          = (COFF_section*)
1819            myindex ( sizeof_COFF_section, sectab, i );
1820       debugBelch(
1821                 "\n"
1822                 "section %d\n"
1823                 "     name `",
1824                 i
1825               );
1826       printName ( sectab_i->Name, strtab );
1827       debugBelch(
1828                 "'\n"
1829                 "    vsize %d\n"
1830                 "    vaddr %d\n"
1831                 "  data sz %d\n"
1832                 " data off %d\n"
1833                 "  num rel %d\n"
1834                 "  off rel %d\n"
1835                 "  ptr raw 0x%x\n",
1836                 sectab_i->VirtualSize,
1837                 sectab_i->VirtualAddress,
1838                 sectab_i->SizeOfRawData,
1839                 sectab_i->PointerToRawData,
1840                 sectab_i->NumberOfRelocations,
1841                 sectab_i->PointerToRelocations,
1842                 sectab_i->PointerToRawData
1843               );
1844       reltab = (COFF_reloc*) (
1845                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1846                );
1847
1848       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1849         /* If the relocation field (a short) has overflowed, the
1850          * real count can be found in the first reloc entry.
1851          *
1852          * See Section 4.1 (last para) of the PE spec (rev6.0).
1853          */
1854         COFF_reloc* rel = (COFF_reloc*)
1855                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1856         noRelocs = rel->VirtualAddress;
1857         j = 1;
1858       } else {
1859         noRelocs = sectab_i->NumberOfRelocations;
1860         j = 0;
1861       }
1862
1863       for (; j < noRelocs; j++) {
1864          COFF_symbol* sym;
1865          COFF_reloc* rel = (COFF_reloc*)
1866                            myindex ( sizeof_COFF_reloc, reltab, j );
1867          debugBelch(
1868                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1869                    (UInt32)rel->Type,
1870                    rel->VirtualAddress );
1871          sym = (COFF_symbol*)
1872                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1873          /* Hmm..mysterious looking offset - what's it for? SOF */
1874          printName ( sym->Name, strtab -10 );
1875          debugBelch("'\n" );
1876       }
1877
1878       debugBelch("\n" );
1879    }
1880    debugBelch("\n" );
1881    debugBelch("string table has size 0x%x\n", * (UInt32*)strtab );
1882    debugBelch("---START of string table---\n");
1883    for (i = 4; i < *(Int32*)strtab; i++) {
1884       if (strtab[i] == 0)
1885          debugBelch("\n"); else
1886          debugBelch("%c", strtab[i] );
1887    }
1888    debugBelch("--- END  of string table---\n");
1889
1890    debugBelch("\n" );
1891    i = 0;
1892    while (1) {
1893       COFF_symbol* symtab_i;
1894       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1895       symtab_i = (COFF_symbol*)
1896                  myindex ( sizeof_COFF_symbol, symtab, i );
1897       debugBelch(
1898                 "symbol %d\n"
1899                 "     name `",
1900                 i
1901               );
1902       printName ( symtab_i->Name, strtab );
1903       debugBelch(
1904                 "'\n"
1905                 "    value 0x%x\n"
1906                 "   1+sec# %d\n"
1907                 "     type 0x%x\n"
1908                 "   sclass 0x%x\n"
1909                 "     nAux %d\n",
1910                 symtab_i->Value,
1911                 (Int32)(symtab_i->SectionNumber),
1912                 (UInt32)symtab_i->Type,
1913                 (UInt32)symtab_i->StorageClass,
1914                 (UInt32)symtab_i->NumberOfAuxSymbols
1915               );
1916       i += symtab_i->NumberOfAuxSymbols;
1917       i++;
1918    }
1919
1920    debugBelch("\n" );
1921    return 1;
1922 }
1923
1924
1925 static int
1926 ocGetNames_PEi386 ( ObjectCode* oc )
1927 {
1928    COFF_header*  hdr;
1929    COFF_section* sectab;
1930    COFF_symbol*  symtab;
1931    UChar*        strtab;
1932
1933    UChar* sname;
1934    void*  addr;
1935    int    i;
1936
1937    hdr = (COFF_header*)(oc->image);
1938    sectab = (COFF_section*) (
1939                ((UChar*)(oc->image))
1940                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1941             );
1942    symtab = (COFF_symbol*) (
1943                ((UChar*)(oc->image))
1944                + hdr->PointerToSymbolTable
1945             );
1946    strtab = ((UChar*)(oc->image))
1947             + hdr->PointerToSymbolTable
1948             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1949
1950    /* Allocate space for any (local, anonymous) .bss sections. */
1951
1952    for (i = 0; i < hdr->NumberOfSections; i++) {
1953       UChar* zspace;
1954       COFF_section* sectab_i
1955          = (COFF_section*)
1956            myindex ( sizeof_COFF_section, sectab, i );
1957       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1958       if (sectab_i->VirtualSize == 0) continue;
1959       /* This is a non-empty .bss section.  Allocate zeroed space for
1960          it, and set its PointerToRawData field such that oc->image +
1961          PointerToRawData == addr_of_zeroed_space.  */
1962       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1963                               "ocGetNames_PEi386(anonymous bss)");
1964       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1965       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1966       /* debugBelch("BSS anon section at 0x%x\n", zspace); */
1967    }
1968
1969    /* Copy section information into the ObjectCode. */
1970
1971    for (i = 0; i < hdr->NumberOfSections; i++) {
1972       UChar* start;
1973       UChar* end;
1974       UInt32 sz;
1975
1976       SectionKind kind
1977          = SECTIONKIND_OTHER;
1978       COFF_section* sectab_i
1979          = (COFF_section*)
1980            myindex ( sizeof_COFF_section, sectab, i );
1981       IF_DEBUG(linker, debugBelch("section name = %s\n", sectab_i->Name ));
1982
1983 #     if 0
1984       /* I'm sure this is the Right Way to do it.  However, the
1985          alternative of testing the sectab_i->Name field seems to
1986          work ok with Cygwin.
1987       */
1988       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1989           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1990          kind = SECTIONKIND_CODE_OR_RODATA;
1991 #     endif
1992
1993       if (0==strcmp(".text",sectab_i->Name) ||
1994           0==strcmp(".rdata",sectab_i->Name)||
1995           0==strcmp(".rodata",sectab_i->Name))
1996          kind = SECTIONKIND_CODE_OR_RODATA;
1997       if (0==strcmp(".data",sectab_i->Name) ||
1998           0==strcmp(".bss",sectab_i->Name))
1999          kind = SECTIONKIND_RWDATA;
2000
2001       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
2002       sz = sectab_i->SizeOfRawData;
2003       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
2004
2005       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
2006       end   = start + sz - 1;
2007
2008       if (kind == SECTIONKIND_OTHER
2009           /* Ignore sections called which contain stabs debugging
2010              information. */
2011           && 0 != strcmp(".stab", sectab_i->Name)
2012           && 0 != strcmp(".stabstr", sectab_i->Name)
2013           /* ignore constructor section for now */
2014           && 0 != strcmp(".ctors", sectab_i->Name)
2015          ) {
2016          errorBelch("Unknown PEi386 section name `%s' (while processing: %s)", sectab_i->Name, oc->fileName);
2017          return 0;
2018       }
2019
2020       if (kind != SECTIONKIND_OTHER && end >= start) {
2021          addSection(oc, kind, start, end);
2022          addProddableBlock(oc, start, end - start + 1);
2023       }
2024    }
2025
2026    /* Copy exported symbols into the ObjectCode. */
2027
2028    oc->n_symbols = hdr->NumberOfSymbols;
2029    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
2030                                   "ocGetNames_PEi386(oc->symbols)");
2031    /* Call me paranoid; I don't care. */
2032    for (i = 0; i < oc->n_symbols; i++)
2033       oc->symbols[i] = NULL;
2034
2035    i = 0;
2036    while (1) {
2037       COFF_symbol* symtab_i;
2038       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
2039       symtab_i = (COFF_symbol*)
2040                  myindex ( sizeof_COFF_symbol, symtab, i );
2041
2042       addr  = NULL;
2043
2044       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
2045           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
2046          /* This symbol is global and defined, viz, exported */
2047          /* for MYIMAGE_SYMCLASS_EXTERNAL
2048                 && !MYIMAGE_SYM_UNDEFINED,
2049             the address of the symbol is:
2050                 address of relevant section + offset in section
2051          */
2052          COFF_section* sectabent
2053             = (COFF_section*) myindex ( sizeof_COFF_section,
2054                                         sectab,
2055                                         symtab_i->SectionNumber-1 );
2056          addr = ((UChar*)(oc->image))
2057                 + (sectabent->PointerToRawData
2058                    + symtab_i->Value);
2059       }
2060       else
2061       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
2062           && symtab_i->Value > 0) {
2063          /* This symbol isn't in any section at all, ie, global bss.
2064             Allocate zeroed space for it. */
2065          addr = stgCallocBytes(1, symtab_i->Value,
2066                                "ocGetNames_PEi386(non-anonymous bss)");
2067          addSection(oc, SECTIONKIND_RWDATA, addr,
2068                         ((UChar*)addr) + symtab_i->Value - 1);
2069          addProddableBlock(oc, addr, symtab_i->Value);
2070          /* debugBelch("BSS      section at 0x%x\n", addr); */
2071       }
2072
2073       if (addr != NULL ) {
2074          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
2075          /* debugBelch("addSymbol %p `%s \n", addr,sname);  */
2076          IF_DEBUG(linker, debugBelch("addSymbol %p `%s'\n", addr,sname);)
2077          ASSERT(i >= 0 && i < oc->n_symbols);
2078          /* cstring_from_COFF_symbol_name always succeeds. */
2079          oc->symbols[i] = sname;
2080          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
2081       } else {
2082 #        if 0
2083          debugBelch(
2084                    "IGNORING symbol %d\n"
2085                    "     name `",
2086                    i
2087                  );
2088          printName ( symtab_i->Name, strtab );
2089          debugBelch(
2090                    "'\n"
2091                    "    value 0x%x\n"
2092                    "   1+sec# %d\n"
2093                    "     type 0x%x\n"
2094                    "   sclass 0x%x\n"
2095                    "     nAux %d\n",
2096                    symtab_i->Value,
2097                    (Int32)(symtab_i->SectionNumber),
2098                    (UInt32)symtab_i->Type,
2099                    (UInt32)symtab_i->StorageClass,
2100                    (UInt32)symtab_i->NumberOfAuxSymbols
2101                  );
2102 #        endif
2103       }
2104
2105       i += symtab_i->NumberOfAuxSymbols;
2106       i++;
2107    }
2108
2109    return 1;
2110 }
2111
2112
2113 static int
2114 ocResolve_PEi386 ( ObjectCode* oc )
2115 {
2116    COFF_header*  hdr;
2117    COFF_section* sectab;
2118    COFF_symbol*  symtab;
2119    UChar*        strtab;
2120
2121    UInt32        A;
2122    UInt32        S;
2123    UInt32*       pP;
2124
2125    int i;
2126    UInt32 j, noRelocs;
2127
2128    /* ToDo: should be variable-sized?  But is at least safe in the
2129       sense of buffer-overrun-proof. */
2130    char symbol[1000];
2131    /* debugBelch("resolving for %s\n", oc->fileName); */
2132
2133    hdr = (COFF_header*)(oc->image);
2134    sectab = (COFF_section*) (
2135                ((UChar*)(oc->image))
2136                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
2137             );
2138    symtab = (COFF_symbol*) (
2139                ((UChar*)(oc->image))
2140                + hdr->PointerToSymbolTable
2141             );
2142    strtab = ((UChar*)(oc->image))
2143             + hdr->PointerToSymbolTable
2144             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
2145
2146    for (i = 0; i < hdr->NumberOfSections; i++) {
2147       COFF_section* sectab_i
2148          = (COFF_section*)
2149            myindex ( sizeof_COFF_section, sectab, i );
2150       COFF_reloc* reltab
2151          = (COFF_reloc*) (
2152               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
2153            );
2154
2155       /* Ignore sections called which contain stabs debugging
2156          information. */
2157       if (0 == strcmp(".stab", sectab_i->Name)
2158           || 0 == strcmp(".stabstr", sectab_i->Name)
2159           || 0 == strcmp(".ctors", sectab_i->Name))
2160          continue;
2161
2162       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
2163         /* If the relocation field (a short) has overflowed, the
2164          * real count can be found in the first reloc entry.
2165          *
2166          * See Section 4.1 (last para) of the PE spec (rev6.0).
2167          *
2168          * Nov2003 update: the GNU linker still doesn't correctly
2169          * handle the generation of relocatable object files with
2170          * overflown relocations. Hence the output to warn of potential
2171          * troubles.
2172          */
2173         COFF_reloc* rel = (COFF_reloc*)
2174                            myindex ( sizeof_COFF_reloc, reltab, 0 );
2175         noRelocs = rel->VirtualAddress;
2176         debugBelch("WARNING: Overflown relocation field (# relocs found: %u)\n",
2177                    noRelocs);
2178         j = 1;
2179       } else {
2180         noRelocs = sectab_i->NumberOfRelocations;
2181         j = 0;
2182       }
2183
2184
2185       for (; j < noRelocs; j++) {
2186          COFF_symbol* sym;
2187          COFF_reloc* reltab_j
2188             = (COFF_reloc*)
2189               myindex ( sizeof_COFF_reloc, reltab, j );
2190
2191          /* the location to patch */
2192          pP = (UInt32*)(
2193                  ((UChar*)(oc->image))
2194                  + (sectab_i->PointerToRawData
2195                     + reltab_j->VirtualAddress
2196                     - sectab_i->VirtualAddress )
2197               );
2198          /* the existing contents of pP */
2199          A = *pP;
2200          /* the symbol to connect to */
2201          sym = (COFF_symbol*)
2202                myindex ( sizeof_COFF_symbol,
2203                          symtab, reltab_j->SymbolTableIndex );
2204          IF_DEBUG(linker,
2205                   debugBelch(
2206                             "reloc sec %2d num %3d:  type 0x%-4x   "
2207                             "vaddr 0x%-8x   name `",
2208                             i, j,
2209                             (UInt32)reltab_j->Type,
2210                             reltab_j->VirtualAddress );
2211                             printName ( sym->Name, strtab );
2212                             debugBelch("'\n" ));
2213
2214          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
2215             COFF_section* section_sym
2216                = findPEi386SectionCalled ( oc, sym->Name );
2217             if (!section_sym) {
2218                errorBelch("%s: can't find section `%s'", oc->fileName, sym->Name);
2219                return 0;
2220             }
2221             S = ((UInt32)(oc->image))
2222                 + (section_sym->PointerToRawData
2223                    + sym->Value);
2224          } else {
2225             copyName ( sym->Name, strtab, symbol, 1000-1 );
2226             (void*)S = lookupLocalSymbol( oc, symbol );
2227             if ((void*)S != NULL) goto foundit;
2228             (void*)S = lookupSymbol( symbol );
2229             if ((void*)S != NULL) goto foundit;
2230             zapTrailingAtSign ( symbol );
2231             (void*)S = lookupLocalSymbol( oc, symbol );
2232             if ((void*)S != NULL) goto foundit;
2233             (void*)S = lookupSymbol( symbol );
2234             if ((void*)S != NULL) goto foundit;
2235             /* Newline first because the interactive linker has printed "linking..." */
2236             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2237             return 0;
2238            foundit:;
2239          }
2240          checkProddableBlock(oc, pP);
2241          switch (reltab_j->Type) {
2242             case MYIMAGE_REL_I386_DIR32:
2243                *pP = A + S;
2244                break;
2245             case MYIMAGE_REL_I386_REL32:
2246                /* Tricky.  We have to insert a displacement at
2247                   pP which, when added to the PC for the _next_
2248                   insn, gives the address of the target (S).
2249                   Problem is to know the address of the next insn
2250                   when we only know pP.  We assume that this
2251                   literal field is always the last in the insn,
2252                   so that the address of the next insn is pP+4
2253                   -- hence the constant 4.
2254                   Also I don't know if A should be added, but so
2255                   far it has always been zero.
2256
2257                   SOF 05/2005: 'A' (old contents of *pP) have been observed
2258                   to contain values other than zero (the 'wx' object file
2259                   that came with wxhaskell-0.9.4; dunno how it was compiled..).
2260                   So, add displacement to old value instead of asserting
2261                   A to be zero. Fixes wxhaskell-related crashes, and no other
2262                   ill effects have been observed.
2263
2264                   Update: the reason why we're seeing these more elaborate
2265                   relocations is due to a switch in how the NCG compiles SRTs
2266                   and offsets to them from info tables. SRTs live in .(ro)data,
2267                   while info tables live in .text, causing GAS to emit REL32/DISP32
2268                   relocations with non-zero values. Adding the displacement is
2269                   the right thing to do.
2270                */
2271                *pP = S - ((UInt32)pP) - 4 + A;
2272                break;
2273             default:
2274                debugBelch("%s: unhandled PEi386 relocation type %d",
2275                      oc->fileName, reltab_j->Type);
2276                return 0;
2277          }
2278
2279       }
2280    }
2281
2282    IF_DEBUG(linker, debugBelch("completed %s", oc->fileName));
2283    return 1;
2284 }
2285
2286 #endif /* defined(OBJFORMAT_PEi386) */
2287
2288
2289 /* --------------------------------------------------------------------------
2290  * ELF specifics
2291  * ------------------------------------------------------------------------*/
2292
2293 #if defined(OBJFORMAT_ELF)
2294
2295 #define FALSE 0
2296 #define TRUE  1
2297
2298 #if defined(sparc_HOST_ARCH)
2299 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2300 #elif defined(i386_HOST_ARCH)
2301 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2302 #elif defined(x86_64_HOST_ARCH)
2303 #  define ELF_TARGET_X64_64
2304 #  define ELF_64BIT
2305 #elif defined (ia64_HOST_ARCH)
2306 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2307 #  define ELF_64BIT
2308 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2309 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2310 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2311 #endif
2312
2313 #if !defined(openbsd_HOST_OS)
2314 #include <elf.h>
2315 #else
2316 /* openbsd elf has things in different places, with diff names */
2317 #include <elf_abi.h>
2318 #include <machine/reloc.h>
2319 #define R_386_32    RELOC_32
2320 #define R_386_PC32  RELOC_PC32
2321 #endif
2322
2323 /*
2324  * Define a set of types which can be used for both ELF32 and ELF64
2325  */
2326
2327 #ifdef ELF_64BIT
2328 #define ELFCLASS    ELFCLASS64
2329 #define Elf_Addr    Elf64_Addr
2330 #define Elf_Word    Elf64_Word
2331 #define Elf_Sword   Elf64_Sword
2332 #define Elf_Ehdr    Elf64_Ehdr
2333 #define Elf_Phdr    Elf64_Phdr
2334 #define Elf_Shdr    Elf64_Shdr
2335 #define Elf_Sym     Elf64_Sym
2336 #define Elf_Rel     Elf64_Rel
2337 #define Elf_Rela    Elf64_Rela
2338 #define ELF_ST_TYPE ELF64_ST_TYPE
2339 #define ELF_ST_BIND ELF64_ST_BIND
2340 #define ELF_R_TYPE  ELF64_R_TYPE
2341 #define ELF_R_SYM   ELF64_R_SYM
2342 #else
2343 #define ELFCLASS    ELFCLASS32
2344 #define Elf_Addr    Elf32_Addr
2345 #define Elf_Word    Elf32_Word
2346 #define Elf_Sword   Elf32_Sword
2347 #define Elf_Ehdr    Elf32_Ehdr
2348 #define Elf_Phdr    Elf32_Phdr
2349 #define Elf_Shdr    Elf32_Shdr
2350 #define Elf_Sym     Elf32_Sym
2351 #define Elf_Rel     Elf32_Rel
2352 #define Elf_Rela    Elf32_Rela
2353 #ifndef ELF_ST_TYPE
2354 #define ELF_ST_TYPE ELF32_ST_TYPE
2355 #endif
2356 #ifndef ELF_ST_BIND
2357 #define ELF_ST_BIND ELF32_ST_BIND
2358 #endif
2359 #ifndef ELF_R_TYPE
2360 #define ELF_R_TYPE  ELF32_R_TYPE
2361 #endif
2362 #ifndef ELF_R_SYM
2363 #define ELF_R_SYM   ELF32_R_SYM
2364 #endif
2365 #endif
2366
2367
2368 /*
2369  * Functions to allocate entries in dynamic sections.  Currently we simply
2370  * preallocate a large number, and we don't check if a entry for the given
2371  * target already exists (a linear search is too slow).  Ideally these
2372  * entries would be associated with symbols.
2373  */
2374
2375 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2376 #define GOT_SIZE            0x20000
2377 #define FUNCTION_TABLE_SIZE 0x10000
2378 #define PLT_SIZE            0x08000
2379
2380 #ifdef ELF_NEED_GOT
2381 static Elf_Addr got[GOT_SIZE];
2382 static unsigned int gotIndex;
2383 static Elf_Addr gp_val = (Elf_Addr)got;
2384
2385 static Elf_Addr
2386 allocateGOTEntry(Elf_Addr target)
2387 {
2388    Elf_Addr *entry;
2389
2390    if (gotIndex >= GOT_SIZE)
2391       barf("Global offset table overflow");
2392
2393    entry = &got[gotIndex++];
2394    *entry = target;
2395    return (Elf_Addr)entry;
2396 }
2397 #endif
2398
2399 #ifdef ELF_FUNCTION_DESC
2400 typedef struct {
2401    Elf_Addr ip;
2402    Elf_Addr gp;
2403 } FunctionDesc;
2404
2405 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2406 static unsigned int functionTableIndex;
2407
2408 static Elf_Addr
2409 allocateFunctionDesc(Elf_Addr target)
2410 {
2411    FunctionDesc *entry;
2412
2413    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2414       barf("Function table overflow");
2415
2416    entry = &functionTable[functionTableIndex++];
2417    entry->ip = target;
2418    entry->gp = (Elf_Addr)gp_val;
2419    return (Elf_Addr)entry;
2420 }
2421
2422 static Elf_Addr
2423 copyFunctionDesc(Elf_Addr target)
2424 {
2425    FunctionDesc *olddesc = (FunctionDesc *)target;
2426    FunctionDesc *newdesc;
2427
2428    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2429    newdesc->gp = olddesc->gp;
2430    return (Elf_Addr)newdesc;
2431 }
2432 #endif
2433
2434 #ifdef ELF_NEED_PLT
2435 #ifdef ia64_HOST_ARCH
2436 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2437 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2438
2439 static unsigned char plt_code[] =
2440 {
2441    /* taken from binutils bfd/elfxx-ia64.c */
2442    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2443    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2444    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2445    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2446    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2447    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2448 };
2449
2450 /* If we can't get to the function descriptor via gp, take a local copy of it */
2451 #define PLT_RELOC(code, target) { \
2452    Elf64_Sxword rel_value = target - gp_val; \
2453    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2454       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2455    else \
2456       ia64_reloc_gprel22((Elf_Addr)code, target); \
2457    }
2458 #endif
2459
2460 typedef struct {
2461    unsigned char code[sizeof(plt_code)];
2462 } PLTEntry;
2463
2464 static Elf_Addr
2465 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2466 {
2467    PLTEntry *plt = (PLTEntry *)oc->plt;
2468    PLTEntry *entry;
2469
2470    if (oc->pltIndex >= PLT_SIZE)
2471       barf("Procedure table overflow");
2472
2473    entry = &plt[oc->pltIndex++];
2474    memcpy(entry->code, plt_code, sizeof(entry->code));
2475    PLT_RELOC(entry->code, target);
2476    return (Elf_Addr)entry;
2477 }
2478
2479 static unsigned int
2480 PLTSize(void)
2481 {
2482    return (PLT_SIZE * sizeof(PLTEntry));
2483 }
2484 #endif
2485
2486
2487 /*
2488  * Generic ELF functions
2489  */
2490
2491 static char *
2492 findElfSection ( void* objImage, Elf_Word sh_type )
2493 {
2494    char* ehdrC = (char*)objImage;
2495    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2496    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2497    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2498    char* ptr = NULL;
2499    int i;
2500
2501    for (i = 0; i < ehdr->e_shnum; i++) {
2502       if (shdr[i].sh_type == sh_type
2503           /* Ignore the section header's string table. */
2504           && i != ehdr->e_shstrndx
2505           /* Ignore string tables named .stabstr, as they contain
2506              debugging info. */
2507           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2508          ) {
2509          ptr = ehdrC + shdr[i].sh_offset;
2510          break;
2511       }
2512    }
2513    return ptr;
2514 }
2515
2516 #if defined(ia64_HOST_ARCH)
2517 static Elf_Addr
2518 findElfSegment ( void* objImage, Elf_Addr vaddr )
2519 {
2520    char* ehdrC = (char*)objImage;
2521    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2522    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2523    Elf_Addr segaddr = 0;
2524    int i;
2525
2526    for (i = 0; i < ehdr->e_phnum; i++) {
2527       segaddr = phdr[i].p_vaddr;
2528       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2529               break;
2530    }
2531    return segaddr;
2532 }
2533 #endif
2534
2535 static int
2536 ocVerifyImage_ELF ( ObjectCode* oc )
2537 {
2538    Elf_Shdr* shdr;
2539    Elf_Sym*  stab;
2540    int i, j, nent, nstrtab, nsymtabs;
2541    char* sh_strtab;
2542    char* strtab;
2543
2544    char*     ehdrC = (char*)(oc->image);
2545    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2546
2547    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2548        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2549        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2550        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2551       errorBelch("%s: not an ELF object", oc->fileName);
2552       return 0;
2553    }
2554
2555    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2556       errorBelch("%s: unsupported ELF format", oc->fileName);
2557       return 0;
2558    }
2559
2560    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2561        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2562    } else
2563    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2564        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2565    } else {
2566        errorBelch("%s: unknown endiannness", oc->fileName);
2567        return 0;
2568    }
2569
2570    if (ehdr->e_type != ET_REL) {
2571       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2572       return 0;
2573    }
2574    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2575
2576    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2577    switch (ehdr->e_machine) {
2578       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2579       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2580 #ifdef EM_IA_64
2581       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2582 #endif
2583       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2584 #ifdef EM_X86_64
2585       case EM_X86_64: IF_DEBUG(linker,debugBelch( "x86_64" )); break;
2586 #endif
2587       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2588                      errorBelch("%s: unknown architecture", oc->fileName);
2589                      return 0;
2590    }
2591
2592    IF_DEBUG(linker,debugBelch(
2593              "\nSection header table: start %d, n_entries %d, ent_size %d\n",
2594              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2595
2596    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2597
2598    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2599
2600    if (ehdr->e_shstrndx == SHN_UNDEF) {
2601       errorBelch("%s: no section header string table", oc->fileName);
2602       return 0;
2603    } else {
2604       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2605                           ehdr->e_shstrndx));
2606       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2607    }
2608
2609    for (i = 0; i < ehdr->e_shnum; i++) {
2610       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
2611       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
2612       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
2613       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
2614       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
2615                ehdrC + shdr[i].sh_offset,
2616                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2617
2618       if (shdr[i].sh_type == SHT_REL) {
2619           IF_DEBUG(linker,debugBelch("Rel  " ));
2620       } else if (shdr[i].sh_type == SHT_RELA) {
2621           IF_DEBUG(linker,debugBelch("RelA " ));
2622       } else {
2623           IF_DEBUG(linker,debugBelch("     "));
2624       }
2625       if (sh_strtab) {
2626           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
2627       }
2628    }
2629
2630    IF_DEBUG(linker,debugBelch( "\nString tables" ));
2631    strtab = NULL;
2632    nstrtab = 0;
2633    for (i = 0; i < ehdr->e_shnum; i++) {
2634       if (shdr[i].sh_type == SHT_STRTAB
2635           /* Ignore the section header's string table. */
2636           && i != ehdr->e_shstrndx
2637           /* Ignore string tables named .stabstr, as they contain
2638              debugging info. */
2639           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2640          ) {
2641          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
2642          strtab = ehdrC + shdr[i].sh_offset;
2643          nstrtab++;
2644       }
2645    }
2646    if (nstrtab != 1) {
2647       errorBelch("%s: no string tables, or too many", oc->fileName);
2648       return 0;
2649    }
2650
2651    nsymtabs = 0;
2652    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
2653    for (i = 0; i < ehdr->e_shnum; i++) {
2654       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2655       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
2656       nsymtabs++;
2657       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2658       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2659       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%d rem)\n",
2660                nent,
2661                shdr[i].sh_size % sizeof(Elf_Sym)
2662              ));
2663       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2664          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
2665          return 0;
2666       }
2667       for (j = 0; j < nent; j++) {
2668          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
2669          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
2670                              (int)stab[j].st_shndx,
2671                              (int)stab[j].st_size,
2672                              (char*)stab[j].st_value ));
2673
2674          IF_DEBUG(linker,debugBelch("type=" ));
2675          switch (ELF_ST_TYPE(stab[j].st_info)) {
2676             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
2677             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
2678             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
2679             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
2680             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
2681             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
2682          }
2683          IF_DEBUG(linker,debugBelch("  " ));
2684
2685          IF_DEBUG(linker,debugBelch("bind=" ));
2686          switch (ELF_ST_BIND(stab[j].st_info)) {
2687             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
2688             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
2689             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
2690             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
2691          }
2692          IF_DEBUG(linker,debugBelch("  " ));
2693
2694          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
2695       }
2696    }
2697
2698    if (nsymtabs == 0) {
2699       errorBelch("%s: didn't find any symbol tables", oc->fileName);
2700       return 0;
2701    }
2702
2703    return 1;
2704 }
2705
2706 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
2707 {
2708     *is_bss = FALSE;
2709
2710     if (hdr->sh_type == SHT_PROGBITS
2711         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
2712         /* .text-style section */
2713         return SECTIONKIND_CODE_OR_RODATA;
2714     }
2715
2716     if (hdr->sh_type == SHT_PROGBITS
2717             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2718             /* .data-style section */
2719             return SECTIONKIND_RWDATA;
2720     }
2721
2722     if (hdr->sh_type == SHT_PROGBITS
2723         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
2724         /* .rodata-style section */
2725         return SECTIONKIND_CODE_OR_RODATA;
2726     }
2727
2728     if (hdr->sh_type == SHT_NOBITS
2729         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2730         /* .bss-style section */
2731         *is_bss = TRUE;
2732         return SECTIONKIND_RWDATA;
2733     }
2734
2735     return SECTIONKIND_OTHER;
2736 }
2737
2738
2739 static int
2740 ocGetNames_ELF ( ObjectCode* oc )
2741 {
2742    int i, j, k, nent;
2743    Elf_Sym* stab;
2744
2745    char*     ehdrC    = (char*)(oc->image);
2746    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2747    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2748    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2749
2750    ASSERT(symhash != NULL);
2751
2752    if (!strtab) {
2753       errorBelch("%s: no strtab", oc->fileName);
2754       return 0;
2755    }
2756
2757    k = 0;
2758    for (i = 0; i < ehdr->e_shnum; i++) {
2759       /* Figure out what kind of section it is.  Logic derived from
2760          Figure 1.14 ("Special Sections") of the ELF document
2761          ("Portable Formats Specification, Version 1.1"). */
2762       int         is_bss = FALSE;
2763       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
2764
2765       if (is_bss && shdr[i].sh_size > 0) {
2766          /* This is a non-empty .bss section.  Allocate zeroed space for
2767             it, and set its .sh_offset field such that
2768             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2769          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2770                                        "ocGetNames_ELF(BSS)");
2771          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2772          /*
2773          debugBelch("BSS section at 0x%x, size %d\n",
2774                          zspace, shdr[i].sh_size);
2775          */
2776       }
2777
2778       /* fill in the section info */
2779       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2780          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2781          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2782                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2783       }
2784
2785       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2786
2787       /* copy stuff into this module's object symbol table */
2788       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2789       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2790
2791       oc->n_symbols = nent;
2792       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2793                                    "ocGetNames_ELF(oc->symbols)");
2794
2795       for (j = 0; j < nent; j++) {
2796
2797          char  isLocal = FALSE; /* avoids uninit-var warning */
2798          char* ad      = NULL;
2799          char* nm      = strtab + stab[j].st_name;
2800          int   secno   = stab[j].st_shndx;
2801
2802          /* Figure out if we want to add it; if so, set ad to its
2803             address.  Otherwise leave ad == NULL. */
2804
2805          if (secno == SHN_COMMON) {
2806             isLocal = FALSE;
2807             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2808             /*
2809             debugBelch("COMMON symbol, size %d name %s\n",
2810                             stab[j].st_size, nm);
2811             */
2812             /* Pointless to do addProddableBlock() for this area,
2813                since the linker should never poke around in it. */
2814          }
2815          else
2816          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2817                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2818               )
2819               /* and not an undefined symbol */
2820               && stab[j].st_shndx != SHN_UNDEF
2821               /* and not in a "special section" */
2822               && stab[j].st_shndx < SHN_LORESERVE
2823               &&
2824               /* and it's a not a section or string table or anything silly */
2825               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2826                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2827                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2828               )
2829             ) {
2830             /* Section 0 is the undefined section, hence > and not >=. */
2831             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2832             /*
2833             if (shdr[secno].sh_type == SHT_NOBITS) {
2834                debugBelch("   BSS symbol, size %d off %d name %s\n",
2835                                stab[j].st_size, stab[j].st_value, nm);
2836             }
2837             */
2838             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2839             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2840                isLocal = TRUE;
2841             } else {
2842 #ifdef ELF_FUNCTION_DESC
2843                /* dlsym() and the initialisation table both give us function
2844                 * descriptors, so to be consistent we store function descriptors
2845                 * in the symbol table */
2846                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2847                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2848 #endif
2849                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s",
2850                                       ad, oc->fileName, nm ));
2851                isLocal = FALSE;
2852             }
2853          }
2854
2855          /* And the decision is ... */
2856
2857          if (ad != NULL) {
2858             ASSERT(nm != NULL);
2859             oc->symbols[j] = nm;
2860             /* Acquire! */
2861             if (isLocal) {
2862                /* Ignore entirely. */
2863             } else {
2864                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2865             }
2866          } else {
2867             /* Skip. */
2868             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
2869                                    strtab + stab[j].st_name ));
2870             /*
2871             debugBelch(
2872                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2873                     (int)ELF_ST_BIND(stab[j].st_info),
2874                     (int)ELF_ST_TYPE(stab[j].st_info),
2875                     (int)stab[j].st_shndx,
2876                     strtab + stab[j].st_name
2877                    );
2878             */
2879             oc->symbols[j] = NULL;
2880          }
2881
2882       }
2883    }
2884
2885    return 1;
2886 }
2887
2888 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2889    relocations appear to be of this form. */
2890 static int
2891 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2892                          Elf_Shdr* shdr, int shnum,
2893                          Elf_Sym*  stab, char* strtab )
2894 {
2895    int j;
2896    char *symbol;
2897    Elf_Word* targ;
2898    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
2899    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
2900    int target_shndx = shdr[shnum].sh_info;
2901    int symtab_shndx = shdr[shnum].sh_link;
2902
2903    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2904    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2905    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
2906                           target_shndx, symtab_shndx ));
2907
2908    /* Skip sections that we're not interested in. */
2909    {
2910        int is_bss;
2911        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
2912        if (kind == SECTIONKIND_OTHER) {
2913            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
2914            return 1;
2915        }
2916    }
2917
2918    for (j = 0; j < nent; j++) {
2919       Elf_Addr offset = rtab[j].r_offset;
2920       Elf_Addr info   = rtab[j].r_info;
2921
2922       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
2923       Elf_Word* pP = (Elf_Word*)P;
2924       Elf_Addr  A  = *pP;
2925       Elf_Addr  S;
2926       void*     S_tmp;
2927       Elf_Addr  value;
2928
2929       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
2930                              j, (void*)offset, (void*)info ));
2931       if (!info) {
2932          IF_DEBUG(linker,debugBelch( " ZERO" ));
2933          S = 0;
2934       } else {
2935          Elf_Sym sym = stab[ELF_R_SYM(info)];
2936          /* First see if it is a local symbol. */
2937          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2938             /* Yes, so we can get the address directly from the ELF symbol
2939                table. */
2940             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2941             S = (Elf_Addr)
2942                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2943                        + stab[ELF_R_SYM(info)].st_value);
2944
2945          } else {
2946             /* No, so look up the name in our global table. */
2947             symbol = strtab + sym.st_name;
2948             S_tmp = lookupSymbol( symbol );
2949             S = (Elf_Addr)S_tmp;
2950          }
2951          if (!S) {
2952             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
2953             return 0;
2954          }
2955          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
2956       }
2957
2958       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
2959                              (void*)P, (void*)S, (void*)A ));
2960       checkProddableBlock ( oc, pP );
2961
2962       value = S + A;
2963
2964       switch (ELF_R_TYPE(info)) {
2965 #        ifdef i386_HOST_ARCH
2966          case R_386_32:   *pP = value;     break;
2967          case R_386_PC32: *pP = value - P; break;
2968 #        endif
2969          default:
2970             errorBelch("%s: unhandled ELF relocation(Rel) type %d\n",
2971                   oc->fileName, ELF_R_TYPE(info));
2972             return 0;
2973       }
2974
2975    }
2976    return 1;
2977 }
2978
2979 /* Do ELF relocations for which explicit addends are supplied.
2980    sparc-solaris relocations appear to be of this form. */
2981 static int
2982 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2983                           Elf_Shdr* shdr, int shnum,
2984                           Elf_Sym*  stab, char* strtab )
2985 {
2986    int j;
2987    char *symbol;
2988    Elf_Addr targ;
2989    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
2990    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
2991    int target_shndx = shdr[shnum].sh_info;
2992    int symtab_shndx = shdr[shnum].sh_link;
2993
2994    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2995    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
2996    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
2997                           target_shndx, symtab_shndx ));
2998
2999    for (j = 0; j < nent; j++) {
3000 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
3001       /* This #ifdef only serves to avoid unused-var warnings. */
3002       Elf_Addr  offset = rtab[j].r_offset;
3003       Elf_Addr  P      = targ + offset;
3004 #endif
3005       Elf_Addr  info   = rtab[j].r_info;
3006       Elf_Addr  A      = rtab[j].r_addend;
3007       Elf_Addr  S;
3008       void*     S_tmp;
3009       Elf_Addr  value;
3010 #     if defined(sparc_HOST_ARCH)
3011       Elf_Word* pP = (Elf_Word*)P;
3012       Elf_Word  w1, w2;
3013 #     elif defined(ia64_HOST_ARCH)
3014       Elf64_Xword *pP = (Elf64_Xword *)P;
3015       Elf_Addr addr;
3016 #     elif defined(powerpc_HOST_ARCH)
3017       Elf_Sword delta;
3018 #     endif
3019
3020       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3021                              j, (void*)offset, (void*)info,
3022                                 (void*)A ));
3023       if (!info) {
3024          IF_DEBUG(linker,debugBelch( " ZERO" ));
3025          S = 0;
3026       } else {
3027          Elf_Sym sym = stab[ELF_R_SYM(info)];
3028          /* First see if it is a local symbol. */
3029          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3030             /* Yes, so we can get the address directly from the ELF symbol
3031                table. */
3032             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3033             S = (Elf_Addr)
3034                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3035                        + stab[ELF_R_SYM(info)].st_value);
3036 #ifdef ELF_FUNCTION_DESC
3037             /* Make a function descriptor for this function */
3038             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3039                S = allocateFunctionDesc(S + A);
3040                A = 0;
3041             }
3042 #endif
3043          } else {
3044             /* No, so look up the name in our global table. */
3045             symbol = strtab + sym.st_name;
3046             S_tmp = lookupSymbol( symbol );
3047             S = (Elf_Addr)S_tmp;
3048
3049 #ifdef ELF_FUNCTION_DESC
3050             /* If a function, already a function descriptor - we would
3051                have to copy it to add an offset. */
3052             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3053                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3054 #endif
3055          }
3056          if (!S) {
3057            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3058            return 0;
3059          }
3060          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3061       }
3062
3063       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3064                                         (void*)P, (void*)S, (void*)A ));
3065       /* checkProddableBlock ( oc, (void*)P ); */
3066
3067       value = S + A;
3068
3069       switch (ELF_R_TYPE(info)) {
3070 #        if defined(sparc_HOST_ARCH)
3071          case R_SPARC_WDISP30:
3072             w1 = *pP & 0xC0000000;
3073             w2 = (Elf_Word)((value - P) >> 2);
3074             ASSERT((w2 & 0xC0000000) == 0);
3075             w1 |= w2;
3076             *pP = w1;
3077             break;
3078          case R_SPARC_HI22:
3079             w1 = *pP & 0xFFC00000;
3080             w2 = (Elf_Word)(value >> 10);
3081             ASSERT((w2 & 0xFFC00000) == 0);
3082             w1 |= w2;
3083             *pP = w1;
3084             break;
3085          case R_SPARC_LO10:
3086             w1 = *pP & ~0x3FF;
3087             w2 = (Elf_Word)(value & 0x3FF);
3088             ASSERT((w2 & ~0x3FF) == 0);
3089             w1 |= w2;
3090             *pP = w1;
3091             break;
3092          /* According to the Sun documentation:
3093             R_SPARC_UA32
3094             This relocation type resembles R_SPARC_32, except it refers to an
3095             unaligned word. That is, the word to be relocated must be treated
3096             as four separate bytes with arbitrary alignment, not as a word
3097             aligned according to the architecture requirements.
3098
3099             (JRS: which means that freeloading on the R_SPARC_32 case
3100             is probably wrong, but hey ...)
3101          */
3102          case R_SPARC_UA32:
3103          case R_SPARC_32:
3104             w2 = (Elf_Word)value;
3105             *pP = w2;
3106             break;
3107 #        elif defined(ia64_HOST_ARCH)
3108          case R_IA64_DIR64LSB:
3109          case R_IA64_FPTR64LSB:
3110             *pP = value;
3111             break;
3112          case R_IA64_PCREL64LSB:
3113             *pP = value - P;
3114             break;
3115          case R_IA64_SEGREL64LSB:
3116             addr = findElfSegment(ehdrC, value);
3117             *pP = value - addr;
3118             break;
3119          case R_IA64_GPREL22:
3120             ia64_reloc_gprel22(P, value);
3121             break;
3122          case R_IA64_LTOFF22:
3123          case R_IA64_LTOFF22X:
3124          case R_IA64_LTOFF_FPTR22:
3125             addr = allocateGOTEntry(value);
3126             ia64_reloc_gprel22(P, addr);
3127             break;
3128          case R_IA64_PCREL21B:
3129             ia64_reloc_pcrel21(P, S, oc);
3130             break;
3131          case R_IA64_LDXMOV:
3132             /* This goes with R_IA64_LTOFF22X and points to the load to
3133              * convert into a move.  We don't implement relaxation. */
3134             break;
3135 #        elif defined(powerpc_HOST_ARCH)
3136          case R_PPC_ADDR16_LO:
3137             *(Elf32_Half*) P = value;
3138             break;
3139
3140          case R_PPC_ADDR16_HI:
3141             *(Elf32_Half*) P = value >> 16;
3142             break;
3143
3144          case R_PPC_ADDR16_HA:
3145             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3146             break;
3147
3148          case R_PPC_ADDR32:
3149             *(Elf32_Word *) P = value;
3150             break;
3151
3152          case R_PPC_REL32:
3153             *(Elf32_Word *) P = value - P;
3154             break;
3155
3156          case R_PPC_REL24:
3157             delta = value - P;
3158
3159             if( delta << 6 >> 6 != delta )
3160             {
3161                value = makeJumpIsland( oc, ELF_R_SYM(info), value );
3162                delta = value - P;
3163
3164                if( value == 0 || delta << 6 >> 6 != delta )
3165                {
3166                   barf( "Unable to make ppcJumpIsland for #%d",
3167                         ELF_R_SYM(info) );
3168                   return 0;
3169                }
3170             }
3171
3172             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3173                                           | (delta & 0x3fffffc);
3174             break;
3175 #        endif
3176
3177 #if x86_64_HOST_OS
3178       case R_X86_64_64:
3179           *(Elf64_Xword *)P = value;
3180           break;
3181
3182       case R_X86_64_PC32:
3183           *(Elf64_Word *)P = (Elf64_Word) (value - P);
3184           break;
3185
3186       case R_X86_64_32:
3187           *(Elf64_Word *)P = (Elf64_Word)value;
3188           break;
3189
3190       case R_X86_64_32S:
3191           *(Elf64_Sword *)P = (Elf64_Sword)value;
3192           break;
3193 #endif
3194
3195          default:
3196             errorBelch("%s: unhandled ELF relocation(RelA) type %d\n",
3197                   oc->fileName, ELF_R_TYPE(info));
3198             return 0;
3199       }
3200
3201    }
3202    return 1;
3203 }
3204
3205 static int
3206 ocResolve_ELF ( ObjectCode* oc )
3207 {
3208    char *strtab;
3209    int   shnum, ok;
3210    Elf_Sym*  stab  = NULL;
3211    char*     ehdrC = (char*)(oc->image);
3212    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3213    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3214
3215    /* first find "the" symbol table */
3216    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3217
3218    /* also go find the string table */
3219    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3220
3221    if (stab == NULL || strtab == NULL) {
3222       errorBelch("%s: can't find string or symbol table", oc->fileName);
3223       return 0;
3224    }
3225
3226    /* Process the relocation sections. */
3227    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3228       if (shdr[shnum].sh_type == SHT_REL) {
3229          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3230                                        shnum, stab, strtab );
3231          if (!ok) return ok;
3232       }
3233       else
3234       if (shdr[shnum].sh_type == SHT_RELA) {
3235          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3236                                         shnum, stab, strtab );
3237          if (!ok) return ok;
3238       }
3239    }
3240
3241    /* Free the local symbol table; we won't need it again. */
3242    freeHashTable(oc->lochash, NULL);
3243    oc->lochash = NULL;
3244
3245 #if defined(powerpc_HOST_ARCH)
3246    ocFlushInstructionCache( oc );
3247 #endif
3248
3249    return 1;
3250 }
3251
3252 /*
3253  * IA64 specifics
3254  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3255  * at the front.  The following utility functions pack and unpack instructions, and
3256  * take care of the most common relocations.
3257  */
3258
3259 #ifdef ia64_HOST_ARCH
3260
3261 static Elf64_Xword
3262 ia64_extract_instruction(Elf64_Xword *target)
3263 {
3264    Elf64_Xword w1, w2;
3265    int slot = (Elf_Addr)target & 3;
3266    target = (Elf_Addr)target & ~3;
3267
3268    w1 = *target;
3269    w2 = *(target+1);
3270
3271    switch (slot)
3272    {
3273       case 0:
3274          return ((w1 >> 5) & 0x1ffffffffff);
3275       case 1:
3276          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3277       case 2:
3278          return (w2 >> 23);
3279       default:
3280          barf("ia64_extract_instruction: invalid slot %p", target);
3281    }
3282 }
3283
3284 static void
3285 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3286 {
3287    int slot = (Elf_Addr)target & 3;
3288    target = (Elf_Addr)target & ~3;
3289
3290    switch (slot)
3291    {
3292       case 0:
3293          *target |= value << 5;
3294          break;
3295       case 1:
3296          *target |= value << 46;
3297          *(target+1) |= value >> 18;
3298          break;
3299       case 2:
3300          *(target+1) |= value << 23;
3301          break;
3302    }
3303 }
3304
3305 static void
3306 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3307 {
3308    Elf64_Xword instruction;
3309    Elf64_Sxword rel_value;
3310
3311    rel_value = value - gp_val;
3312    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3313       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3314
3315    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3316    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3317                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3318                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3319                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3320    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3321 }
3322
3323 static void
3324 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3325 {
3326    Elf64_Xword instruction;
3327    Elf64_Sxword rel_value;
3328    Elf_Addr entry;
3329
3330    entry = allocatePLTEntry(value, oc);
3331
3332    rel_value = (entry >> 4) - (target >> 4);
3333    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3334       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3335
3336    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3337    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3338                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3339    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3340 }
3341
3342 #endif /* ia64 */
3343
3344 /*
3345  * PowerPC ELF specifics
3346  */
3347
3348 #ifdef powerpc_HOST_ARCH
3349
3350 static int ocAllocateJumpIslands_ELF( ObjectCode *oc )
3351 {
3352   Elf_Ehdr *ehdr;
3353   Elf_Shdr* shdr;
3354   int i;
3355
3356   ehdr = (Elf_Ehdr *) oc->image;
3357   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3358
3359   for( i = 0; i < ehdr->e_shnum; i++ )
3360     if( shdr[i].sh_type == SHT_SYMTAB )
3361       break;
3362
3363   if( i == ehdr->e_shnum )
3364   {
3365     errorBelch( "This ELF file contains no symtab" );
3366     return 0;
3367   }
3368
3369   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3370   {
3371     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3372       shdr[i].sh_entsize, sizeof( Elf_Sym ) );
3373
3374     return 0;
3375   }
3376
3377   return ocAllocateJumpIslands( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3378 }
3379
3380 #endif /* powerpc */
3381
3382 #endif /* ELF */
3383
3384 /* --------------------------------------------------------------------------
3385  * Mach-O specifics
3386  * ------------------------------------------------------------------------*/
3387
3388 #if defined(OBJFORMAT_MACHO)
3389
3390 /*
3391   Support for MachO linking on Darwin/MacOS X
3392   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3393
3394   I hereby formally apologize for the hackish nature of this code.
3395   Things that need to be done:
3396   *) implement ocVerifyImage_MachO
3397   *) add still more sanity checks.
3398 */
3399
3400 #ifdef powerpc_HOST_ARCH
3401 static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
3402 {
3403     struct mach_header *header = (struct mach_header *) oc->image;
3404     struct load_command *lc = (struct load_command *) (header + 1);
3405     unsigned i;
3406
3407     for( i = 0; i < header->ncmds; i++ )
3408     {
3409         if( lc->cmd == LC_SYMTAB )
3410         {
3411                 // Find out the first and last undefined external
3412                 // symbol, so we don't have to allocate too many
3413                 // jump islands.
3414             struct symtab_command *symLC = (struct symtab_command *) lc;
3415             unsigned min = symLC->nsyms, max = 0;
3416             struct nlist *nlist =
3417                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3418                       : NULL;
3419             for(i=0;i<symLC->nsyms;i++)
3420             {
3421                 if(nlist[i].n_type & N_STAB)
3422                     ;
3423                 else if(nlist[i].n_type & N_EXT)
3424                 {
3425                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3426                         && (nlist[i].n_value == 0))
3427                     {
3428                         if(i < min)
3429                             min = i;
3430                         if(i > max)
3431                             max = i;
3432                     }
3433                 }
3434             }
3435             if(max >= min)
3436                 return ocAllocateJumpIslands(oc, max - min + 1, min);
3437
3438             break;
3439         }
3440
3441         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3442     }
3443     return ocAllocateJumpIslands(oc,0,0);
3444 }
3445 #endif
3446
3447 static int ocVerifyImage_MachO(ObjectCode* oc STG_UNUSED)
3448 {
3449     // FIXME: do some verifying here
3450     return 1;
3451 }
3452
3453 static int resolveImports(
3454     ObjectCode* oc,
3455     char *image,
3456     struct symtab_command *symLC,
3457     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3458     unsigned long *indirectSyms,
3459     struct nlist *nlist)
3460 {
3461     unsigned i;
3462
3463     for(i=0;i*4<sect->size;i++)
3464     {
3465         // according to otool, reserved1 contains the first index into the indirect symbol table
3466         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3467         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3468         void *addr = NULL;
3469
3470         if((symbol->n_type & N_TYPE) == N_UNDF
3471             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3472             addr = (void*) (symbol->n_value);
3473         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3474             ;
3475         else
3476             addr = lookupSymbol(nm);
3477         if(!addr)
3478         {
3479             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3480             return 0;
3481         }
3482         ASSERT(addr);
3483         checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3484         ((void**)(image + sect->offset))[i] = addr;
3485     }
3486
3487     return 1;
3488 }
3489
3490 static unsigned long relocateAddress(
3491     ObjectCode* oc,
3492     int nSections,
3493     struct section* sections,
3494     unsigned long address)
3495 {
3496     int i;
3497     for(i = 0; i < nSections; i++)
3498     {
3499         if(sections[i].addr <= address
3500             && address < sections[i].addr + sections[i].size)
3501         {
3502             return (unsigned long)oc->image
3503                     + sections[i].offset + address - sections[i].addr;
3504         }
3505     }
3506     barf("Invalid Mach-O file:"
3507          "Address out of bounds while relocating object file");
3508     return 0;
3509 }
3510
3511 static int relocateSection(
3512     ObjectCode* oc,
3513     char *image,
3514     struct symtab_command *symLC, struct nlist *nlist,
3515     int nSections, struct section* sections, struct section *sect)
3516 {
3517     struct relocation_info *relocs;
3518     int i,n;
3519
3520     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3521         return 1;
3522     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3523         return 1;
3524     else if(!strcmp(sect->sectname,"__la_sym_ptr2"))
3525         return 1;
3526     else if(!strcmp(sect->sectname,"__la_sym_ptr3"))
3527         return 1;
3528
3529     n = sect->nreloc;
3530     relocs = (struct relocation_info*) (image + sect->reloff);
3531
3532     for(i=0;i<n;i++)
3533     {
3534         if(relocs[i].r_address & R_SCATTERED)
3535         {
3536             struct scattered_relocation_info *scat =
3537                 (struct scattered_relocation_info*) &relocs[i];
3538
3539             if(!scat->r_pcrel)
3540             {
3541                 if(scat->r_length == 2)
3542                 {
3543                     unsigned long word = 0;
3544                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
3545                     checkProddableBlock(oc,wordPtr);
3546
3547                     // Note on relocation types:
3548                     // i386 uses the GENERIC_RELOC_* types,
3549                     // while ppc uses special PPC_RELOC_* types.
3550                     // *_RELOC_VANILLA and *_RELOC_PAIR have the same value
3551                     // in both cases, all others are different.
3552                     // Therefore, we use GENERIC_RELOC_VANILLA
3553                     // and GENERIC_RELOC_PAIR instead of the PPC variants,
3554                     // and use #ifdefs for the other types.
3555
3556                     // Step 1: Figure out what the relocated value should be
3557                     if(scat->r_type == GENERIC_RELOC_VANILLA)
3558                     {
3559                         word = *wordPtr + (unsigned long) relocateAddress(
3560                                                                 oc,
3561                                                                 nSections,
3562                                                                 sections,
3563                                                                 scat->r_value)
3564                                         - scat->r_value;
3565                     }
3566 #ifdef powerpc_HOST_ARCH
3567                     else if(scat->r_type == PPC_RELOC_SECTDIFF
3568                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
3569                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
3570                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3571 #else
3572                     else if(scat->r_type == GENERIC_RELOC_SECTDIFF)
3573 #endif
3574                     {
3575                         struct scattered_relocation_info *pair =
3576                                 (struct scattered_relocation_info*) &relocs[i+1];
3577
3578                         if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR)
3579                             barf("Invalid Mach-O file: "
3580                                  "RELOC_*_SECTDIFF not followed by RELOC_PAIR");
3581
3582                         word = (unsigned long)
3583                                (relocateAddress(oc, nSections, sections, scat->r_value)
3584                               - relocateAddress(oc, nSections, sections, pair->r_value));
3585                         i++;
3586                     }
3587 #ifdef powerpc_HOST_ARCH
3588                     else if(scat->r_type == PPC_RELOC_HI16
3589                          || scat->r_type == PPC_RELOC_LO16
3590                          || scat->r_type == PPC_RELOC_HA16
3591                          || scat->r_type == PPC_RELOC_LO14)
3592                     {   // these are generated by label+offset things
3593                         struct relocation_info *pair = &relocs[i+1];
3594                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
3595                             barf("Invalid Mach-O file: "
3596                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
3597
3598                         if(scat->r_type == PPC_RELOC_LO16)
3599                         {
3600                             word = ((unsigned short*) wordPtr)[1];
3601                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3602                         }
3603                         else if(scat->r_type == PPC_RELOC_LO14)
3604                         {
3605                             barf("Unsupported Relocation: PPC_RELOC_LO14");
3606                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
3607                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3608                         }
3609                         else if(scat->r_type == PPC_RELOC_HI16)
3610                         {
3611                             word = ((unsigned short*) wordPtr)[1] << 16;
3612                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3613                         }
3614                         else if(scat->r_type == PPC_RELOC_HA16)
3615                         {
3616                             word = ((unsigned short*) wordPtr)[1] << 16;
3617                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3618                         }
3619
3620
3621                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
3622                                                 - scat->r_value;
3623
3624                         i++;
3625                     }
3626  #endif
3627                     else
3628                         continue;  // ignore the others
3629
3630 #ifdef powerpc_HOST_ARCH
3631                     if(scat->r_type == GENERIC_RELOC_VANILLA
3632                         || scat->r_type == PPC_RELOC_SECTDIFF)
3633 #else
3634                     if(scat->r_type == GENERIC_RELOC_VANILLA
3635                         || scat->r_type == GENERIC_RELOC_SECTDIFF)
3636 #endif
3637                     {
3638                         *wordPtr = word;
3639                     }
3640 #ifdef powerpc_HOST_ARCH
3641                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
3642                     {
3643                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3644                     }
3645                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
3646                     {
3647                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3648                     }
3649                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
3650                     {
3651                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3652                             + ((word & (1<<15)) ? 1 : 0);
3653                     }
3654 #endif
3655                 }
3656             }
3657
3658             continue; // FIXME: I hope it's OK to ignore all the others.
3659         }
3660         else
3661         {
3662             struct relocation_info *reloc = &relocs[i];
3663             if(reloc->r_pcrel && !reloc->r_extern)
3664                 continue;
3665
3666             if(reloc->r_length == 2)
3667             {
3668                 unsigned long word = 0;
3669 #ifdef powerpc_HOST_ARCH
3670                 unsigned long jumpIsland = 0;
3671                 long offsetToJumpIsland = 0xBADBAD42; // initialise to bad value
3672                                                       // to avoid warning and to catch
3673                                                       // bugs.
3674 #endif
3675
3676                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
3677                 checkProddableBlock(oc,wordPtr);
3678
3679                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3680                 {
3681                     word = *wordPtr;
3682                 }
3683 #ifdef powerpc_HOST_ARCH
3684                 else if(reloc->r_type == PPC_RELOC_LO16)
3685                 {
3686                     word = ((unsigned short*) wordPtr)[1];
3687                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3688                 }
3689                 else if(reloc->r_type == PPC_RELOC_HI16)
3690                 {
3691                     word = ((unsigned short*) wordPtr)[1] << 16;
3692                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3693                 }
3694                 else if(reloc->r_type == PPC_RELOC_HA16)
3695                 {
3696                     word = ((unsigned short*) wordPtr)[1] << 16;
3697                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3698                 }
3699                 else if(reloc->r_type == PPC_RELOC_BR24)
3700                 {
3701                     word = *wordPtr;
3702                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
3703                 }
3704 #endif
3705
3706                 if(!reloc->r_extern)
3707                 {
3708                     long delta =
3709                         sections[reloc->r_symbolnum-1].offset
3710                         - sections[reloc->r_symbolnum-1].addr
3711                         + ((long) image);
3712
3713                     word += delta;
3714                 }
3715                 else
3716                 {
3717                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3718                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3719                     void *symbolAddress = lookupSymbol(nm);
3720                     if(!symbolAddress)
3721                     {
3722                         errorBelch("\nunknown symbol `%s'", nm);
3723                         return 0;
3724                     }
3725
3726                     if(reloc->r_pcrel)
3727                     {
3728 #ifdef powerpc_HOST_ARCH
3729                             // In the .o file, this should be a relative jump to NULL
3730                             // and we'll change it to a relative jump to the symbol
3731                         ASSERT(-word == reloc->r_address);
3732                         jumpIsland = makeJumpIsland(oc,reloc->r_symbolnum,(unsigned long) symbolAddress);
3733                         if(jumpIsland != 0)
3734                         {
3735                             offsetToJumpIsland = word + jumpIsland
3736                                 - (((long)image) + sect->offset - sect->addr);
3737                         }
3738 #endif
3739                         word += (unsigned long) symbolAddress
3740                                 - (((long)image) + sect->offset - sect->addr);
3741                     }
3742                     else
3743                     {
3744                         word += (unsigned long) symbolAddress;
3745                     }
3746                 }
3747
3748                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3749                 {
3750                     *wordPtr = word;
3751                     continue;
3752                 }
3753 #ifdef powerpc_HOST_ARCH
3754                 else if(reloc->r_type == PPC_RELOC_LO16)
3755                 {
3756                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3757                     i++; continue;
3758                 }
3759                 else if(reloc->r_type == PPC_RELOC_HI16)
3760                 {
3761                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3762                     i++; continue;
3763                 }
3764                 else if(reloc->r_type == PPC_RELOC_HA16)
3765                 {
3766                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3767                         + ((word & (1<<15)) ? 1 : 0);
3768                     i++; continue;
3769                 }
3770                 else if(reloc->r_type == PPC_RELOC_BR24)
3771                 {
3772                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3773                     {
3774                         // The branch offset is too large.
3775                         // Therefore, we try to use a jump island.
3776                         if(jumpIsland == 0)
3777                         {
3778                             barf("unconditional relative branch out of range: "
3779                                  "no jump island available");
3780                         }
3781
3782                         word = offsetToJumpIsland;
3783                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3784                             barf("unconditional relative branch out of range: "
3785                                  "jump island out of range");
3786                     }
3787                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
3788                     continue;
3789                 }
3790 #endif
3791             }
3792             barf("\nunknown relocation %d",reloc->r_type);
3793             return 0;
3794         }
3795     }
3796     return 1;
3797 }
3798
3799 static int ocGetNames_MachO(ObjectCode* oc)
3800 {
3801     char *image = (char*) oc->image;
3802     struct mach_header *header = (struct mach_header*) image;
3803     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3804     unsigned i,curSymbol = 0;
3805     struct segment_command *segLC = NULL;
3806     struct section *sections;
3807     struct symtab_command *symLC = NULL;
3808     struct nlist *nlist;
3809     unsigned long commonSize = 0;
3810     char    *commonStorage = NULL;
3811     unsigned long commonCounter;
3812
3813     for(i=0;i<header->ncmds;i++)
3814     {
3815         if(lc->cmd == LC_SEGMENT)
3816             segLC = (struct segment_command*) lc;
3817         else if(lc->cmd == LC_SYMTAB)
3818             symLC = (struct symtab_command*) lc;
3819         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3820     }
3821
3822     sections = (struct section*) (segLC+1);
3823     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
3824                   : NULL;
3825
3826     for(i=0;i<segLC->nsects;i++)
3827     {
3828         if(sections[i].size == 0)
3829             continue;
3830
3831         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
3832         {
3833             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
3834                                       "ocGetNames_MachO(common symbols)");
3835             sections[i].offset = zeroFillArea - image;
3836         }
3837
3838         if(!strcmp(sections[i].sectname,"__text"))
3839             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3840                 (void*) (image + sections[i].offset),
3841                 (void*) (image + sections[i].offset + sections[i].size));
3842         else if(!strcmp(sections[i].sectname,"__const"))
3843             addSection(oc, SECTIONKIND_RWDATA,
3844                 (void*) (image + sections[i].offset),
3845                 (void*) (image + sections[i].offset + sections[i].size));
3846         else if(!strcmp(sections[i].sectname,"__data"))
3847             addSection(oc, SECTIONKIND_RWDATA,
3848                 (void*) (image + sections[i].offset),
3849                 (void*) (image + sections[i].offset + sections[i].size));
3850         else if(!strcmp(sections[i].sectname,"__bss")
3851                 || !strcmp(sections[i].sectname,"__common"))
3852             addSection(oc, SECTIONKIND_RWDATA,
3853                 (void*) (image + sections[i].offset),
3854                 (void*) (image + sections[i].offset + sections[i].size));
3855
3856         addProddableBlock(oc, (void*) (image + sections[i].offset),
3857                                         sections[i].size);
3858     }
3859
3860         // count external symbols defined here
3861     oc->n_symbols = 0;
3862     if(symLC)
3863     {
3864         for(i=0;i<symLC->nsyms;i++)
3865         {
3866             if(nlist[i].n_type & N_STAB)
3867                 ;
3868             else if(nlist[i].n_type & N_EXT)
3869             {
3870                 if((nlist[i].n_type & N_TYPE) == N_UNDF
3871                     && (nlist[i].n_value != 0))
3872                 {
3873                     commonSize += nlist[i].n_value;
3874                     oc->n_symbols++;
3875                 }
3876                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
3877                     oc->n_symbols++;
3878             }
3879         }
3880     }
3881     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3882                                    "ocGetNames_MachO(oc->symbols)");
3883
3884     if(symLC)
3885     {
3886         for(i=0;i<symLC->nsyms;i++)
3887         {
3888             if(nlist[i].n_type & N_STAB)
3889                 ;
3890             else if((nlist[i].n_type & N_TYPE) == N_SECT)
3891             {
3892                 if(nlist[i].n_type & N_EXT)
3893                 {
3894                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3895                     ghciInsertStrHashTable(oc->fileName, symhash, nm,
3896                                             image
3897                                             + sections[nlist[i].n_sect-1].offset
3898                                             - sections[nlist[i].n_sect-1].addr
3899                                             + nlist[i].n_value);
3900                     oc->symbols[curSymbol++] = nm;
3901                 }
3902                 else
3903                 {
3904                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3905                     ghciInsertStrHashTable(oc->fileName, oc->lochash, nm,
3906                                             image
3907                                             + sections[nlist[i].n_sect-1].offset
3908                                             - sections[nlist[i].n_sect-1].addr
3909                                             + nlist[i].n_value);
3910                 }
3911             }
3912         }
3913     }
3914
3915     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
3916     commonCounter = (unsigned long)commonStorage;
3917     if(symLC)
3918     {
3919         for(i=0;i<symLC->nsyms;i++)
3920         {
3921             if((nlist[i].n_type & N_TYPE) == N_UNDF
3922                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3923             {
3924                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3925                 unsigned long sz = nlist[i].n_value;
3926
3927                 nlist[i].n_value = commonCounter;
3928
3929                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
3930                                        (void*)commonCounter);
3931                 oc->symbols[curSymbol++] = nm;
3932
3933                 commonCounter += sz;
3934             }
3935         }
3936     }
3937     return 1;
3938 }
3939
3940 static int ocResolve_MachO(ObjectCode* oc)
3941 {
3942     char *image = (char*) oc->image;
3943     struct mach_header *header = (struct mach_header*) image;
3944     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3945     unsigned i;
3946     struct segment_command *segLC = NULL;
3947     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3948     struct symtab_command *symLC = NULL;
3949     struct dysymtab_command *dsymLC = NULL;
3950     struct nlist *nlist;
3951
3952     for(i=0;i<header->ncmds;i++)
3953     {
3954         if(lc->cmd == LC_SEGMENT)
3955             segLC = (struct segment_command*) lc;
3956         else if(lc->cmd == LC_SYMTAB)
3957             symLC = (struct symtab_command*) lc;
3958         else if(lc->cmd == LC_DYSYMTAB)
3959             dsymLC = (struct dysymtab_command*) lc;
3960         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3961     }
3962
3963     sections = (struct section*) (segLC+1);
3964     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
3965                   : NULL;
3966
3967     for(i=0;i<segLC->nsects;i++)
3968     {
3969         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3970             la_ptrs = &sections[i];
3971         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3972             nl_ptrs = &sections[i];
3973         else if(!strcmp(sections[i].sectname,"__la_sym_ptr2"))
3974             la_ptrs = &sections[i];
3975         else if(!strcmp(sections[i].sectname,"__la_sym_ptr3"))
3976             la_ptrs = &sections[i];
3977     }
3978
3979     if(dsymLC)
3980     {
3981         unsigned long *indirectSyms
3982             = (unsigned long*) (image + dsymLC->indirectsymoff);
3983
3984         if(la_ptrs)
3985             if(!resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist))
3986                 return 0;
3987         if(nl_ptrs)
3988             if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
3989                 return 0;
3990     }
3991
3992     for(i=0;i<segLC->nsects;i++)
3993     {
3994         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
3995             return 0;
3996     }
3997
3998     /* Free the local symbol table; we won't need it again. */
3999     freeHashTable(oc->lochash, NULL);
4000     oc->lochash = NULL;
4001
4002 #if defined (powerpc_HOST_ARCH)
4003     ocFlushInstructionCache( oc );
4004 #endif
4005
4006     return 1;
4007 }
4008
4009 #ifdef powerpc_HOST_ARCH
4010 /*
4011  * The Mach-O object format uses leading underscores. But not everywhere.
4012  * There is a small number of runtime support functions defined in
4013  * libcc_dynamic.a whose name does not have a leading underscore.
4014  * As a consequence, we can't get their address from C code.
4015  * We have to use inline assembler just to take the address of a function.
4016  * Yuck.
4017  */
4018
4019 static void machoInitSymbolsWithoutUnderscore()
4020 {
4021     extern void* symbolsWithoutUnderscore[];
4022     void **p = symbolsWithoutUnderscore;
4023     __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
4024
4025 #undef Sym
4026 #define Sym(x)  \
4027     __asm__ volatile(".long " # x);
4028
4029     RTS_MACHO_NOUNDERLINE_SYMBOLS
4030
4031     __asm__ volatile(".text");
4032
4033 #undef Sym
4034 #define Sym(x)  \
4035     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
4036
4037     RTS_MACHO_NOUNDERLINE_SYMBOLS
4038
4039 #undef Sym
4040 }
4041 #endif
4042
4043 /*
4044  * Figure out by how much to shift the entire Mach-O file in memory
4045  * when loading so that its single segment ends up 16-byte-aligned
4046  */
4047 static int machoGetMisalignment( FILE * f )
4048 {
4049     struct mach_header header;
4050     int misalignment;
4051
4052     fread(&header, sizeof(header), 1, f);
4053     rewind(f);
4054
4055     if(header.magic != MH_MAGIC)
4056         return 0;
4057
4058     misalignment = (header.sizeofcmds + sizeof(header))
4059                     & 0xF;
4060
4061     return misalignment ? (16 - misalignment) : 0;
4062 }
4063
4064 #endif