ghc/rts/Linker.c

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