ghc/rts/Linker.c

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