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