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