ghc/rts/Linker.c

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