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.
 987       Ignore requests to load multiple times */
 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              break; /* don't need to search further */
 995           }
 996        }
 997        if (is_dup) {
 998           IF_DEBUG(linker, belch(
 999             "GHCi runtime linker: warning: looks like you're trying to load the\n"
1000             "same object file twice:\n"
1001             "   %s\n"
1002             "GHCi will ignore this, but be warned.\n"
1003             , path));
1004           return 1; /* success */
1005        }
1006    }
1007
1008    oc = stgMallocBytes(sizeof(ObjectCode), "loadObj(oc)");
1009
1010 #  if defined(OBJFORMAT_ELF)
1011    oc->formatName = "ELF";
1012 #  elif defined(OBJFORMAT_PEi386)
1013    oc->formatName = "PEi386";
1014 #  elif defined(OBJFORMAT_MACHO)
1015    oc->formatName = "Mach-O";
1016 #  else
1017    stgFree(oc);
1018    barf("loadObj: not implemented on this platform");
1019 #  endif
1020
1021    r = stat(path, &st);
1022    if (r == -1) { return 0; }
1023
1024    /* sigh, strdup() isn't a POSIX function, so do it the long way */
1025    oc->fileName = stgMallocBytes( strlen(path)+1, "loadObj" );
1026    strcpy(oc->fileName, path);
1027
1028    oc->fileSize          = st.st_size;
1029    oc->symbols           = NULL;
1030    oc->sections          = NULL;
1031    oc->lochash           = allocStrHashTable();
1032    oc->proddables        = NULL;
1033
1034    /* chain it onto the list of objects */
1035    oc->next              = objects;
1036    objects               = oc;
1037
1038 #ifdef USE_MMAP
1039 #define ROUND_UP(x,size) ((x + size - 1) & ~(size - 1))
1040
1041    /* On many architectures malloc'd memory isn't executable, so we need to use mmap. */
1042
1043 #if defined(openbsd_TARGET_OS)
1044    fd = open(path, O_RDONLY, S_IRUSR);
1045 #else
1046    fd = open(path, O_RDONLY);
1047 #endif
1048    if (fd == -1)
1049       barf("loadObj: can't open `%s'", path);
1050
1051    pagesize = getpagesize();
1052
1053 #ifdef ia64_TARGET_ARCH
1054    /* The PLT needs to be right before the object */
1055    n = ROUND_UP(PLTSize(), pagesize);
1056    oc->plt = mmap(NULL, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0);
1057    if (oc->plt == MAP_FAILED)
1058       barf("loadObj: can't allocate PLT");
1059
1060    oc->pltIndex = 0;
1061    map_addr = oc->plt + n;
1062 #endif
1063
1064    n = ROUND_UP(oc->fileSize, pagesize);
1065    oc->image = mmap(map_addr, n, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
1066    if (oc->image == MAP_FAILED)
1067       barf("loadObj: can't map `%s'", path);
1068
1069    close(fd);
1070
1071 #else /* !USE_MMAP */
1072
1073    oc->image = stgMallocBytes(oc->fileSize, "loadObj(image)");
1074
1075    /* load the image into memory */
1076    f = fopen(path, "rb");
1077    if (!f)
1078        barf("loadObj: can't read `%s'", path);
1079
1080    n = fread ( oc->image, 1, oc->fileSize, f );
1081    if (n != oc->fileSize)
1082       barf("loadObj: error whilst reading `%s'", path);
1083
1084    fclose(f);
1085
1086 #endif /* USE_MMAP */
1087
1088 #  if defined(OBJFORMAT_MACHO)
1089    r = ocAllocateJumpIslands_MachO ( oc );
1090    if (!r) { return r; }
1091 #endif
1092
1093    /* verify the in-memory image */
1094 #  if defined(OBJFORMAT_ELF)
1095    r = ocVerifyImage_ELF ( oc );
1096 #  elif defined(OBJFORMAT_PEi386)
1097    r = ocVerifyImage_PEi386 ( oc );
1098 #  elif defined(OBJFORMAT_MACHO)
1099    r = ocVerifyImage_MachO ( oc );
1100 #  else
1101    barf("loadObj: no verify method");
1102 #  endif
1103    if (!r) { return r; }
1104
1105    /* build the symbol list for this image */
1106 #  if defined(OBJFORMAT_ELF)
1107    r = ocGetNames_ELF ( oc );
1108 #  elif defined(OBJFORMAT_PEi386)
1109    r = ocGetNames_PEi386 ( oc );
1110 #  elif defined(OBJFORMAT_MACHO)
1111    r = ocGetNames_MachO ( oc );
1112 #  else
1113    barf("loadObj: no getNames method");
1114 #  endif
1115    if (!r) { return r; }
1116
1117    /* loaded, but not resolved yet */
1118    oc->status = OBJECT_LOADED;
1119
1120    return 1;
1121 }
1122
1123 /* -----------------------------------------------------------------------------
1124  * resolve all the currently unlinked objects in memory
1125  *
1126  * Returns: 1 if ok, 0 on error.
1127  */
1128 HsInt
1129 resolveObjs( void )
1130 {
1131     ObjectCode *oc;
1132     int r;
1133
1134     initLinker();
1135
1136     for (oc = objects; oc; oc = oc->next) {
1137         if (oc->status != OBJECT_RESOLVED) {
1138 #           if defined(OBJFORMAT_ELF)
1139             r = ocResolve_ELF ( oc );
1140 #           elif defined(OBJFORMAT_PEi386)
1141             r = ocResolve_PEi386 ( oc );
1142 #           elif defined(OBJFORMAT_MACHO)
1143             r = ocResolve_MachO ( oc );
1144 #           else
1145             barf("resolveObjs: not implemented on this platform");
1146 #           endif
1147             if (!r) { return r; }
1148             oc->status = OBJECT_RESOLVED;
1149         }
1150     }
1151     return 1;
1152 }
1153
1154 /* -----------------------------------------------------------------------------
1155  * delete an object from the pool
1156  */
1157 HsInt
1158 unloadObj( char *path )
1159 {
1160     ObjectCode *oc, *prev;
1161
1162     ASSERT(symhash != NULL);
1163     ASSERT(objects != NULL);
1164
1165     initLinker();
1166
1167     prev = NULL;
1168     for (oc = objects; oc; prev = oc, oc = oc->next) {
1169         if (!strcmp(oc->fileName,path)) {
1170
1171             /* Remove all the mappings for the symbols within this
1172              * object..
1173              */
1174             {
1175                 int i;
1176                 for (i = 0; i < oc->n_symbols; i++) {
1177                    if (oc->symbols[i] != NULL) {
1178                        removeStrHashTable(symhash, oc->symbols[i], NULL);
1179                    }
1180                 }
1181             }
1182
1183             if (prev == NULL) {
1184                 objects = oc->next;
1185             } else {
1186                 prev->next = oc->next;
1187             }
1188
1189             /* We're going to leave this in place, in case there are
1190                any pointers from the heap into it: */
1191             /* stgFree(oc->image); */
1192             stgFree(oc->fileName);
1193             stgFree(oc->symbols);
1194             stgFree(oc->sections);
1195             /* The local hash table should have been freed at the end
1196                of the ocResolve_ call on it. */
1197             ASSERT(oc->lochash == NULL);
1198             stgFree(oc);
1199             return 1;
1200         }
1201     }
1202
1203     belch("unloadObj: can't find `%s' to unload", path);
1204     return 0;
1205 }
1206
1207 /* -----------------------------------------------------------------------------
1208  * Sanity checking.  For each ObjectCode, maintain a list of address ranges
1209  * which may be prodded during relocation, and abort if we try and write
1210  * outside any of these.
1211  */
1212 static void addProddableBlock ( ObjectCode* oc, void* start, int size )
1213 {
1214    ProddableBlock* pb
1215       = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
1216    /* fprintf(stderr, "aPB %p %p %d\n", oc, start, size); */
1217    ASSERT(size > 0);
1218    pb->start      = start;
1219    pb->size       = size;
1220    pb->next       = oc->proddables;
1221    oc->proddables = pb;
1222 }
1223
1224 static void checkProddableBlock ( ObjectCode* oc, void* addr )
1225 {
1226    ProddableBlock* pb;
1227    for (pb = oc->proddables; pb != NULL; pb = pb->next) {
1228       char* s = (char*)(pb->start);
1229       char* e = s + pb->size - 1;
1230       char* a = (char*)addr;
1231       /* Assumes that the biggest fixup involves a 4-byte write.  This
1232          probably needs to be changed to 8 (ie, +7) on 64-bit
1233          plats. */
1234       if (a >= s && (a+3) <= e) return;
1235    }
1236    barf("checkProddableBlock: invalid fixup in runtime linker");
1237 }
1238
1239 /* -----------------------------------------------------------------------------
1240  * Section management.
1241  */
1242 static void addSection ( ObjectCode* oc, SectionKind kind,
1243                          void* start, void* end )
1244 {
1245    Section* s   = stgMallocBytes(sizeof(Section), "addSection");
1246    s->start     = start;
1247    s->end       = end;
1248    s->kind      = kind;
1249    s->next      = oc->sections;
1250    oc->sections = s;
1251    /*
1252    fprintf(stderr, "addSection: %p-%p (size %d), kind %d\n",
1253                    start, ((char*)end)-1, end - start + 1, kind );
1254    */
1255 }
1256
1257
1258
1259 /* --------------------------------------------------------------------------
1260  * PEi386 specifics (Win32 targets)
1261  * ------------------------------------------------------------------------*/
1262
1263 /* The information for this linker comes from
1264       Microsoft Portable Executable
1265       and Common Object File Format Specification
1266       revision 5.1 January 1998
1267    which SimonM says comes from the MS Developer Network CDs.
1268
1269    It can be found there (on older CDs), but can also be found
1270    online at:
1271
1272       http://www.microsoft.com/hwdev/hardware/PECOFF.asp
1273
1274    (this is Rev 6.0 from February 1999).
1275
1276    Things move, so if that fails, try searching for it via
1277
1278       http://www.google.com/search?q=PE+COFF+specification
1279
1280    The ultimate reference for the PE format is the Winnt.h
1281    header file that comes with the Platform SDKs; as always,
1282    implementations will drift wrt their documentation.
1283
1284    A good background article on the PE format is Matt Pietrek's
1285    March 1994 article in Microsoft System Journal (MSJ)
1286    (Vol.9, No. 3): "Peering Inside the PE: A Tour of the
1287    Win32 Portable Executable File Format." The info in there
1288    has recently been updated in a two part article in
1289    MSDN magazine, issues Feb and March 2002,
1290    "Inside Windows: An In-Depth Look into the Win32 Portable
1291    Executable File Format"
1292
1293    John Levine's book "Linkers and Loaders" contains useful
1294    info on PE too.
1295 */
1296
1297
1298 #if defined(OBJFORMAT_PEi386)
1299
1300
1301
1302 typedef unsigned char  UChar;
1303 typedef unsigned short UInt16;
1304 typedef unsigned int   UInt32;
1305 typedef          int   Int32;
1306
1307
1308 typedef
1309    struct {
1310       UInt16 Machine;
1311       UInt16 NumberOfSections;
1312       UInt32 TimeDateStamp;
1313       UInt32 PointerToSymbolTable;
1314       UInt32 NumberOfSymbols;
1315       UInt16 SizeOfOptionalHeader;
1316       UInt16 Characteristics;
1317    }
1318    COFF_header;
1319
1320 #define sizeof_COFF_header 20
1321
1322
1323 typedef
1324    struct {
1325       UChar  Name[8];
1326       UInt32 VirtualSize;
1327       UInt32 VirtualAddress;
1328       UInt32 SizeOfRawData;
1329       UInt32 PointerToRawData;
1330       UInt32 PointerToRelocations;
1331       UInt32 PointerToLinenumbers;
1332       UInt16 NumberOfRelocations;
1333       UInt16 NumberOfLineNumbers;
1334       UInt32 Characteristics;
1335    }
1336    COFF_section;
1337
1338 #define sizeof_COFF_section 40
1339
1340
1341 typedef
1342    struct {
1343       UChar  Name[8];
1344       UInt32 Value;
1345       UInt16 SectionNumber;
1346       UInt16 Type;
1347       UChar  StorageClass;
1348       UChar  NumberOfAuxSymbols;
1349    }
1350    COFF_symbol;
1351
1352 #define sizeof_COFF_symbol 18
1353
1354
1355 typedef
1356    struct {
1357       UInt32 VirtualAddress;
1358       UInt32 SymbolTableIndex;
1359       UInt16 Type;
1360    }
1361    COFF_reloc;
1362
1363 #define sizeof_COFF_reloc 10
1364
1365
1366 /* From PE spec doc, section 3.3.2 */
1367 /* Note use of MYIMAGE_* since IMAGE_* are already defined in
1368    windows.h -- for the same purpose, but I want to know what I'm
1369    getting, here. */
1370 #define MYIMAGE_FILE_RELOCS_STRIPPED     0x0001
1371 #define MYIMAGE_FILE_EXECUTABLE_IMAGE    0x0002
1372 #define MYIMAGE_FILE_DLL                 0x2000
1373 #define MYIMAGE_FILE_SYSTEM              0x1000
1374 #define MYIMAGE_FILE_BYTES_REVERSED_HI   0x8000
1375 #define MYIMAGE_FILE_BYTES_REVERSED_LO   0x0080
1376 #define MYIMAGE_FILE_32BIT_MACHINE       0x0100
1377
1378 /* From PE spec doc, section 5.4.2 and 5.4.4 */
1379 #define MYIMAGE_SYM_CLASS_EXTERNAL       2
1380 #define MYIMAGE_SYM_CLASS_STATIC         3
1381 #define MYIMAGE_SYM_UNDEFINED            0
1382
1383 /* From PE spec doc, section 4.1 */
1384 #define MYIMAGE_SCN_CNT_CODE             0x00000020
1385 #define MYIMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
1386 #define MYIMAGE_SCN_LNK_NRELOC_OVFL      0x01000000
1387
1388 /* From PE spec doc, section 5.2.1 */
1389 #define MYIMAGE_REL_I386_DIR32           0x0006
1390 #define MYIMAGE_REL_I386_REL32           0x0014
1391
1392
1393 /* We use myindex to calculate array addresses, rather than
1394    simply doing the normal subscript thing.  That's because
1395    some of the above structs have sizes which are not
1396    a whole number of words.  GCC rounds their sizes up to a
1397    whole number of words, which means that the address calcs
1398    arising from using normal C indexing or pointer arithmetic
1399    are just plain wrong.  Sigh.
1400 */
1401 static UChar *
1402 myindex ( int scale, void* base, int index )
1403 {
1404    return
1405       ((UChar*)base) + scale * index;
1406 }
1407
1408
1409 static void
1410 printName ( UChar* name, UChar* strtab )
1411 {
1412    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1413       UInt32 strtab_offset = * (UInt32*)(name+4);
1414       fprintf ( stderr, "%s", strtab + strtab_offset );
1415    } else {
1416       int i;
1417       for (i = 0; i < 8; i++) {
1418          if (name[i] == 0) break;
1419          fprintf ( stderr, "%c", name[i] );
1420       }
1421    }
1422 }
1423
1424
1425 static void
1426 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
1427 {
1428    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1429       UInt32 strtab_offset = * (UInt32*)(name+4);
1430       strncpy ( dst, strtab+strtab_offset, dstSize );
1431       dst[dstSize-1] = 0;
1432    } else {
1433       int i = 0;
1434       while (1) {
1435          if (i >= 8) break;
1436          if (name[i] == 0) break;
1437          dst[i] = name[i];
1438          i++;
1439       }
1440       dst[i] = 0;
1441    }
1442 }
1443
1444
1445 static UChar *
1446 cstring_from_COFF_symbol_name ( UChar* name, UChar* strtab )
1447 {
1448    UChar* newstr;
1449    /* If the string is longer than 8 bytes, look in the
1450       string table for it -- this will be correctly zero terminated.
1451    */
1452    if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
1453       UInt32 strtab_offset = * (UInt32*)(name+4);
1454       return ((UChar*)strtab) + strtab_offset;
1455    }
1456    /* Otherwise, if shorter than 8 bytes, return the original,
1457       which by defn is correctly terminated.
1458    */
1459    if (name[7]==0) return name;
1460    /* The annoying case: 8 bytes.  Copy into a temporary
1461       (which is never freed ...)
1462    */
1463    newstr = stgMallocBytes(9, "cstring_from_COFF_symbol_name");
1464    ASSERT(newstr);
1465    strncpy(newstr,name,8);
1466    newstr[8] = 0;
1467    return newstr;
1468 }
1469
1470
1471 /* Just compares the short names (first 8 chars) */
1472 static COFF_section *
1473 findPEi386SectionCalled ( ObjectCode* oc,  char* name )
1474 {
1475    int i;
1476    COFF_header* hdr
1477       = (COFF_header*)(oc->image);
1478    COFF_section* sectab
1479       = (COFF_section*) (
1480            ((UChar*)(oc->image))
1481            + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1482         );
1483    for (i = 0; i < hdr->NumberOfSections; i++) {
1484       UChar* n1;
1485       UChar* n2;
1486       COFF_section* section_i
1487          = (COFF_section*)
1488            myindex ( sizeof_COFF_section, sectab, i );
1489       n1 = (UChar*) &(section_i->Name);
1490       n2 = name;
1491       if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
1492           n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
1493           n1[6]==n2[6] && n1[7]==n2[7])
1494          return section_i;
1495    }
1496
1497    return NULL;
1498 }
1499
1500
1501 static void
1502 zapTrailingAtSign ( UChar* sym )
1503 {
1504 #  define my_isdigit(c) ((c) >= '0' && (c) <= '9')
1505    int i, j;
1506    if (sym[0] == 0) return;
1507    i = 0;
1508    while (sym[i] != 0) i++;
1509    i--;
1510    j = i;
1511    while (j > 0 && my_isdigit(sym[j])) j--;
1512    if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
1513 #  undef my_isdigit
1514 }
1515
1516
1517 static int
1518 ocVerifyImage_PEi386 ( ObjectCode* oc )
1519 {
1520    int i;
1521    UInt32 j, noRelocs;
1522    COFF_header*  hdr;
1523    COFF_section* sectab;
1524    COFF_symbol*  symtab;
1525    UChar*        strtab;
1526    /* fprintf(stderr, "\nLOADING %s\n", oc->fileName); */
1527    hdr = (COFF_header*)(oc->image);
1528    sectab = (COFF_section*) (
1529                ((UChar*)(oc->image))
1530                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1531             );
1532    symtab = (COFF_symbol*) (
1533                ((UChar*)(oc->image))
1534                + hdr->PointerToSymbolTable
1535             );
1536    strtab = ((UChar*)symtab)
1537             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1538
1539    if (hdr->Machine != 0x14c) {
1540       belch("Not x86 PEi386");
1541       return 0;
1542    }
1543    if (hdr->SizeOfOptionalHeader != 0) {
1544       belch("PEi386 with nonempty optional header");
1545       return 0;
1546    }
1547    if ( /* (hdr->Characteristics & MYIMAGE_FILE_RELOCS_STRIPPED) || */
1548         (hdr->Characteristics & MYIMAGE_FILE_EXECUTABLE_IMAGE) ||
1549         (hdr->Characteristics & MYIMAGE_FILE_DLL) ||
1550         (hdr->Characteristics & MYIMAGE_FILE_SYSTEM) ) {
1551       belch("Not a PEi386 object file");
1552       return 0;
1553    }
1554    if ( (hdr->Characteristics & MYIMAGE_FILE_BYTES_REVERSED_HI)
1555         /* || !(hdr->Characteristics & MYIMAGE_FILE_32BIT_MACHINE) */ ) {
1556       belch("Invalid PEi386 word size or endiannness: %d",
1557             (int)(hdr->Characteristics));
1558       return 0;
1559    }
1560    /* If the string table size is way crazy, this might indicate that
1561       there are more than 64k relocations, despite claims to the
1562       contrary.  Hence this test. */
1563    /* fprintf(stderr, "strtab size %d\n", * (UInt32*)strtab); */
1564 #if 0
1565    if ( (*(UInt32*)strtab) > 600000 ) {
1566       /* Note that 600k has no special significance other than being
1567          big enough to handle the almost-2MB-sized lumps that
1568          constitute HSwin32*.o. */
1569       belch("PEi386 object has suspiciously large string table; > 64k relocs?");
1570       return 0;
1571    }
1572 #endif
1573
1574    /* No further verification after this point; only debug printing. */
1575    i = 0;
1576    IF_DEBUG(linker, i=1);
1577    if (i == 0) return 1;
1578
1579    fprintf ( stderr,
1580              "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
1581    fprintf ( stderr,
1582              "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
1583    fprintf ( stderr,
1584              "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
1585
1586    fprintf ( stderr, "\n" );
1587    fprintf ( stderr,
1588              "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
1589    fprintf ( stderr,
1590              "# sections:        %d\n",   (UInt32)(hdr->NumberOfSections) );
1591    fprintf ( stderr,
1592              "time/date:         0x%x\n", (UInt32)(hdr->TimeDateStamp) );
1593    fprintf ( stderr,
1594              "symtab offset:     %d\n",   (UInt32)(hdr->PointerToSymbolTable) );
1595    fprintf ( stderr,
1596              "# symbols:         %d\n",   (UInt32)(hdr->NumberOfSymbols) );
1597    fprintf ( stderr,
1598              "sz of opt hdr:     %d\n",   (UInt32)(hdr->SizeOfOptionalHeader) );
1599    fprintf ( stderr,
1600              "characteristics:   0x%x\n", (UInt32)(hdr->Characteristics) );
1601
1602    /* Print the section table. */
1603    fprintf ( stderr, "\n" );
1604    for (i = 0; i < hdr->NumberOfSections; i++) {
1605       COFF_reloc* reltab;
1606       COFF_section* sectab_i
1607          = (COFF_section*)
1608            myindex ( sizeof_COFF_section, sectab, i );
1609       fprintf ( stderr,
1610                 "\n"
1611                 "section %d\n"
1612                 "     name `",
1613                 i
1614               );
1615       printName ( sectab_i->Name, strtab );
1616       fprintf ( stderr,
1617                 "'\n"
1618                 "    vsize %d\n"
1619                 "    vaddr %d\n"
1620                 "  data sz %d\n"
1621                 " data off %d\n"
1622                 "  num rel %d\n"
1623                 "  off rel %d\n"
1624                 "  ptr raw 0x%x\n",
1625                 sectab_i->VirtualSize,
1626                 sectab_i->VirtualAddress,
1627                 sectab_i->SizeOfRawData,
1628                 sectab_i->PointerToRawData,
1629                 sectab_i->NumberOfRelocations,
1630                 sectab_i->PointerToRelocations,
1631                 sectab_i->PointerToRawData
1632               );
1633       reltab = (COFF_reloc*) (
1634                   ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1635                );
1636
1637       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1638         /* If the relocation field (a short) has overflowed, the
1639          * real count can be found in the first reloc entry.
1640          *
1641          * See Section 4.1 (last para) of the PE spec (rev6.0).
1642          */
1643         COFF_reloc* rel = (COFF_reloc*)
1644                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1645         noRelocs = rel->VirtualAddress;
1646         j = 1;
1647       } else {
1648         noRelocs = sectab_i->NumberOfRelocations;
1649         j = 0;
1650       }
1651
1652       for (; j < noRelocs; j++) {
1653          COFF_symbol* sym;
1654          COFF_reloc* rel = (COFF_reloc*)
1655                            myindex ( sizeof_COFF_reloc, reltab, j );
1656          fprintf ( stderr,
1657                    "        type 0x%-4x   vaddr 0x%-8x   name `",
1658                    (UInt32)rel->Type,
1659                    rel->VirtualAddress );
1660          sym = (COFF_symbol*)
1661                myindex ( sizeof_COFF_symbol, symtab, rel->SymbolTableIndex );
1662          /* Hmm..mysterious looking offset - what's it for? SOF */
1663          printName ( sym->Name, strtab -10 );
1664          fprintf ( stderr, "'\n" );
1665       }
1666
1667       fprintf ( stderr, "\n" );
1668    }
1669    fprintf ( stderr, "\n" );
1670    fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
1671    fprintf ( stderr, "---START of string table---\n");
1672    for (i = 4; i < *(Int32*)strtab; i++) {
1673       if (strtab[i] == 0)
1674          fprintf ( stderr, "\n"); else
1675          fprintf( stderr, "%c", strtab[i] );
1676    }
1677    fprintf ( stderr, "--- END  of string table---\n");
1678
1679    fprintf ( stderr, "\n" );
1680    i = 0;
1681    while (1) {
1682       COFF_symbol* symtab_i;
1683       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1684       symtab_i = (COFF_symbol*)
1685                  myindex ( sizeof_COFF_symbol, symtab, i );
1686       fprintf ( stderr,
1687                 "symbol %d\n"
1688                 "     name `",
1689                 i
1690               );
1691       printName ( symtab_i->Name, strtab );
1692       fprintf ( stderr,
1693                 "'\n"
1694                 "    value 0x%x\n"
1695                 "   1+sec# %d\n"
1696                 "     type 0x%x\n"
1697                 "   sclass 0x%x\n"
1698                 "     nAux %d\n",
1699                 symtab_i->Value,
1700                 (Int32)(symtab_i->SectionNumber),
1701                 (UInt32)symtab_i->Type,
1702                 (UInt32)symtab_i->StorageClass,
1703                 (UInt32)symtab_i->NumberOfAuxSymbols
1704               );
1705       i += symtab_i->NumberOfAuxSymbols;
1706       i++;
1707    }
1708
1709    fprintf ( stderr, "\n" );
1710    return 1;
1711 }
1712
1713
1714 static int
1715 ocGetNames_PEi386 ( ObjectCode* oc )
1716 {
1717    COFF_header*  hdr;
1718    COFF_section* sectab;
1719    COFF_symbol*  symtab;
1720    UChar*        strtab;
1721
1722    UChar* sname;
1723    void*  addr;
1724    int    i;
1725
1726    hdr = (COFF_header*)(oc->image);
1727    sectab = (COFF_section*) (
1728                ((UChar*)(oc->image))
1729                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1730             );
1731    symtab = (COFF_symbol*) (
1732                ((UChar*)(oc->image))
1733                + hdr->PointerToSymbolTable
1734             );
1735    strtab = ((UChar*)(oc->image))
1736             + hdr->PointerToSymbolTable
1737             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1738
1739    /* Allocate space for any (local, anonymous) .bss sections. */
1740
1741    for (i = 0; i < hdr->NumberOfSections; i++) {
1742       UChar* zspace;
1743       COFF_section* sectab_i
1744          = (COFF_section*)
1745            myindex ( sizeof_COFF_section, sectab, i );
1746       if (0 != strcmp(sectab_i->Name, ".bss")) continue;
1747       if (sectab_i->VirtualSize == 0) continue;
1748       /* This is a non-empty .bss section.  Allocate zeroed space for
1749          it, and set its PointerToRawData field such that oc->image +
1750          PointerToRawData == addr_of_zeroed_space.  */
1751       zspace = stgCallocBytes(1, sectab_i->VirtualSize,
1752                               "ocGetNames_PEi386(anonymous bss)");
1753       sectab_i->PointerToRawData = ((UChar*)zspace) - ((UChar*)(oc->image));
1754       addProddableBlock(oc, zspace, sectab_i->VirtualSize);
1755       /* fprintf(stderr, "BSS anon section at 0x%x\n", zspace); */
1756    }
1757
1758    /* Copy section information into the ObjectCode. */
1759
1760    for (i = 0; i < hdr->NumberOfSections; i++) {
1761       UChar* start;
1762       UChar* end;
1763       UInt32 sz;
1764
1765       SectionKind kind
1766          = SECTIONKIND_OTHER;
1767       COFF_section* sectab_i
1768          = (COFF_section*)
1769            myindex ( sizeof_COFF_section, sectab, i );
1770       IF_DEBUG(linker, belch("section name = %s\n", sectab_i->Name ));
1771
1772 #     if 0
1773       /* I'm sure this is the Right Way to do it.  However, the
1774          alternative of testing the sectab_i->Name field seems to
1775          work ok with Cygwin.
1776       */
1777       if (sectab_i->Characteristics & MYIMAGE_SCN_CNT_CODE ||
1778           sectab_i->Characteristics & MYIMAGE_SCN_CNT_INITIALIZED_DATA)
1779          kind = SECTIONKIND_CODE_OR_RODATA;
1780 #     endif
1781
1782       if (0==strcmp(".text",sectab_i->Name) ||
1783           0==strcmp(".rodata",sectab_i->Name))
1784          kind = SECTIONKIND_CODE_OR_RODATA;
1785       if (0==strcmp(".data",sectab_i->Name) ||
1786           0==strcmp(".bss",sectab_i->Name))
1787          kind = SECTIONKIND_RWDATA;
1788
1789       ASSERT(sectab_i->SizeOfRawData == 0 || sectab_i->VirtualSize == 0);
1790       sz = sectab_i->SizeOfRawData;
1791       if (sz < sectab_i->VirtualSize) sz = sectab_i->VirtualSize;
1792
1793       start = ((UChar*)(oc->image)) + sectab_i->PointerToRawData;
1794       end   = start + sz - 1;
1795
1796       if (kind == SECTIONKIND_OTHER
1797           /* Ignore sections called which contain stabs debugging
1798              information. */
1799           && 0 != strcmp(".stab", sectab_i->Name)
1800           && 0 != strcmp(".stabstr", sectab_i->Name)
1801          ) {
1802          belch("Unknown PEi386 section name `%s'", sectab_i->Name);
1803          return 0;
1804       }
1805
1806       if (kind != SECTIONKIND_OTHER && end >= start) {
1807          addSection(oc, kind, start, end);
1808          addProddableBlock(oc, start, end - start + 1);
1809       }
1810    }
1811
1812    /* Copy exported symbols into the ObjectCode. */
1813
1814    oc->n_symbols = hdr->NumberOfSymbols;
1815    oc->symbols   = stgMallocBytes(oc->n_symbols * sizeof(char*),
1816                                   "ocGetNames_PEi386(oc->symbols)");
1817    /* Call me paranoid; I don't care. */
1818    for (i = 0; i < oc->n_symbols; i++)
1819       oc->symbols[i] = NULL;
1820
1821    i = 0;
1822    while (1) {
1823       COFF_symbol* symtab_i;
1824       if (i >= (Int32)(hdr->NumberOfSymbols)) break;
1825       symtab_i = (COFF_symbol*)
1826                  myindex ( sizeof_COFF_symbol, symtab, i );
1827
1828       addr  = NULL;
1829
1830       if (symtab_i->StorageClass == MYIMAGE_SYM_CLASS_EXTERNAL
1831           && symtab_i->SectionNumber != MYIMAGE_SYM_UNDEFINED) {
1832          /* This symbol is global and defined, viz, exported */
1833          /* for MYIMAGE_SYMCLASS_EXTERNAL
1834                 && !MYIMAGE_SYM_UNDEFINED,
1835             the address of the symbol is:
1836                 address of relevant section + offset in section
1837          */
1838          COFF_section* sectabent
1839             = (COFF_section*) myindex ( sizeof_COFF_section,
1840                                         sectab,
1841                                         symtab_i->SectionNumber-1 );
1842          addr = ((UChar*)(oc->image))
1843                 + (sectabent->PointerToRawData
1844                    + symtab_i->Value);
1845       }
1846       else
1847       if (symtab_i->SectionNumber == MYIMAGE_SYM_UNDEFINED
1848           && symtab_i->Value > 0) {
1849          /* This symbol isn't in any section at all, ie, global bss.
1850             Allocate zeroed space for it. */
1851          addr = stgCallocBytes(1, symtab_i->Value,
1852                                "ocGetNames_PEi386(non-anonymous bss)");
1853          addSection(oc, SECTIONKIND_RWDATA, addr,
1854                         ((UChar*)addr) + symtab_i->Value - 1);
1855          addProddableBlock(oc, addr, symtab_i->Value);
1856          /* fprintf(stderr, "BSS      section at 0x%x\n", addr); */
1857       }
1858
1859       if (addr != NULL ) {
1860          sname = cstring_from_COFF_symbol_name ( symtab_i->Name, strtab );
1861          /* fprintf(stderr,"addSymbol %p `%s \n", addr,sname);  */
1862          IF_DEBUG(linker, belch("addSymbol %p `%s'\n", addr,sname);)
1863          ASSERT(i >= 0 && i < oc->n_symbols);
1864          /* cstring_from_COFF_symbol_name always succeeds. */
1865          oc->symbols[i] = sname;
1866          ghciInsertStrHashTable(oc->fileName, symhash, sname, addr);
1867       } else {
1868 #        if 0
1869          fprintf ( stderr,
1870                    "IGNORING symbol %d\n"
1871                    "     name `",
1872                    i
1873                  );
1874          printName ( symtab_i->Name, strtab );
1875          fprintf ( stderr,
1876                    "'\n"
1877                    "    value 0x%x\n"
1878                    "   1+sec# %d\n"
1879                    "     type 0x%x\n"
1880                    "   sclass 0x%x\n"
1881                    "     nAux %d\n",
1882                    symtab_i->Value,
1883                    (Int32)(symtab_i->SectionNumber),
1884                    (UInt32)symtab_i->Type,
1885                    (UInt32)symtab_i->StorageClass,
1886                    (UInt32)symtab_i->NumberOfAuxSymbols
1887                  );
1888 #        endif
1889       }
1890
1891       i += symtab_i->NumberOfAuxSymbols;
1892       i++;
1893    }
1894
1895    return 1;
1896 }
1897
1898
1899 static int
1900 ocResolve_PEi386 ( ObjectCode* oc )
1901 {
1902    COFF_header*  hdr;
1903    COFF_section* sectab;
1904    COFF_symbol*  symtab;
1905    UChar*        strtab;
1906
1907    UInt32        A;
1908    UInt32        S;
1909    UInt32*       pP;
1910
1911    int i;
1912    UInt32 j, noRelocs;
1913
1914    /* ToDo: should be variable-sized?  But is at least safe in the
1915       sense of buffer-overrun-proof. */
1916    char symbol[1000];
1917    /* fprintf(stderr, "resolving for %s\n", oc->fileName); */
1918
1919    hdr = (COFF_header*)(oc->image);
1920    sectab = (COFF_section*) (
1921                ((UChar*)(oc->image))
1922                + sizeof_COFF_header + hdr->SizeOfOptionalHeader
1923             );
1924    symtab = (COFF_symbol*) (
1925                ((UChar*)(oc->image))
1926                + hdr->PointerToSymbolTable
1927             );
1928    strtab = ((UChar*)(oc->image))
1929             + hdr->PointerToSymbolTable
1930             + hdr->NumberOfSymbols * sizeof_COFF_symbol;
1931
1932    for (i = 0; i < hdr->NumberOfSections; i++) {
1933       COFF_section* sectab_i
1934          = (COFF_section*)
1935            myindex ( sizeof_COFF_section, sectab, i );
1936       COFF_reloc* reltab
1937          = (COFF_reloc*) (
1938               ((UChar*)(oc->image)) + sectab_i->PointerToRelocations
1939            );
1940
1941       /* Ignore sections called which contain stabs debugging
1942          information. */
1943       if (0 == strcmp(".stab", sectab_i->Name)
1944           || 0 == strcmp(".stabstr", sectab_i->Name))
1945          continue;
1946
1947       if ( sectab_i->Characteristics & MYIMAGE_SCN_LNK_NRELOC_OVFL ) {
1948         /* If the relocation field (a short) has overflowed, the
1949          * real count can be found in the first reloc entry.
1950          *
1951          * See Section 4.1 (last para) of the PE spec (rev6.0).
1952          *
1953          * Nov2003 update: the GNU linker still doesn't correctly
1954          * handle the generation of relocatable object files with
1955          * overflown relocations. Hence the output to warn of potential
1956          * troubles.
1957          */
1958         COFF_reloc* rel = (COFF_reloc*)
1959                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1960         noRelocs = rel->VirtualAddress;
1961         fprintf(stderr, "WARNING: Overflown relocation field (# relocs found: %u)\n", noRelocs); fflush(stderr);
1962         j = 1;
1963       } else {
1964         noRelocs = sectab_i->NumberOfRelocations;
1965         j = 0;
1966       }
1967
1968
1969       for (; j < noRelocs; j++) {
1970          COFF_symbol* sym;
1971          COFF_reloc* reltab_j
1972             = (COFF_reloc*)
1973               myindex ( sizeof_COFF_reloc, reltab, j );
1974
1975          /* the location to patch */
1976          pP = (UInt32*)(
1977                  ((UChar*)(oc->image))
1978                  + (sectab_i->PointerToRawData
1979                     + reltab_j->VirtualAddress
1980                     - sectab_i->VirtualAddress )
1981               );
1982          /* the existing contents of pP */
1983          A = *pP;
1984          /* the symbol to connect to */
1985          sym = (COFF_symbol*)
1986                myindex ( sizeof_COFF_symbol,
1987                          symtab, reltab_j->SymbolTableIndex );
1988          IF_DEBUG(linker,
1989                   fprintf ( stderr,
1990                             "reloc sec %2d num %3d:  type 0x%-4x   "
1991                             "vaddr 0x%-8x   name `",
1992                             i, j,
1993                             (UInt32)reltab_j->Type,
1994                             reltab_j->VirtualAddress );
1995                             printName ( sym->Name, strtab );
1996                             fprintf ( stderr, "'\n" ));
1997
1998          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1999             COFF_section* section_sym
2000                = findPEi386SectionCalled ( oc, sym->Name );
2001             if (!section_sym) {
2002                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
2003                return 0;
2004             }
2005             S = ((UInt32)(oc->image))
2006                 + (section_sym->PointerToRawData
2007                    + sym->Value);
2008          } else {
2009             copyName ( sym->Name, strtab, symbol, 1000-1 );
2010             (void*)S = lookupLocalSymbol( oc, symbol );
2011             if ((void*)S != NULL) goto foundit;
2012             (void*)S = lookupSymbol( symbol );
2013             if ((void*)S != NULL) goto foundit;
2014             zapTrailingAtSign ( symbol );
2015             (void*)S = lookupLocalSymbol( oc, symbol );
2016             if ((void*)S != NULL) goto foundit;
2017             (void*)S = lookupSymbol( symbol );
2018             if ((void*)S != NULL) goto foundit;
2019             /* Newline first because the interactive linker has printed "linking..." */
2020             belch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
2021             return 0;
2022            foundit:
2023          }
2024          checkProddableBlock(oc, pP);
2025          switch (reltab_j->Type) {
2026             case MYIMAGE_REL_I386_DIR32:
2027                *pP = A + S;
2028                break;
2029             case MYIMAGE_REL_I386_REL32:
2030                /* Tricky.  We have to insert a displacement at
2031                   pP which, when added to the PC for the _next_
2032                   insn, gives the address of the target (S).
2033                   Problem is to know the address of the next insn
2034                   when we only know pP.  We assume that this
2035                   literal field is always the last in the insn,
2036                   so that the address of the next insn is pP+4
2037                   -- hence the constant 4.
2038                   Also I don't know if A should be added, but so
2039                   far it has always been zero.
2040                */
2041                ASSERT(A==0);
2042                *pP = S - ((UInt32)pP) - 4;
2043                break;
2044             default:
2045                belch("%s: unhandled PEi386 relocation type %d",
2046                      oc->fileName, reltab_j->Type);
2047                return 0;
2048          }
2049
2050       }
2051    }
2052
2053    IF_DEBUG(linker, belch("completed %s", oc->fileName));
2054    return 1;
2055 }
2056
2057 #endif /* defined(OBJFORMAT_PEi386) */
2058
2059
2060 /* --------------------------------------------------------------------------
2061  * ELF specifics
2062  * ------------------------------------------------------------------------*/
2063
2064 #if defined(OBJFORMAT_ELF)
2065
2066 #define FALSE 0
2067 #define TRUE  1
2068
2069 #if defined(sparc_TARGET_ARCH)
2070 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2071 #elif defined(i386_TARGET_ARCH)
2072 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2073 #elif defined(x86_64_TARGET_ARCH)
2074 #  define ELF_TARGET_X64_64
2075 #  define ELF_64BIT
2076 #elif defined (ia64_TARGET_ARCH)
2077 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2078 #  define ELF_64BIT
2079 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2080 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2081 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2082 #endif
2083
2084 #if !defined(openbsd_TARGET_OS)
2085 #include <elf.h>
2086 #else
2087 /* openbsd elf has things in different places, with diff names */
2088 #include <elf_abi.h>
2089 #include <machine/reloc.h>
2090 #define R_386_32    RELOC_32
2091 #define R_386_PC32  RELOC_PC32
2092 #endif
2093
2094 /*
2095  * Define a set of types which can be used for both ELF32 and ELF64
2096  */
2097
2098 #ifdef ELF_64BIT
2099 #define ELFCLASS    ELFCLASS64
2100 #define Elf_Addr    Elf64_Addr
2101 #define Elf_Word    Elf64_Word
2102 #define Elf_Sword   Elf64_Sword
2103 #define Elf_Ehdr    Elf64_Ehdr
2104 #define Elf_Phdr    Elf64_Phdr
2105 #define Elf_Shdr    Elf64_Shdr
2106 #define Elf_Sym     Elf64_Sym
2107 #define Elf_Rel     Elf64_Rel
2108 #define Elf_Rela    Elf64_Rela
2109 #define ELF_ST_TYPE ELF64_ST_TYPE
2110 #define ELF_ST_BIND ELF64_ST_BIND
2111 #define ELF_R_TYPE  ELF64_R_TYPE
2112 #define ELF_R_SYM   ELF64_R_SYM
2113 #else
2114 #define ELFCLASS    ELFCLASS32
2115 #define Elf_Addr    Elf32_Addr
2116 #define Elf_Word    Elf32_Word
2117 #define Elf_Sword   Elf32_Sword
2118 #define Elf_Ehdr    Elf32_Ehdr
2119 #define Elf_Phdr    Elf32_Phdr
2120 #define Elf_Shdr    Elf32_Shdr
2121 #define Elf_Sym     Elf32_Sym
2122 #define Elf_Rel     Elf32_Rel
2123 #define Elf_Rela    Elf32_Rela
2124 #ifndef ELF_ST_TYPE
2125 #define ELF_ST_TYPE ELF32_ST_TYPE
2126 #endif
2127 #ifndef ELF_ST_BIND
2128 #define ELF_ST_BIND ELF32_ST_BIND
2129 #endif
2130 #ifndef ELF_R_TYPE
2131 #define ELF_R_TYPE  ELF32_R_TYPE
2132 #endif
2133 #ifndef ELF_R_SYM
2134 #define ELF_R_SYM   ELF32_R_SYM
2135 #endif
2136 #endif
2137
2138
2139 /*
2140  * Functions to allocate entries in dynamic sections.  Currently we simply
2141  * preallocate a large number, and we don't check if a entry for the given
2142  * target already exists (a linear search is too slow).  Ideally these
2143  * entries would be associated with symbols.
2144  */
2145
2146 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2147 #define GOT_SIZE            0x20000
2148 #define FUNCTION_TABLE_SIZE 0x10000
2149 #define PLT_SIZE            0x08000
2150
2151 #ifdef ELF_NEED_GOT
2152 static Elf_Addr got[GOT_SIZE];
2153 static unsigned int gotIndex;
2154 static Elf_Addr gp_val = (Elf_Addr)got;
2155
2156 static Elf_Addr
2157 allocateGOTEntry(Elf_Addr target)
2158 {
2159    Elf_Addr *entry;
2160
2161    if (gotIndex >= GOT_SIZE)
2162       barf("Global offset table overflow");
2163
2164    entry = &got[gotIndex++];
2165    *entry = target;
2166    return (Elf_Addr)entry;
2167 }
2168 #endif
2169
2170 #ifdef ELF_FUNCTION_DESC
2171 typedef struct {
2172    Elf_Addr ip;
2173    Elf_Addr gp;
2174 } FunctionDesc;
2175
2176 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2177 static unsigned int functionTableIndex;
2178
2179 static Elf_Addr
2180 allocateFunctionDesc(Elf_Addr target)
2181 {
2182    FunctionDesc *entry;
2183
2184    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2185       barf("Function table overflow");
2186
2187    entry = &functionTable[functionTableIndex++];
2188    entry->ip = target;
2189    entry->gp = (Elf_Addr)gp_val;
2190    return (Elf_Addr)entry;
2191 }
2192
2193 static Elf_Addr
2194 copyFunctionDesc(Elf_Addr target)
2195 {
2196    FunctionDesc *olddesc = (FunctionDesc *)target;
2197    FunctionDesc *newdesc;
2198
2199    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2200    newdesc->gp = olddesc->gp;
2201    return (Elf_Addr)newdesc;
2202 }
2203 #endif
2204
2205 #ifdef ELF_NEED_PLT
2206 #ifdef ia64_TARGET_ARCH
2207 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2208 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2209
2210 static unsigned char plt_code[] =
2211 {
2212    /* taken from binutils bfd/elfxx-ia64.c */
2213    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2214    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2215    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2216    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2217    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2218    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2219 };
2220
2221 /* If we can't get to the function descriptor via gp, take a local copy of it */
2222 #define PLT_RELOC(code, target) { \
2223    Elf64_Sxword rel_value = target - gp_val; \
2224    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2225       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2226    else \
2227       ia64_reloc_gprel22((Elf_Addr)code, target); \
2228    }
2229 #endif
2230
2231 typedef struct {
2232    unsigned char code[sizeof(plt_code)];
2233 } PLTEntry;
2234
2235 static Elf_Addr
2236 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2237 {
2238    PLTEntry *plt = (PLTEntry *)oc->plt;
2239    PLTEntry *entry;
2240
2241    if (oc->pltIndex >= PLT_SIZE)
2242       barf("Procedure table overflow");
2243
2244    entry = &plt[oc->pltIndex++];
2245    memcpy(entry->code, plt_code, sizeof(entry->code));
2246    PLT_RELOC(entry->code, target);
2247    return (Elf_Addr)entry;
2248 }
2249
2250 static unsigned int
2251 PLTSize(void)
2252 {
2253    return (PLT_SIZE * sizeof(PLTEntry));
2254 }
2255 #endif
2256
2257
2258 /*
2259  * Generic ELF functions
2260  */
2261
2262 static char *
2263 findElfSection ( void* objImage, Elf_Word sh_type )
2264 {
2265    char* ehdrC = (char*)objImage;
2266    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2267    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2268    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2269    char* ptr = NULL;
2270    int i;
2271
2272    for (i = 0; i < ehdr->e_shnum; i++) {
2273       if (shdr[i].sh_type == sh_type
2274           /* Ignore the section header's string table. */
2275           && i != ehdr->e_shstrndx
2276           /* Ignore string tables named .stabstr, as they contain
2277              debugging info. */
2278           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2279          ) {
2280          ptr = ehdrC + shdr[i].sh_offset;
2281          break;
2282       }
2283    }
2284    return ptr;
2285 }
2286
2287 #if defined(ia64_TARGET_ARCH)
2288 static Elf_Addr
2289 findElfSegment ( void* objImage, Elf_Addr vaddr )
2290 {
2291    char* ehdrC = (char*)objImage;
2292    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2293    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2294    Elf_Addr segaddr = 0;
2295    int i;
2296
2297    for (i = 0; i < ehdr->e_phnum; i++) {
2298       segaddr = phdr[i].p_vaddr;
2299       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2300               break;
2301    }
2302    return segaddr;
2303 }
2304 #endif
2305
2306 static int
2307 ocVerifyImage_ELF ( ObjectCode* oc )
2308 {
2309    Elf_Shdr* shdr;
2310    Elf_Sym*  stab;
2311    int i, j, nent, nstrtab, nsymtabs;
2312    char* sh_strtab;
2313    char* strtab;
2314
2315    char*     ehdrC = (char*)(oc->image);
2316    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2317
2318    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2319        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2320        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2321        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2322       belch("%s: not an ELF object", oc->fileName);
2323       return 0;
2324    }
2325
2326    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2327       belch("%s: unsupported ELF format", oc->fileName);
2328       return 0;
2329    }
2330
2331    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2332        IF_DEBUG(linker,belch( "Is little-endian" ));
2333    } else
2334    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2335        IF_DEBUG(linker,belch( "Is big-endian" ));
2336    } else {
2337        belch("%s: unknown endiannness", oc->fileName);
2338        return 0;
2339    }
2340
2341    if (ehdr->e_type != ET_REL) {
2342       belch("%s: not a relocatable object (.o) file", oc->fileName);
2343       return 0;
2344    }
2345    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
2346
2347    IF_DEBUG(linker,belch( "Architecture is " ));
2348    switch (ehdr->e_machine) {
2349       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
2350       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
2351 #ifdef EM_IA_64
2352       case EM_IA_64: IF_DEBUG(linker,belch( "ia64" )); break;
2353 #endif
2354       default:       IF_DEBUG(linker,belch( "unknown" ));
2355                      belch("%s: unknown architecture", oc->fileName);
2356                      return 0;
2357    }
2358
2359    IF_DEBUG(linker,belch(
2360              "\nSection header table: start %d, n_entries %d, ent_size %d",
2361              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2362
2363    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2364
2365    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2366
2367    if (ehdr->e_shstrndx == SHN_UNDEF) {
2368       belch("%s: no section header string table", oc->fileName);
2369       return 0;
2370    } else {
2371       IF_DEBUG(linker,belch( "Section header string table is section %d",
2372                           ehdr->e_shstrndx));
2373       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2374    }
2375
2376    for (i = 0; i < ehdr->e_shnum; i++) {
2377       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
2378       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
2379       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
2380       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
2381       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
2382                ehdrC + shdr[i].sh_offset,
2383                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2384
2385       if (shdr[i].sh_type == SHT_REL) {
2386           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
2387       } else if (shdr[i].sh_type == SHT_RELA) {
2388           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
2389       } else {
2390           IF_DEBUG(linker,fprintf(stderr,"     "));
2391       }
2392       if (sh_strtab) {
2393           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
2394       }
2395    }
2396
2397    IF_DEBUG(linker,belch( "\nString tables" ));
2398    strtab = NULL;
2399    nstrtab = 0;
2400    for (i = 0; i < ehdr->e_shnum; i++) {
2401       if (shdr[i].sh_type == SHT_STRTAB
2402           /* Ignore the section header's string table. */
2403           && i != ehdr->e_shstrndx
2404           /* Ignore string tables named .stabstr, as they contain
2405              debugging info. */
2406           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2407          ) {
2408          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
2409          strtab = ehdrC + shdr[i].sh_offset;
2410          nstrtab++;
2411       }
2412    }
2413    if (nstrtab != 1) {
2414       belch("%s: no string tables, or too many", oc->fileName);
2415       return 0;
2416    }
2417
2418    nsymtabs = 0;
2419    IF_DEBUG(linker,belch( "\nSymbol tables" ));
2420    for (i = 0; i < ehdr->e_shnum; i++) {
2421       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2422       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
2423       nsymtabs++;
2424       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2425       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2426       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
2427                nent,
2428                shdr[i].sh_size % sizeof(Elf_Sym)
2429              ));
2430       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2431          belch("%s: non-integral number of symbol table entries", oc->fileName);
2432          return 0;
2433       }
2434       for (j = 0; j < nent; j++) {
2435          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
2436          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
2437                              (int)stab[j].st_shndx,
2438                              (int)stab[j].st_size,
2439                              (char*)stab[j].st_value ));
2440
2441          IF_DEBUG(linker,fprintf(stderr, "type=" ));
2442          switch (ELF_ST_TYPE(stab[j].st_info)) {
2443             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
2444             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
2445             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
2446             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
2447             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
2448             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
2449          }
2450          IF_DEBUG(linker,fprintf(stderr, "  " ));
2451
2452          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
2453          switch (ELF_ST_BIND(stab[j].st_info)) {
2454             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
2455             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
2456             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
2457             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
2458          }
2459          IF_DEBUG(linker,fprintf(stderr, "  " ));
2460
2461          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
2462       }
2463    }
2464
2465    if (nsymtabs == 0) {
2466       belch("%s: didn't find any symbol tables", oc->fileName);
2467       return 0;
2468    }
2469
2470    return 1;
2471 }
2472
2473
2474 static int
2475 ocGetNames_ELF ( ObjectCode* oc )
2476 {
2477    int i, j, k, nent;
2478    Elf_Sym* stab;
2479
2480    char*     ehdrC    = (char*)(oc->image);
2481    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2482    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2483    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2484
2485    ASSERT(symhash != NULL);
2486
2487    if (!strtab) {
2488       belch("%s: no strtab", oc->fileName);
2489       return 0;
2490    }
2491
2492    k = 0;
2493    for (i = 0; i < ehdr->e_shnum; i++) {
2494       /* Figure out what kind of section it is.  Logic derived from
2495          Figure 1.14 ("Special Sections") of the ELF document
2496          ("Portable Formats Specification, Version 1.1"). */
2497       Elf_Shdr    hdr    = shdr[i];
2498       SectionKind kind   = SECTIONKIND_OTHER;
2499       int         is_bss = FALSE;
2500
2501       if (hdr.sh_type == SHT_PROGBITS
2502           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_EXECINSTR)) {
2503          /* .text-style section */
2504          kind = SECTIONKIND_CODE_OR_RODATA;
2505       }
2506       else
2507       if (hdr.sh_type == SHT_PROGBITS
2508           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2509          /* .data-style section */
2510          kind = SECTIONKIND_RWDATA;
2511       }
2512       else
2513       if (hdr.sh_type == SHT_PROGBITS
2514           && (hdr.sh_flags & SHF_ALLOC) && !(hdr.sh_flags & SHF_WRITE)) {
2515          /* .rodata-style section */
2516          kind = SECTIONKIND_CODE_OR_RODATA;
2517       }
2518       else
2519       if (hdr.sh_type == SHT_NOBITS
2520           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2521          /* .bss-style section */
2522          kind = SECTIONKIND_RWDATA;
2523          is_bss = TRUE;
2524       }
2525
2526       if (is_bss && shdr[i].sh_size > 0) {
2527          /* This is a non-empty .bss section.  Allocate zeroed space for
2528             it, and set its .sh_offset field such that
2529             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2530          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2531                                        "ocGetNames_ELF(BSS)");
2532          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2533          /*
2534          fprintf(stderr, "BSS section at 0x%x, size %d\n",
2535                          zspace, shdr[i].sh_size);
2536          */
2537       }
2538
2539       /* fill in the section info */
2540       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2541          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2542          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2543                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2544       }
2545
2546       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2547
2548       /* copy stuff into this module's object symbol table */
2549       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2550       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2551
2552       oc->n_symbols = nent;
2553       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2554                                    "ocGetNames_ELF(oc->symbols)");
2555
2556       for (j = 0; j < nent; j++) {
2557
2558          char  isLocal = FALSE; /* avoids uninit-var warning */
2559          char* ad      = NULL;
2560          char* nm      = strtab + stab[j].st_name;
2561          int   secno   = stab[j].st_shndx;
2562
2563          /* Figure out if we want to add it; if so, set ad to its
2564             address.  Otherwise leave ad == NULL. */
2565
2566          if (secno == SHN_COMMON) {
2567             isLocal = FALSE;
2568             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2569             /*
2570             fprintf(stderr, "COMMON symbol, size %d name %s\n",
2571                             stab[j].st_size, nm);
2572             */
2573             /* Pointless to do addProddableBlock() for this area,
2574                since the linker should never poke around in it. */
2575          }
2576          else
2577          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2578                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2579               )
2580               /* and not an undefined symbol */
2581               && stab[j].st_shndx != SHN_UNDEF
2582               /* and not in a "special section" */
2583               && stab[j].st_shndx < SHN_LORESERVE
2584               &&
2585               /* and it's a not a section or string table or anything silly */
2586               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2587                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2588                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2589               )
2590             ) {
2591             /* Section 0 is the undefined section, hence > and not >=. */
2592             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2593             /*
2594             if (shdr[secno].sh_type == SHT_NOBITS) {
2595                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
2596                                stab[j].st_size, stab[j].st_value, nm);
2597             }
2598             */
2599             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2600             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2601                isLocal = TRUE;
2602             } else {
2603 #ifdef ELF_FUNCTION_DESC
2604                /* dlsym() and the initialisation table both give us function
2605                 * descriptors, so to be consistent we store function descriptors
2606                 * in the symbol table */
2607                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2608                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2609 #endif
2610                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
2611                                       ad, oc->fileName, nm ));
2612                isLocal = FALSE;
2613             }
2614          }
2615
2616          /* And the decision is ... */
2617
2618          if (ad != NULL) {
2619             ASSERT(nm != NULL);
2620             oc->symbols[j] = nm;
2621             /* Acquire! */
2622             if (isLocal) {
2623                /* Ignore entirely. */
2624             } else {
2625                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2626             }
2627          } else {
2628             /* Skip. */
2629             IF_DEBUG(linker,belch( "skipping `%s'",
2630                                    strtab + stab[j].st_name ));
2631             /*
2632             fprintf(stderr,
2633                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2634                     (int)ELF_ST_BIND(stab[j].st_info),
2635                     (int)ELF_ST_TYPE(stab[j].st_info),
2636                     (int)stab[j].st_shndx,
2637                     strtab + stab[j].st_name
2638                    );
2639             */
2640             oc->symbols[j] = NULL;
2641          }
2642
2643       }
2644    }
2645
2646    return 1;
2647 }
2648
2649 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2650    relocations appear to be of this form. */
2651 static int
2652 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2653                          Elf_Shdr* shdr, int shnum,
2654                          Elf_Sym*  stab, char* strtab )
2655 {
2656    int j;
2657    char *symbol;
2658    Elf_Word* targ;
2659    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
2660    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
2661    int target_shndx = shdr[shnum].sh_info;
2662    int symtab_shndx = shdr[shnum].sh_link;
2663
2664    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2665    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2666    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2667                           target_shndx, symtab_shndx ));
2668
2669    for (j = 0; j < nent; j++) {
2670       Elf_Addr offset = rtab[j].r_offset;
2671       Elf_Addr info   = rtab[j].r_info;
2672
2673       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
2674       Elf_Word* pP = (Elf_Word*)P;
2675       Elf_Addr  A  = *pP;
2676       Elf_Addr  S;
2677       Elf_Addr  value;
2678
2679       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
2680                              j, (void*)offset, (void*)info ));
2681       if (!info) {
2682          IF_DEBUG(linker,belch( " ZERO" ));
2683          S = 0;
2684       } else {
2685          Elf_Sym sym = stab[ELF_R_SYM(info)];
2686          /* First see if it is a local symbol. */
2687          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2688             /* Yes, so we can get the address directly from the ELF symbol
2689                table. */
2690             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2691             S = (Elf_Addr)
2692                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2693                        + stab[ELF_R_SYM(info)].st_value);
2694
2695          } else {
2696             /* No, so look up the name in our global table. */
2697             symbol = strtab + sym.st_name;
2698             (void*)S = lookupSymbol( symbol );
2699          }
2700          if (!S) {
2701             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2702             return 0;
2703          }
2704          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2705       }
2706
2707       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2708                              (void*)P, (void*)S, (void*)A ));
2709       checkProddableBlock ( oc, pP );
2710
2711       value = S + A;
2712
2713       switch (ELF_R_TYPE(info)) {
2714 #        ifdef i386_TARGET_ARCH
2715          case R_386_32:   *pP = value;     break;
2716          case R_386_PC32: *pP = value - P; break;
2717 #        endif
2718          default:
2719             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2720                   oc->fileName, ELF_R_TYPE(info));
2721             return 0;
2722       }
2723
2724    }
2725    return 1;
2726 }
2727
2728 /* Do ELF relocations for which explicit addends are supplied.
2729    sparc-solaris relocations appear to be of this form. */
2730 static int
2731 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2732                           Elf_Shdr* shdr, int shnum,
2733                           Elf_Sym*  stab, char* strtab )
2734 {
2735    int j;
2736    char *symbol;
2737    Elf_Addr targ;
2738    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
2739    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
2740    int target_shndx = shdr[shnum].sh_info;
2741    int symtab_shndx = shdr[shnum].sh_link;
2742
2743    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2744    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
2745    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2746                           target_shndx, symtab_shndx ));
2747
2748    for (j = 0; j < nent; j++) {
2749 #if defined(DEBUG) || defined(sparc_TARGET_ARCH) || defined(ia64_TARGET_ARCH)
2750       /* This #ifdef only serves to avoid unused-var warnings. */
2751       Elf_Addr  offset = rtab[j].r_offset;
2752       Elf_Addr  P      = targ + offset;
2753 #endif
2754       Elf_Addr  info   = rtab[j].r_info;
2755       Elf_Addr  A      = rtab[j].r_addend;
2756       Elf_Addr  S;
2757       Elf_Addr  value;
2758 #     if defined(sparc_TARGET_ARCH)
2759       Elf_Word* pP = (Elf_Word*)P;
2760       Elf_Word  w1, w2;
2761 #     elif defined(ia64_TARGET_ARCH)
2762       Elf64_Xword *pP = (Elf64_Xword *)P;
2763       Elf_Addr addr;
2764 #     endif
2765
2766       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2767                              j, (void*)offset, (void*)info,
2768                                 (void*)A ));
2769       if (!info) {
2770          IF_DEBUG(linker,belch( " ZERO" ));
2771          S = 0;
2772       } else {
2773          Elf_Sym sym = stab[ELF_R_SYM(info)];
2774          /* First see if it is a local symbol. */
2775          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2776             /* Yes, so we can get the address directly from the ELF symbol
2777                table. */
2778             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2779             S = (Elf_Addr)
2780                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2781                        + stab[ELF_R_SYM(info)].st_value);
2782 #ifdef ELF_FUNCTION_DESC
2783             /* Make a function descriptor for this function */
2784             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
2785                S = allocateFunctionDesc(S + A);
2786                A = 0;
2787             }
2788 #endif
2789          } else {
2790             /* No, so look up the name in our global table. */
2791             symbol = strtab + sym.st_name;
2792             (void*)S = lookupSymbol( symbol );
2793
2794 #ifdef ELF_FUNCTION_DESC
2795             /* If a function, already a function descriptor - we would
2796                have to copy it to add an offset. */
2797             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
2798                belch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
2799 #endif
2800          }
2801          if (!S) {
2802            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2803            return 0;
2804          }
2805          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2806       }
2807
2808       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2809                                         (void*)P, (void*)S, (void*)A ));
2810       /* checkProddableBlock ( oc, (void*)P ); */
2811
2812       value = S + A;
2813
2814       switch (ELF_R_TYPE(info)) {
2815 #        if defined(sparc_TARGET_ARCH)
2816          case R_SPARC_WDISP30:
2817             w1 = *pP & 0xC0000000;
2818             w2 = (Elf_Word)((value - P) >> 2);
2819             ASSERT((w2 & 0xC0000000) == 0);
2820             w1 |= w2;
2821             *pP = w1;
2822             break;
2823          case R_SPARC_HI22:
2824             w1 = *pP & 0xFFC00000;
2825             w2 = (Elf_Word)(value >> 10);
2826             ASSERT((w2 & 0xFFC00000) == 0);
2827             w1 |= w2;
2828             *pP = w1;
2829             break;
2830          case R_SPARC_LO10:
2831             w1 = *pP & ~0x3FF;
2832             w2 = (Elf_Word)(value & 0x3FF);
2833             ASSERT((w2 & ~0x3FF) == 0);
2834             w1 |= w2;
2835             *pP = w1;
2836             break;
2837          /* According to the Sun documentation:
2838             R_SPARC_UA32
2839             This relocation type resembles R_SPARC_32, except it refers to an
2840             unaligned word. That is, the word to be relocated must be treated
2841             as four separate bytes with arbitrary alignment, not as a word
2842             aligned according to the architecture requirements.
2843
2844             (JRS: which means that freeloading on the R_SPARC_32 case
2845             is probably wrong, but hey ...)
2846          */
2847          case R_SPARC_UA32:
2848          case R_SPARC_32:
2849             w2 = (Elf_Word)value;
2850             *pP = w2;
2851             break;
2852 #        elif defined(ia64_TARGET_ARCH)
2853          case R_IA64_DIR64LSB:
2854          case R_IA64_FPTR64LSB:
2855             *pP = value;
2856             break;
2857          case R_IA64_PCREL64LSB:
2858             *pP = value - P;
2859             break;
2860          case R_IA64_SEGREL64LSB:
2861             addr = findElfSegment(ehdrC, value);
2862             *pP = value - addr;
2863             break;
2864          case R_IA64_GPREL22:
2865             ia64_reloc_gprel22(P, value);
2866             break;
2867          case R_IA64_LTOFF22:
2868          case R_IA64_LTOFF22X:
2869          case R_IA64_LTOFF_FPTR22:
2870             addr = allocateGOTEntry(value);
2871             ia64_reloc_gprel22(P, addr);
2872             break;
2873          case R_IA64_PCREL21B:
2874             ia64_reloc_pcrel21(P, S, oc);
2875             break;
2876          case R_IA64_LDXMOV:
2877             /* This goes with R_IA64_LTOFF22X and points to the load to
2878              * convert into a move.  We don't implement relaxation. */
2879             break;
2880 #        endif
2881          default:
2882             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2883                   oc->fileName, ELF_R_TYPE(info));
2884             return 0;
2885       }
2886
2887    }
2888    return 1;
2889 }
2890
2891 static int
2892 ocResolve_ELF ( ObjectCode* oc )
2893 {
2894    char *strtab;
2895    int   shnum, ok;
2896    Elf_Sym*  stab  = NULL;
2897    char*     ehdrC = (char*)(oc->image);
2898    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
2899    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2900    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2901
2902    /* first find "the" symbol table */
2903    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2904
2905    /* also go find the string table */
2906    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2907
2908    if (stab == NULL || strtab == NULL) {
2909       belch("%s: can't find string or symbol table", oc->fileName);
2910       return 0;
2911    }
2912
2913    /* Process the relocation sections. */
2914    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2915
2916       /* Skip sections called ".rel.stab".  These appear to contain
2917          relocation entries that, when done, make the stabs debugging
2918          info point at the right places.  We ain't interested in all
2919          dat jazz, mun. */
2920       if (0 == memcmp(".rel.stab", sh_strtab + shdr[shnum].sh_name, 9))
2921          continue;
2922
2923       if (shdr[shnum].sh_type == SHT_REL ) {
2924          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
2925                                        shnum, stab, strtab );
2926          if (!ok) return ok;
2927       }
2928       else
2929       if (shdr[shnum].sh_type == SHT_RELA) {
2930          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
2931                                         shnum, stab, strtab );
2932          if (!ok) return ok;
2933       }
2934    }
2935
2936    /* Free the local symbol table; we won't need it again. */
2937    freeHashTable(oc->lochash, NULL);
2938    oc->lochash = NULL;
2939
2940    return 1;
2941 }
2942
2943 /*
2944  * IA64 specifics
2945  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
2946  * at the front.  The following utility functions pack and unpack instructions, and
2947  * take care of the most common relocations.
2948  */
2949
2950 #ifdef ia64_TARGET_ARCH
2951
2952 static Elf64_Xword
2953 ia64_extract_instruction(Elf64_Xword *target)
2954 {
2955    Elf64_Xword w1, w2;
2956    int slot = (Elf_Addr)target & 3;
2957    (Elf_Addr)target &= ~3;
2958
2959    w1 = *target;
2960    w2 = *(target+1);
2961
2962    switch (slot)
2963    {
2964       case 0:
2965          return ((w1 >> 5) & 0x1ffffffffff);
2966       case 1:
2967          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
2968       case 2:
2969          return (w2 >> 23);
2970       default:
2971          barf("ia64_extract_instruction: invalid slot %p", target);
2972    }
2973 }
2974
2975 static void
2976 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
2977 {
2978    int slot = (Elf_Addr)target & 3;
2979    (Elf_Addr)target &= ~3;
2980
2981    switch (slot)
2982    {
2983       case 0:
2984          *target |= value << 5;
2985          break;
2986       case 1:
2987          *target |= value << 46;
2988          *(target+1) |= value >> 18;
2989          break;
2990       case 2:
2991          *(target+1) |= value << 23;
2992          break;
2993    }
2994 }
2995
2996 static void
2997 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
2998 {
2999    Elf64_Xword instruction;
3000    Elf64_Sxword rel_value;
3001
3002    rel_value = value - gp_val;
3003    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3004       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3005
3006    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3007    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3008                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3009                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3010                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3011    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3012 }
3013
3014 static void
3015 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3016 {
3017    Elf64_Xword instruction;
3018    Elf64_Sxword rel_value;
3019    Elf_Addr entry;
3020
3021    entry = allocatePLTEntry(value, oc);
3022
3023    rel_value = (entry >> 4) - (target >> 4);
3024    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3025       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3026
3027    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3028    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3029                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3030    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3031 }
3032
3033 #endif /* ia64 */
3034
3035 #endif /* ELF */
3036
3037 /* --------------------------------------------------------------------------
3038  * Mach-O specifics
3039  * ------------------------------------------------------------------------*/
3040
3041 #if defined(OBJFORMAT_MACHO)
3042
3043 /*
3044   Support for MachO linking on Darwin/MacOS X on PowerPC chips
3045   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3046
3047   I hereby formally apologize for the hackish nature of this code.
3048   Things that need to be done:
3049   *) implement ocVerifyImage_MachO
3050   *) add still more sanity checks.
3051 */
3052
3053
3054 /*
3055   ocAllocateJumpIslands_MachO
3056
3057   Allocate additional space at the end of the object file image to make room
3058   for jump islands.
3059
3060   PowerPC relative branch instructions have a 24 bit displacement field.
3061   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
3062   If a particular imported symbol is outside this range, we have to redirect
3063   the jump to a short piece of new code that just loads the 32bit absolute
3064   address and jumps there.
3065   This function just allocates space for one 16 byte jump island for every
3066   undefined symbol in the object file. The code for the islands is filled in by
3067   makeJumpIsland below.
3068 */
3069
3070 static const int islandSize = 16;
3071
3072 static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
3073 {
3074     char *image = (char*) oc->image;
3075     struct mach_header *header = (struct mach_header*) image;
3076     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3077     unsigned i;
3078
3079     for(i=0;i<header->ncmds;i++)
3080     {
3081         if(lc->cmd == LC_DYSYMTAB)
3082         {
3083             struct dysymtab_command *dsymLC = (struct dysymtab_command*) lc;
3084             unsigned long nundefsym = dsymLC->nundefsym;
3085             oc->island_start_symbol = dsymLC->iundefsym;
3086             oc->n_islands = nundefsym;
3087
3088             if(nundefsym > 0)
3089             {
3090 #ifdef USE_MMAP
3091                 #error ocAllocateJumpIslands_MachO doesnt want USE_MMAP to be defined
3092 #else
3093                 oc->image = stgReallocBytes(
3094                     image, oc->fileSize + islandSize * nundefsym,
3095                     "ocAllocateJumpIslands_MachO");
3096 #endif
3097                 oc->jump_islands = oc->image + oc->fileSize;
3098                 memset(oc->jump_islands, 0, islandSize * nundefsym);
3099             }
3100
3101             break;  // there can be only one LC_DSYMTAB
3102         }
3103         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3104     }
3105     return 1;
3106 }
3107
3108 static int ocVerifyImage_MachO(ObjectCode* oc)
3109 {
3110     // FIXME: do some verifying here
3111     return 1;
3112 }
3113
3114 static int resolveImports(
3115     ObjectCode* oc,
3116     char *image,
3117     struct symtab_command *symLC,
3118     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3119     unsigned long *indirectSyms,
3120     struct nlist *nlist)
3121 {
3122     unsigned i;
3123
3124     for(i=0;i*4<sect->size;i++)
3125     {
3126         // according to otool, reserved1 contains the first index into the indirect symbol table
3127         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3128         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3129         void *addr = NULL;
3130
3131         if((symbol->n_type & N_TYPE) == N_UNDF
3132             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3133             addr = (void*) (symbol->n_value);
3134         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3135             ;
3136         else
3137             addr = lookupSymbol(nm);
3138         if(!addr)
3139         {
3140             belch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3141             return 0;
3142         }
3143         ASSERT(addr);
3144         checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3145         ((void**)(image + sect->offset))[i] = addr;
3146     }
3147
3148     return 1;
3149 }
3150
3151 static void* makeJumpIsland(
3152     ObjectCode* oc,
3153     unsigned long symbolNumber,
3154     void* target)
3155 {
3156     if(symbolNumber < oc->island_start_symbol ||
3157         symbolNumber - oc->island_start_symbol > oc->n_islands)
3158         return NULL;
3159     symbolNumber -= oc->island_start_symbol;
3160
3161     void *island = (void*) ((char*)oc->jump_islands + islandSize * symbolNumber);
3162     unsigned long *p = (unsigned long*) island;
3163
3164         // lis r12, hi16(target)
3165     *p++ = 0x3d800000 | ( ((unsigned long) target) >> 16 );
3166         // ori r12, r12, lo16(target)
3167     *p++ = 0x618c0000 | ( ((unsigned long) target) & 0xFFFF );
3168         // mtctr r12
3169     *p++ = 0x7d8903a6;
3170         // bctr
3171     *p++ = 0x4e800420;
3172
3173     return (void*) island;
3174 }
3175
3176 static char* relocateAddress(
3177     ObjectCode* oc,
3178     int nSections,
3179     struct section* sections,
3180     unsigned long address)
3181 {
3182     int i;
3183     for(i = 0; i < nSections; i++)
3184     {
3185         if(sections[i].addr <= address
3186             && address < sections[i].addr + sections[i].size)
3187         {
3188             return oc->image + sections[i].offset + address - sections[i].addr;
3189         }
3190     }
3191     barf("Invalid Mach-O file:"
3192          "Address out of bounds while relocating object file");
3193     return NULL;
3194 }
3195
3196 static int relocateSection(
3197     ObjectCode* oc,
3198     char *image,
3199     struct symtab_command *symLC, struct nlist *nlist,
3200     int nSections, struct section* sections, struct section *sect)
3201 {
3202     struct relocation_info *relocs;
3203     int i,n;
3204
3205     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3206         return 1;
3207     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3208         return 1;
3209
3210     n = sect->nreloc;
3211     relocs = (struct relocation_info*) (image + sect->reloff);
3212
3213     for(i=0;i<n;i++)
3214     {
3215         if(relocs[i].r_address & R_SCATTERED)
3216         {
3217             struct scattered_relocation_info *scat =
3218                 (struct scattered_relocation_info*) &relocs[i];
3219
3220             if(!scat->r_pcrel)
3221             {
3222                 if(scat->r_length == 2)
3223                 {
3224                     unsigned long word = 0;
3225                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
3226                     checkProddableBlock(oc,wordPtr);
3227
3228                     // Step 1: Figure out what the relocated value should be
3229                     if(scat->r_type == GENERIC_RELOC_VANILLA)
3230                     {
3231                         word = scat->r_value + sect->offset + ((long) image);
3232                     }
3233                     else if(scat->r_type == PPC_RELOC_SECTDIFF
3234                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
3235                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
3236                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3237                     {
3238                         struct scattered_relocation_info *pair =
3239                                 (struct scattered_relocation_info*) &relocs[i+1];
3240
3241                         if(!pair->r_scattered || pair->r_type != PPC_RELOC_PAIR)
3242                             barf("Invalid Mach-O file: "
3243                                  "PPC_RELOC_*_SECTDIFF not followed by PPC_RELOC_PAIR");
3244
3245                         word = (unsigned long)
3246                                (relocateAddress(oc, nSections, sections, scat->r_value)
3247                               - relocateAddress(oc, nSections, sections, pair->r_value));
3248                         i++;
3249                     }
3250                     else
3251                         continue;  // ignore the others
3252
3253                     if(scat->r_type == GENERIC_RELOC_VANILLA
3254                         || scat->r_type == PPC_RELOC_SECTDIFF)
3255                     {
3256                         *wordPtr = word;
3257                     }
3258                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF)
3259                     {
3260                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3261                     }
3262                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF)
3263                     {
3264                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3265                     }
3266                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3267                     {
3268                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3269                             + ((word & (1<<15)) ? 1 : 0);
3270                     }
3271                 }
3272             }
3273
3274             continue; // FIXME: I hope it's OK to ignore all the others.
3275         }
3276         else
3277         {
3278             struct relocation_info *reloc = &relocs[i];
3279             if(reloc->r_pcrel && !reloc->r_extern)
3280                 continue;
3281
3282             if(reloc->r_length == 2)
3283             {
3284                 unsigned long word = 0;
3285                 unsigned long jumpIsland = 0;
3286                 long offsetToJumpIsland;
3287
3288                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
3289                 checkProddableBlock(oc,wordPtr);
3290
3291                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3292                 {
3293                     word = *wordPtr;
3294                 }
3295                 else if(reloc->r_type == PPC_RELOC_LO16)
3296                 {
3297                     word = ((unsigned short*) wordPtr)[1];
3298                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3299                 }
3300                 else if(reloc->r_type == PPC_RELOC_HI16)
3301                 {
3302                     word = ((unsigned short*) wordPtr)[1] << 16;
3303                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3304                 }
3305                 else if(reloc->r_type == PPC_RELOC_HA16)
3306                 {
3307                     word = ((unsigned short*) wordPtr)[1] << 16;
3308                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3309                 }
3310                 else if(reloc->r_type == PPC_RELOC_BR24)
3311                 {
3312                     word = *wordPtr;
3313                     word = (word & 0x03FFFFFC) | (word & 0x02000000) ? 0xFC000000 : 0;
3314                 }
3315
3316
3317                 if(!reloc->r_extern)
3318                 {
3319                     long delta =
3320                         sections[reloc->r_symbolnum-1].offset
3321                         - sections[reloc->r_symbolnum-1].addr
3322                         + ((long) image);
3323
3324                     word += delta;
3325                 }
3326                 else
3327                 {
3328                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3329                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3330                     word = (unsigned long) (lookupSymbol(nm));
3331                     if(!word)
3332                     {
3333                         belch("\nunknown symbol `%s'", nm);
3334                         return 0;
3335                     }
3336
3337                     if(reloc->r_pcrel)
3338                     {
3339                         jumpIsland = (long) makeJumpIsland(oc,reloc->r_symbolnum,(void*)word);
3340                         word -= ((long)image) + sect->offset + reloc->r_address;
3341                         if(jumpIsland != 0)
3342                         {
3343                             offsetToJumpIsland = jumpIsland
3344                                 - (((long)image) + sect->offset + reloc->r_address);
3345                         }
3346                     }
3347                 }
3348
3349                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3350                 {
3351                     *wordPtr = word;
3352                     continue;
3353                 }
3354                 else if(reloc->r_type == PPC_RELOC_LO16)
3355                 {
3356                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3357                     i++; continue;
3358                 }
3359                 else if(reloc->r_type == PPC_RELOC_HI16)
3360                 {
3361                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3362                     i++; continue;
3363                 }
3364                 else if(reloc->r_type == PPC_RELOC_HA16)
3365                 {
3366                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3367                         + ((word & (1<<15)) ? 1 : 0);
3368                     i++; continue;
3369                 }
3370                 else if(reloc->r_type == PPC_RELOC_BR24)
3371                 {
3372                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3373                     {
3374                         // The branch offset is too large.
3375                         // Therefore, we try to use a jump island.
3376                         if(jumpIsland == 0)
3377                             barf("unconditional relative branch out of range: "
3378                                  "no jump island available");
3379
3380                         word = offsetToJumpIsland;
3381                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3382                             barf("unconditional relative branch out of range: "
3383                                  "jump island out of range");
3384                     }
3385                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
3386                     continue;
3387                 }
3388             }
3389             barf("\nunknown relocation %d",reloc->r_type);
3390             return 0;
3391         }
3392     }
3393     return 1;
3394 }
3395
3396 static int ocGetNames_MachO(ObjectCode* oc)
3397 {
3398     char *image = (char*) oc->image;
3399     struct mach_header *header = (struct mach_header*) image;
3400     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3401     unsigned i,curSymbol;
3402     struct segment_command *segLC = NULL;
3403     struct section *sections;
3404     struct symtab_command *symLC = NULL;
3405     struct dysymtab_command *dsymLC = NULL;
3406     struct nlist *nlist;
3407     unsigned long commonSize = 0;
3408     char    *commonStorage = NULL;
3409     unsigned long commonCounter;
3410
3411     for(i=0;i<header->ncmds;i++)
3412     {
3413         if(lc->cmd == LC_SEGMENT)
3414             segLC = (struct segment_command*) lc;
3415         else if(lc->cmd == LC_SYMTAB)
3416             symLC = (struct symtab_command*) lc;
3417         else if(lc->cmd == LC_DYSYMTAB)
3418             dsymLC = (struct dysymtab_command*) lc;
3419         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3420     }
3421
3422     sections = (struct section*) (segLC+1);
3423     nlist = (struct nlist*) (image + symLC->symoff);
3424
3425     for(i=0;i<segLC->nsects;i++)
3426     {
3427         if(sections[i].size == 0)
3428             continue;
3429
3430         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
3431         {
3432             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
3433                                       "ocGetNames_MachO(common symbols)");
3434             sections[i].offset = zeroFillArea - image;
3435         }
3436
3437         if(!strcmp(sections[i].sectname,"__text"))
3438             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3439                 (void*) (image + sections[i].offset),
3440                 (void*) (image + sections[i].offset + sections[i].size));
3441         else if(!strcmp(sections[i].sectname,"__const"))
3442             addSection(oc, SECTIONKIND_RWDATA,
3443                 (void*) (image + sections[i].offset),
3444                 (void*) (image + sections[i].offset + sections[i].size));
3445         else if(!strcmp(sections[i].sectname,"__data"))
3446             addSection(oc, SECTIONKIND_RWDATA,
3447                 (void*) (image + sections[i].offset),
3448                 (void*) (image + sections[i].offset + sections[i].size));
3449         else if(!strcmp(sections[i].sectname,"__bss")
3450                 || !strcmp(sections[i].sectname,"__common"))
3451             addSection(oc, SECTIONKIND_RWDATA,
3452                 (void*) (image + sections[i].offset),
3453                 (void*) (image + sections[i].offset + sections[i].size));
3454
3455         addProddableBlock(oc, (void*) (image + sections[i].offset),
3456                                         sections[i].size);
3457     }
3458
3459         // count external symbols defined here
3460     oc->n_symbols = 0;
3461     for(i=dsymLC->iextdefsym;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3462     {
3463         if((nlist[i].n_type & N_TYPE) == N_SECT)
3464             oc->n_symbols++;
3465     }
3466     for(i=0;i<symLC->nsyms;i++)
3467     {
3468         if((nlist[i].n_type & N_TYPE) == N_UNDF
3469                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3470         {
3471             commonSize += nlist[i].n_value;
3472             oc->n_symbols++;
3473         }
3474     }
3475     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3476                                    "ocGetNames_MachO(oc->symbols)");
3477
3478         // insert symbols into hash table
3479     for(i=dsymLC->iextdefsym,curSymbol=0;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3480     {
3481         if((nlist[i].n_type & N_TYPE) == N_SECT)
3482         {
3483             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3484             ghciInsertStrHashTable(oc->fileName, symhash, nm, image +
3485                 sections[nlist[i].n_sect-1].offset
3486                 - sections[nlist[i].n_sect-1].addr
3487                 + nlist[i].n_value);
3488             oc->symbols[curSymbol++] = nm;
3489         }
3490     }
3491
3492         // insert local symbols into lochash
3493     for(i=dsymLC->ilocalsym;i<dsymLC->ilocalsym+dsymLC->nlocalsym;i++)
3494     {
3495         if((nlist[i].n_type & N_TYPE) == N_SECT)
3496         {
3497             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3498             ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, image +
3499                 sections[nlist[i].n_sect-1].offset
3500                 - sections[nlist[i].n_sect-1].addr
3501                 + nlist[i].n_value);
3502         }
3503     }
3504
3505
3506     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
3507     commonCounter = (unsigned long)commonStorage;
3508     for(i=0;i<symLC->nsyms;i++)
3509     {
3510         if((nlist[i].n_type & N_TYPE) == N_UNDF
3511                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3512         {
3513             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3514             unsigned long sz = nlist[i].n_value;
3515
3516             nlist[i].n_value = commonCounter;
3517
3518             ghciInsertStrHashTable(oc->fileName, symhash, nm, (void*)commonCounter);
3519             oc->symbols[curSymbol++] = nm;
3520
3521             commonCounter += sz;
3522         }
3523     }
3524     return 1;
3525 }
3526
3527 static int ocResolve_MachO(ObjectCode* oc)
3528 {
3529     char *image = (char*) oc->image;
3530     struct mach_header *header = (struct mach_header*) image;
3531     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3532     unsigned i;
3533     struct segment_command *segLC = NULL;
3534     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3535     struct symtab_command *symLC = NULL;
3536     struct dysymtab_command *dsymLC = NULL;
3537     struct nlist *nlist;
3538     unsigned long *indirectSyms;
3539
3540     for(i=0;i<header->ncmds;i++)
3541     {
3542         if(lc->cmd == LC_SEGMENT)
3543             segLC = (struct segment_command*) lc;
3544         else if(lc->cmd == LC_SYMTAB)
3545             symLC = (struct symtab_command*) lc;
3546         else if(lc->cmd == LC_DYSYMTAB)
3547             dsymLC = (struct dysymtab_command*) lc;
3548         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3549     }
3550
3551     sections = (struct section*) (segLC+1);
3552     nlist = (struct nlist*) (image + symLC->symoff);
3553
3554     for(i=0;i<segLC->nsects;i++)
3555     {
3556         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3557             la_ptrs = &sections[i];
3558         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3559             nl_ptrs = &sections[i];
3560     }
3561
3562     indirectSyms = (unsigned long*) (image + dsymLC->indirectsymoff);
3563
3564     if(la_ptrs)
3565         if(!resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist))
3566             return 0;
3567     if(nl_ptrs)
3568         if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
3569             return 0;
3570
3571     for(i=0;i<segLC->nsects;i++)
3572     {
3573         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
3574             return 0;
3575     }
3576
3577     /* Free the local symbol table; we won't need it again. */
3578     freeHashTable(oc->lochash, NULL);
3579     oc->lochash = NULL;
3580
3581     /*
3582         Flush the data & instruction caches.
3583         Because the PPC has split data/instruction caches, we have to
3584         do that whenever we modify code at runtime.
3585     */
3586     {
3587         int n = (oc->fileSize + islandSize * oc->n_islands) / 4;
3588         unsigned long *p = (unsigned long*)oc->image;
3589         while(n--)
3590         {
3591             __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
3592                                 : : "r" (p));
3593             p++;
3594         }
3595         __asm__ volatile ("sync\n\tisync");
3596     }
3597     return 1;
3598 }
3599
3600 /*
3601  * The Mach-O object format uses leading underscores. But not everywhere.
3602  * There is a small number of runtime support functions defined in
3603  * libcc_dynamic.a whose name does not have a leading underscore.
3604  * As a consequence, we can't get their address from C code.
3605  * We have to use inline assembler just to take the address of a function.
3606  * Yuck.
3607  */
3608
3609 static void machoInitSymbolsWithoutUnderscore()
3610 {
3611     void *p;
3612
3613 #undef Sym
3614 #define Sym(x)                                          \
3615     __asm__ ("lis %0,hi16(" #x ")\n\tori %0,%0,lo16(" #x ")" : "=r" (p));       \
3616     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, p);
3617
3618     RTS_MACHO_NOUNDERLINE_SYMBOLS
3619
3620 }
3621 #endif