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 static int
2445 findElfSectionIndexByName( ObjectCode *oc, const char *sh_name,
2446                            Elf_Word expected_type, Elf_Word expected_entsize )
2447 {
2448   Elf_Ehdr *ehdr = (Elf_Ehdr *) oc->image;
2449   Elf_Shdr *shdr = (Elf_Shdr *) (oc->image + ehdr->e_shoff);
2450   char *sectnames = oc->image + shdr[ehdr->e_shstrndx].sh_offset;
2451   int i;
2452
2453   for( i = 0; i < ehdr->e_shnum; i++ )
2454     if( !strcmp( sectnames + shdr[i].sh_name, sh_name ) )
2455     {
2456       if( shdr[i].sh_type != expected_type )
2457       {
2458         errorBelch( "The entry type (%d) of the '%s' section isn't %d\n",
2459                     shdr[i].sh_type, sh_name, expected_type );
2460         return -1;
2461       }
2462
2463       if( shdr[i].sh_entsize != expected_entsize )
2464       {
2465         errorBelch( "The entry size (%d) of the '%s' section isn't %d\n",
2466                     shdr[i].sh_entsize, sh_name, expected_entsize );
2467
2468         return -1;
2469       }
2470
2471       return i;
2472     }
2473
2474   errorBelch( "This ELF file contains no '%s' section", sh_name );
2475   return -1;
2476 }
2477
2478 static char *
2479 findElfSectionByName( ObjectCode *oc, const char *sh_name,
2480                       Elf_Word expected_type, int expected_entsize,
2481                       int *num_entries )
2482 {
2483   Elf_Ehdr *ehdr = (Elf_Ehdr *) oc->image;
2484   Elf_Shdr *shdr = (Elf_Shdr *) (oc->image + ehdr->e_shoff);
2485   int section;
2486
2487   section = findElfSectionIndexByName( oc, sh_name, expected_type,
2488                                        expected_entsize );
2489
2490   if( section < 0 )
2491     return NULL;
2492
2493   /* allow for meaningful results in num_entries even when entsize is 0 */
2494   if( expected_entsize == 0 )
2495     expected_entsize = 1;
2496
2497   if( num_entries )
2498     *num_entries = shdr[section].sh_size / expected_entsize;
2499
2500   return oc->image + shdr[section].sh_offset;
2501 }
2502
2503 #if defined(ia64_HOST_ARCH)
2504 static Elf_Addr
2505 findElfSegment ( void* objImage, Elf_Addr vaddr )
2506 {
2507    char* ehdrC = (char*)objImage;
2508    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2509    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2510    Elf_Addr segaddr = 0;
2511    int i;
2512
2513    for (i = 0; i < ehdr->e_phnum; i++) {
2514       segaddr = phdr[i].p_vaddr;
2515       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2516               break;
2517    }
2518    return segaddr;
2519 }
2520 #endif
2521
2522 static int
2523 ocVerifyImage_ELF ( ObjectCode* oc )
2524 {
2525    Elf_Shdr* shdr;
2526    Elf_Sym*  stab;
2527    int i, j, nent, nstrtab, nsymtabs;
2528    char* sh_strtab;
2529    char* strtab;
2530
2531    char*     ehdrC = (char*)(oc->image);
2532    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2533
2534    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2535        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2536        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2537        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2538       errorBelch("%s: not an ELF object", oc->fileName);
2539       return 0;
2540    }
2541
2542    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2543       errorBelch("%s: unsupported ELF format", oc->fileName);
2544       return 0;
2545    }
2546
2547    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2548        IF_DEBUG(linker,debugBelch( "Is little-endian\n" ));
2549    } else
2550    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2551        IF_DEBUG(linker,debugBelch( "Is big-endian\n" ));
2552    } else {
2553        errorBelch("%s: unknown endiannness", oc->fileName);
2554        return 0;
2555    }
2556
2557    if (ehdr->e_type != ET_REL) {
2558       errorBelch("%s: not a relocatable object (.o) file", oc->fileName);
2559       return 0;
2560    }
2561    IF_DEBUG(linker, debugBelch( "Is a relocatable object (.o) file\n" ));
2562
2563    IF_DEBUG(linker,debugBelch( "Architecture is " ));
2564    switch (ehdr->e_machine) {
2565       case EM_386:   IF_DEBUG(linker,debugBelch( "x86" )); break;
2566       case EM_SPARC: IF_DEBUG(linker,debugBelch( "sparc" )); break;
2567 #ifdef EM_IA_64
2568       case EM_IA_64: IF_DEBUG(linker,debugBelch( "ia64" )); break;
2569 #endif
2570       case EM_PPC:   IF_DEBUG(linker,debugBelch( "powerpc32" )); break;
2571       default:       IF_DEBUG(linker,debugBelch( "unknown" ));
2572                      errorBelch("%s: unknown architecture", oc->fileName);
2573                      return 0;
2574    }
2575
2576    IF_DEBUG(linker,debugBelch(
2577              "\nSection header table: start %d, n_entries %d, ent_size %d\n",
2578              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2579
2580    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2581
2582    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2583
2584    if (ehdr->e_shstrndx == SHN_UNDEF) {
2585       errorBelch("%s: no section header string table", oc->fileName);
2586       return 0;
2587    } else {
2588       IF_DEBUG(linker,debugBelch( "Section header string table is section %d\n",
2589                           ehdr->e_shstrndx));
2590       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2591    }
2592
2593    for (i = 0; i < ehdr->e_shnum; i++) {
2594       IF_DEBUG(linker,debugBelch("%2d:  ", i ));
2595       IF_DEBUG(linker,debugBelch("type=%2d  ", (int)shdr[i].sh_type ));
2596       IF_DEBUG(linker,debugBelch("size=%4d  ", (int)shdr[i].sh_size ));
2597       IF_DEBUG(linker,debugBelch("offs=%4d  ", (int)shdr[i].sh_offset ));
2598       IF_DEBUG(linker,debugBelch("  (%p .. %p)  ",
2599                ehdrC + shdr[i].sh_offset,
2600                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2601
2602       if (shdr[i].sh_type == SHT_REL) {
2603           IF_DEBUG(linker,debugBelch("Rel  " ));
2604       } else if (shdr[i].sh_type == SHT_RELA) {
2605           IF_DEBUG(linker,debugBelch("RelA " ));
2606       } else {
2607           IF_DEBUG(linker,debugBelch("     "));
2608       }
2609       if (sh_strtab) {
2610           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
2611       }
2612    }
2613
2614    IF_DEBUG(linker,debugBelch( "\nString tables" ));
2615    strtab = NULL;
2616    nstrtab = 0;
2617    for (i = 0; i < ehdr->e_shnum; i++) {
2618       if (shdr[i].sh_type == SHT_STRTAB
2619           /* Ignore the section header's string table. */
2620           && i != ehdr->e_shstrndx
2621           /* Ignore string tables named .stabstr, as they contain
2622              debugging info. */
2623           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2624          ) {
2625          IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
2626          strtab = ehdrC + shdr[i].sh_offset;
2627          nstrtab++;
2628       }
2629    }
2630    if (nstrtab != 1) {
2631       errorBelch("%s: no string tables, or too many", oc->fileName);
2632       return 0;
2633    }
2634
2635    nsymtabs = 0;
2636    IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
2637    for (i = 0; i < ehdr->e_shnum; i++) {
2638       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2639       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
2640       nsymtabs++;
2641       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2642       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2643       IF_DEBUG(linker,debugBelch( "   number of entries is apparently %d (%d rem)\n",
2644                nent,
2645                shdr[i].sh_size % sizeof(Elf_Sym)
2646              ));
2647       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2648          errorBelch("%s: non-integral number of symbol table entries", oc->fileName);
2649          return 0;
2650       }
2651       for (j = 0; j < nent; j++) {
2652          IF_DEBUG(linker,debugBelch("   %2d  ", j ));
2653          IF_DEBUG(linker,debugBelch("  sec=%-5d  size=%-3d  val=%5p  ",
2654                              (int)stab[j].st_shndx,
2655                              (int)stab[j].st_size,
2656                              (char*)stab[j].st_value ));
2657
2658          IF_DEBUG(linker,debugBelch("type=" ));
2659          switch (ELF_ST_TYPE(stab[j].st_info)) {
2660             case STT_NOTYPE:  IF_DEBUG(linker,debugBelch("notype " )); break;
2661             case STT_OBJECT:  IF_DEBUG(linker,debugBelch("object " )); break;
2662             case STT_FUNC  :  IF_DEBUG(linker,debugBelch("func   " )); break;
2663             case STT_SECTION: IF_DEBUG(linker,debugBelch("section" )); break;
2664             case STT_FILE:    IF_DEBUG(linker,debugBelch("file   " )); break;
2665             default:          IF_DEBUG(linker,debugBelch("?      " )); break;
2666          }
2667          IF_DEBUG(linker,debugBelch("  " ));
2668
2669          IF_DEBUG(linker,debugBelch("bind=" ));
2670          switch (ELF_ST_BIND(stab[j].st_info)) {
2671             case STB_LOCAL :  IF_DEBUG(linker,debugBelch("local " )); break;
2672             case STB_GLOBAL:  IF_DEBUG(linker,debugBelch("global" )); break;
2673             case STB_WEAK  :  IF_DEBUG(linker,debugBelch("weak  " )); break;
2674             default:          IF_DEBUG(linker,debugBelch("?     " )); break;
2675          }
2676          IF_DEBUG(linker,debugBelch("  " ));
2677
2678          IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
2679       }
2680    }
2681
2682    if (nsymtabs == 0) {
2683       errorBelch("%s: didn't find any symbol tables", oc->fileName);
2684       return 0;
2685    }
2686
2687    return 1;
2688 }
2689
2690 static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss )
2691 {
2692     *is_bss = FALSE;
2693
2694     if (hdr->sh_type == SHT_PROGBITS
2695         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_EXECINSTR)) {
2696         /* .text-style section */
2697         return SECTIONKIND_CODE_OR_RODATA;
2698     }
2699
2700     if (hdr->sh_type == SHT_PROGBITS
2701             && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2702             /* .data-style section */
2703             return SECTIONKIND_RWDATA;
2704     }
2705
2706     if (hdr->sh_type == SHT_PROGBITS
2707         && (hdr->sh_flags & SHF_ALLOC) && !(hdr->sh_flags & SHF_WRITE)) {
2708         /* .rodata-style section */
2709         return SECTIONKIND_CODE_OR_RODATA;
2710     }
2711
2712     if (hdr->sh_type == SHT_NOBITS
2713         && (hdr->sh_flags & SHF_ALLOC) && (hdr->sh_flags & SHF_WRITE)) {
2714         /* .bss-style section */
2715         *is_bss = TRUE;
2716         return SECTIONKIND_RWDATA;
2717     }
2718
2719     return SECTIONKIND_OTHER;
2720 }
2721
2722
2723 static int
2724 ocGetNames_ELF ( ObjectCode* oc )
2725 {
2726    int i, j, k, nent;
2727    Elf_Sym* stab;
2728
2729    char*     ehdrC    = (char*)(oc->image);
2730    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2731    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2732    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2733
2734    ASSERT(symhash != NULL);
2735
2736    if (!strtab) {
2737       errorBelch("%s: no strtab", oc->fileName);
2738       return 0;
2739    }
2740
2741    k = 0;
2742    for (i = 0; i < ehdr->e_shnum; i++) {
2743       /* Figure out what kind of section it is.  Logic derived from
2744          Figure 1.14 ("Special Sections") of the ELF document
2745          ("Portable Formats Specification, Version 1.1"). */
2746       int         is_bss = FALSE;
2747       SectionKind kind   = getSectionKind_ELF(&shdr[i], &is_bss);
2748
2749       if (is_bss && shdr[i].sh_size > 0) {
2750          /* This is a non-empty .bss section.  Allocate zeroed space for
2751             it, and set its .sh_offset field such that
2752             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2753          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2754                                        "ocGetNames_ELF(BSS)");
2755          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2756          /*
2757          debugBelch("BSS section at 0x%x, size %d\n",
2758                          zspace, shdr[i].sh_size);
2759          */
2760       }
2761
2762       /* fill in the section info */
2763       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2764          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2765          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2766                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2767       }
2768
2769       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2770
2771       /* copy stuff into this module's object symbol table */
2772       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2773       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2774
2775       oc->n_symbols = nent;
2776       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2777                                    "ocGetNames_ELF(oc->symbols)");
2778
2779       for (j = 0; j < nent; j++) {
2780
2781          char  isLocal = FALSE; /* avoids uninit-var warning */
2782          char* ad      = NULL;
2783          char* nm      = strtab + stab[j].st_name;
2784          int   secno   = stab[j].st_shndx;
2785
2786          /* Figure out if we want to add it; if so, set ad to its
2787             address.  Otherwise leave ad == NULL. */
2788
2789          if (secno == SHN_COMMON) {
2790             isLocal = FALSE;
2791             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2792             /*
2793             debugBelch("COMMON symbol, size %d name %s\n",
2794                             stab[j].st_size, nm);
2795             */
2796             /* Pointless to do addProddableBlock() for this area,
2797                since the linker should never poke around in it. */
2798          }
2799          else
2800          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2801                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2802               )
2803               /* and not an undefined symbol */
2804               && stab[j].st_shndx != SHN_UNDEF
2805               /* and not in a "special section" */
2806               && stab[j].st_shndx < SHN_LORESERVE
2807               &&
2808               /* and it's a not a section or string table or anything silly */
2809               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2810                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2811                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2812               )
2813             ) {
2814             /* Section 0 is the undefined section, hence > and not >=. */
2815             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2816             /*
2817             if (shdr[secno].sh_type == SHT_NOBITS) {
2818                debugBelch("   BSS symbol, size %d off %d name %s\n",
2819                                stab[j].st_size, stab[j].st_value, nm);
2820             }
2821             */
2822             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2823             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2824                isLocal = TRUE;
2825             } else {
2826 #ifdef ELF_FUNCTION_DESC
2827                /* dlsym() and the initialisation table both give us function
2828                 * descriptors, so to be consistent we store function descriptors
2829                 * in the symbol table */
2830                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2831                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2832 #endif
2833                IF_DEBUG(linker,debugBelch( "addOTabName(GLOB): %10p  %s %s",
2834                                       ad, oc->fileName, nm ));
2835                isLocal = FALSE;
2836             }
2837          }
2838
2839          /* And the decision is ... */
2840
2841          if (ad != NULL) {
2842             ASSERT(nm != NULL);
2843             oc->symbols[j] = nm;
2844             /* Acquire! */
2845             if (isLocal) {
2846                /* Ignore entirely. */
2847             } else {
2848                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2849             }
2850          } else {
2851             /* Skip. */
2852             IF_DEBUG(linker,debugBelch( "skipping `%s'\n",
2853                                    strtab + stab[j].st_name ));
2854             /*
2855             debugBelch(
2856                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2857                     (int)ELF_ST_BIND(stab[j].st_info),
2858                     (int)ELF_ST_TYPE(stab[j].st_info),
2859                     (int)stab[j].st_shndx,
2860                     strtab + stab[j].st_name
2861                    );
2862             */
2863             oc->symbols[j] = NULL;
2864          }
2865
2866       }
2867    }
2868
2869    return 1;
2870 }
2871
2872 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2873    relocations appear to be of this form. */
2874 static int
2875 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2876                          Elf_Shdr* shdr, int shnum,
2877                          Elf_Sym*  stab, char* strtab )
2878 {
2879    int j;
2880    char *symbol;
2881    Elf_Word* targ;
2882    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
2883    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
2884    int target_shndx = shdr[shnum].sh_info;
2885    int symtab_shndx = shdr[shnum].sh_link;
2886
2887    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2888    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2889    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
2890                           target_shndx, symtab_shndx ));
2891
2892    /* Skip sections that we're not interested in. */
2893    {
2894        int is_bss;
2895        SectionKind kind = getSectionKind_ELF(&shdr[target_shndx], &is_bss);
2896        if (kind == SECTIONKIND_OTHER) {
2897            IF_DEBUG(linker,debugBelch( "skipping (target section not loaded)"));
2898            return 1;
2899        }
2900    }
2901
2902    for (j = 0; j < nent; j++) {
2903       Elf_Addr offset = rtab[j].r_offset;
2904       Elf_Addr info   = rtab[j].r_info;
2905
2906       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
2907       Elf_Word* pP = (Elf_Word*)P;
2908       Elf_Addr  A  = *pP;
2909       Elf_Addr  S;
2910       void*     S_tmp;
2911       Elf_Addr  value;
2912
2913       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p)",
2914                              j, (void*)offset, (void*)info ));
2915       if (!info) {
2916          IF_DEBUG(linker,debugBelch( " ZERO" ));
2917          S = 0;
2918       } else {
2919          Elf_Sym sym = stab[ELF_R_SYM(info)];
2920          /* First see if it is a local symbol. */
2921          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2922             /* Yes, so we can get the address directly from the ELF symbol
2923                table. */
2924             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2925             S = (Elf_Addr)
2926                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2927                        + stab[ELF_R_SYM(info)].st_value);
2928
2929          } else {
2930             /* No, so look up the name in our global table. */
2931             symbol = strtab + sym.st_name;
2932             S_tmp = lookupSymbol( symbol );
2933             S = (Elf_Addr)S_tmp;
2934          }
2935          if (!S) {
2936             errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
2937             return 0;
2938          }
2939          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p\n", symbol, (void*)S ));
2940       }
2941
2942       IF_DEBUG(linker,debugBelch( "Reloc: P = %p   S = %p   A = %p\n",
2943                              (void*)P, (void*)S, (void*)A ));
2944       checkProddableBlock ( oc, pP );
2945
2946       value = S + A;
2947
2948       switch (ELF_R_TYPE(info)) {
2949 #        ifdef i386_HOST_ARCH
2950          case R_386_32:   *pP = value;     break;
2951          case R_386_PC32: *pP = value - P; break;
2952 #        endif
2953          default:
2954             errorBelch("%s: unhandled ELF relocation(Rel) type %d\n",
2955                   oc->fileName, ELF_R_TYPE(info));
2956             return 0;
2957       }
2958
2959    }
2960    return 1;
2961 }
2962
2963 /* Do ELF relocations for which explicit addends are supplied.
2964    sparc-solaris relocations appear to be of this form. */
2965 static int
2966 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2967                           Elf_Shdr* shdr, int shnum,
2968                           Elf_Sym*  stab, char* strtab )
2969 {
2970    int j;
2971    char *symbol;
2972    Elf_Addr targ;
2973    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
2974    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
2975    int target_shndx = shdr[shnum].sh_info;
2976    int symtab_shndx = shdr[shnum].sh_link;
2977
2978    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2979    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
2980    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
2981                           target_shndx, symtab_shndx ));
2982
2983    for (j = 0; j < nent; j++) {
2984 #if defined(DEBUG) || defined(sparc_HOST_ARCH) || defined(ia64_HOST_ARCH) || defined(powerpc_HOST_ARCH)
2985       /* This #ifdef only serves to avoid unused-var warnings. */
2986       Elf_Addr  offset = rtab[j].r_offset;
2987       Elf_Addr  P      = targ + offset;
2988 #endif
2989       Elf_Addr  info   = rtab[j].r_info;
2990       Elf_Addr  A      = rtab[j].r_addend;
2991       Elf_Addr  S;
2992       void*     S_tmp;
2993       Elf_Addr  value;
2994 #     if defined(sparc_HOST_ARCH)
2995       Elf_Word* pP = (Elf_Word*)P;
2996       Elf_Word  w1, w2;
2997 #     elif defined(ia64_HOST_ARCH)
2998       Elf64_Xword *pP = (Elf64_Xword *)P;
2999       Elf_Addr addr;
3000 #     elif defined(powerpc_HOST_ARCH)
3001       Elf_Sword delta;
3002 #     endif
3003
3004       IF_DEBUG(linker,debugBelch( "Rel entry %3d is raw(%6p %6p %6p)   ",
3005                              j, (void*)offset, (void*)info,
3006                                 (void*)A ));
3007       if (!info) {
3008          IF_DEBUG(linker,debugBelch( " ZERO" ));
3009          S = 0;
3010       } else {
3011          Elf_Sym sym = stab[ELF_R_SYM(info)];
3012          /* First see if it is a local symbol. */
3013          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
3014             /* Yes, so we can get the address directly from the ELF symbol
3015                table. */
3016             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
3017             S = (Elf_Addr)
3018                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
3019                        + stab[ELF_R_SYM(info)].st_value);
3020 #ifdef ELF_FUNCTION_DESC
3021             /* Make a function descriptor for this function */
3022             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
3023                S = allocateFunctionDesc(S + A);
3024                A = 0;
3025             }
3026 #endif
3027          } else {
3028             /* No, so look up the name in our global table. */
3029             symbol = strtab + sym.st_name;
3030             S_tmp = lookupSymbol( symbol );
3031             S = (Elf_Addr)S_tmp;
3032
3033 #ifdef ELF_FUNCTION_DESC
3034             /* If a function, already a function descriptor - we would
3035                have to copy it to add an offset. */
3036             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
3037                errorBelch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
3038 #endif
3039          }
3040          if (!S) {
3041            errorBelch("%s: unknown symbol `%s'", oc->fileName, symbol);
3042            return 0;
3043          }
3044          IF_DEBUG(linker,debugBelch( "`%s' resolves to %p", symbol, (void*)S ));
3045       }
3046
3047       IF_DEBUG(linker,debugBelch("Reloc: P = %p   S = %p   A = %p\n",
3048                                         (void*)P, (void*)S, (void*)A ));
3049       /* checkProddableBlock ( oc, (void*)P ); */
3050
3051       value = S + A;
3052
3053       switch (ELF_R_TYPE(info)) {
3054 #        if defined(sparc_HOST_ARCH)
3055          case R_SPARC_WDISP30:
3056             w1 = *pP & 0xC0000000;
3057             w2 = (Elf_Word)((value - P) >> 2);
3058             ASSERT((w2 & 0xC0000000) == 0);
3059             w1 |= w2;
3060             *pP = w1;
3061             break;
3062          case R_SPARC_HI22:
3063             w1 = *pP & 0xFFC00000;
3064             w2 = (Elf_Word)(value >> 10);
3065             ASSERT((w2 & 0xFFC00000) == 0);
3066             w1 |= w2;
3067             *pP = w1;
3068             break;
3069          case R_SPARC_LO10:
3070             w1 = *pP & ~0x3FF;
3071             w2 = (Elf_Word)(value & 0x3FF);
3072             ASSERT((w2 & ~0x3FF) == 0);
3073             w1 |= w2;
3074             *pP = w1;
3075             break;
3076          /* According to the Sun documentation:
3077             R_SPARC_UA32
3078             This relocation type resembles R_SPARC_32, except it refers to an
3079             unaligned word. That is, the word to be relocated must be treated
3080             as four separate bytes with arbitrary alignment, not as a word
3081             aligned according to the architecture requirements.
3082
3083             (JRS: which means that freeloading on the R_SPARC_32 case
3084             is probably wrong, but hey ...)
3085          */
3086          case R_SPARC_UA32:
3087          case R_SPARC_32:
3088             w2 = (Elf_Word)value;
3089             *pP = w2;
3090             break;
3091 #        elif defined(ia64_HOST_ARCH)
3092          case R_IA64_DIR64LSB:
3093          case R_IA64_FPTR64LSB:
3094             *pP = value;
3095             break;
3096          case R_IA64_PCREL64LSB:
3097             *pP = value - P;
3098             break;
3099          case R_IA64_SEGREL64LSB:
3100             addr = findElfSegment(ehdrC, value);
3101             *pP = value - addr;
3102             break;
3103          case R_IA64_GPREL22:
3104             ia64_reloc_gprel22(P, value);
3105             break;
3106          case R_IA64_LTOFF22:
3107          case R_IA64_LTOFF22X:
3108          case R_IA64_LTOFF_FPTR22:
3109             addr = allocateGOTEntry(value);
3110             ia64_reloc_gprel22(P, addr);
3111             break;
3112          case R_IA64_PCREL21B:
3113             ia64_reloc_pcrel21(P, S, oc);
3114             break;
3115          case R_IA64_LDXMOV:
3116             /* This goes with R_IA64_LTOFF22X and points to the load to
3117              * convert into a move.  We don't implement relaxation. */
3118             break;
3119 #        elif defined(powerpc_HOST_ARCH)
3120          case R_PPC_ADDR16_LO:
3121             *(Elf32_Half*) P = value;
3122             break;
3123
3124          case R_PPC_ADDR16_HI:
3125             *(Elf32_Half*) P = value >> 16;
3126             break;
3127
3128          case R_PPC_ADDR16_HA:
3129             *(Elf32_Half*) P = (value + 0x8000) >> 16;
3130             break;
3131
3132          case R_PPC_ADDR32:
3133             *(Elf32_Word *) P = value;
3134             break;
3135
3136          case R_PPC_REL32:
3137             *(Elf32_Word *) P = value - P;
3138             break;
3139
3140          case R_PPC_REL24:
3141             delta = value - P;
3142
3143             if( delta << 6 >> 6 != delta )
3144             {
3145                value = makeJumpIsland( oc, ELF_R_SYM(info), value );
3146                delta = value - P;
3147
3148                if( value == 0 || delta << 6 >> 6 != delta )
3149                {
3150                   barf( "Unable to make ppcJumpIsland for #%d",
3151                         ELF_R_SYM(info) );
3152                   return 0;
3153                }
3154             }
3155
3156             *(Elf_Word *) P = (*(Elf_Word *) P & 0xfc000003)
3157                                           | (delta & 0x3fffffc);
3158             break;
3159 #        endif
3160          default:
3161             errorBelch("%s: unhandled ELF relocation(RelA) type %d\n",
3162                   oc->fileName, ELF_R_TYPE(info));
3163             return 0;
3164       }
3165
3166    }
3167    return 1;
3168 }
3169
3170 static int
3171 ocResolve_ELF ( ObjectCode* oc )
3172 {
3173    char *strtab;
3174    int   shnum, ok;
3175    Elf_Sym*  stab  = NULL;
3176    char*     ehdrC = (char*)(oc->image);
3177    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
3178    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
3179
3180    /* first find "the" symbol table */
3181    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
3182
3183    /* also go find the string table */
3184    strtab = findElfSection ( ehdrC, SHT_STRTAB );
3185
3186    if (stab == NULL || strtab == NULL) {
3187       errorBelch("%s: can't find string or symbol table", oc->fileName);
3188       return 0;
3189    }
3190
3191    /* Process the relocation sections. */
3192    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
3193       if (shdr[shnum].sh_type == SHT_REL) {
3194          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
3195                                        shnum, stab, strtab );
3196          if (!ok) return ok;
3197       }
3198       else
3199       if (shdr[shnum].sh_type == SHT_RELA) {
3200          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
3201                                         shnum, stab, strtab );
3202          if (!ok) return ok;
3203       }
3204    }
3205
3206    /* Free the local symbol table; we won't need it again. */
3207    freeHashTable(oc->lochash, NULL);
3208    oc->lochash = NULL;
3209
3210 #if defined(powerpc_HOST_ARCH)
3211    ocFlushInstructionCache( oc );
3212 #endif
3213
3214    return 1;
3215 }
3216
3217 /*
3218  * IA64 specifics
3219  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
3220  * at the front.  The following utility functions pack and unpack instructions, and
3221  * take care of the most common relocations.
3222  */
3223
3224 #ifdef ia64_HOST_ARCH
3225
3226 static Elf64_Xword
3227 ia64_extract_instruction(Elf64_Xword *target)
3228 {
3229    Elf64_Xword w1, w2;
3230    int slot = (Elf_Addr)target & 3;
3231    (Elf_Addr)target &= ~3;
3232
3233    w1 = *target;
3234    w2 = *(target+1);
3235
3236    switch (slot)
3237    {
3238       case 0:
3239          return ((w1 >> 5) & 0x1ffffffffff);
3240       case 1:
3241          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
3242       case 2:
3243          return (w2 >> 23);
3244       default:
3245          barf("ia64_extract_instruction: invalid slot %p", target);
3246    }
3247 }
3248
3249 static void
3250 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
3251 {
3252    int slot = (Elf_Addr)target & 3;
3253    (Elf_Addr)target &= ~3;
3254
3255    switch (slot)
3256    {
3257       case 0:
3258          *target |= value << 5;
3259          break;
3260       case 1:
3261          *target |= value << 46;
3262          *(target+1) |= value >> 18;
3263          break;
3264       case 2:
3265          *(target+1) |= value << 23;
3266          break;
3267    }
3268 }
3269
3270 static void
3271 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
3272 {
3273    Elf64_Xword instruction;
3274    Elf64_Sxword rel_value;
3275
3276    rel_value = value - gp_val;
3277    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
3278       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
3279
3280    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3281    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
3282                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
3283                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
3284                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3285    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3286 }
3287
3288 static void
3289 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
3290 {
3291    Elf64_Xword instruction;
3292    Elf64_Sxword rel_value;
3293    Elf_Addr entry;
3294
3295    entry = allocatePLTEntry(value, oc);
3296
3297    rel_value = (entry >> 4) - (target >> 4);
3298    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
3299       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
3300
3301    instruction = ia64_extract_instruction((Elf64_Xword *)target);
3302    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
3303                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
3304    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
3305 }
3306
3307 #endif /* ia64 */
3308
3309 /*
3310  * PowerPC ELF specifics
3311  */
3312
3313 #ifdef powerpc_HOST_ARCH
3314
3315 static int ocAllocateJumpIslands_ELF( ObjectCode *oc )
3316 {
3317   Elf_Ehdr *ehdr;
3318   Elf_Shdr* shdr;
3319   int i;
3320
3321   ehdr = (Elf_Ehdr *) oc->image;
3322   shdr = (Elf_Shdr *) ( ((char *)oc->image) + ehdr->e_shoff );
3323
3324   for( i = 0; i < ehdr->e_shnum; i++ )
3325     if( shdr[i].sh_type == SHT_SYMTAB )
3326       break;
3327
3328   if( i == ehdr->e_shnum )
3329   {
3330     errorBelch( "This ELF file contains no symtab" );
3331     return 0;
3332   }
3333
3334   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
3335   {
3336     errorBelch( "The entry size (%d) of the symtab isn't %d\n",
3337       shdr[i].sh_entsize, sizeof( Elf_Sym ) );
3338
3339     return 0;
3340   }
3341
3342   return ocAllocateJumpIslands( oc, shdr[i].sh_size / sizeof( Elf_Sym ), 0 );
3343 }
3344
3345 #endif /* powerpc */
3346
3347 #endif /* ELF */
3348
3349 /* --------------------------------------------------------------------------
3350  * Mach-O specifics
3351  * ------------------------------------------------------------------------*/
3352
3353 #if defined(OBJFORMAT_MACHO)
3354
3355 /*
3356   Support for MachO linking on Darwin/MacOS X on PowerPC chips
3357   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3358
3359   I hereby formally apologize for the hackish nature of this code.
3360   Things that need to be done:
3361   *) implement ocVerifyImage_MachO
3362   *) add still more sanity checks.
3363 */
3364
3365 static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
3366 {
3367     struct mach_header *header = (struct mach_header *) oc->image;
3368     struct load_command *lc = (struct load_command *) (header + 1);
3369     unsigned i;
3370
3371     for( i = 0; i < header->ncmds; i++ )
3372     {
3373         if( lc->cmd == LC_SYMTAB )
3374         {
3375                 // Find out the first and last undefined external
3376                 // symbol, so we don't have to allocate too many
3377                 // jump islands.
3378             struct symtab_command *symLC = (struct symtab_command *) lc;
3379             int min = symLC->nsyms, max = 0;
3380             struct nlist *nlist =
3381                 symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
3382                       : NULL;
3383             for(i=0;i<symLC->nsyms;i++)
3384             {
3385                 if(nlist[i].n_type & N_STAB)
3386                     ;
3387                 else if(nlist[i].n_type & N_EXT)
3388                 {
3389                     if((nlist[i].n_type & N_TYPE) == N_UNDF
3390                         && (nlist[i].n_value == 0))
3391                     {
3392                         if(i < min)
3393                             min = i;
3394                         if(i > max)
3395                             max = i;
3396                     }
3397                 }
3398             }
3399             if(max >= min)
3400                 return ocAllocateJumpIslands(oc, max - min + 1, min);
3401
3402             break;
3403         }
3404
3405         lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
3406     }
3407     return ocAllocateJumpIslands(oc,0,0);
3408 }
3409
3410 static int ocVerifyImage_MachO(ObjectCode* oc)
3411 {
3412     // FIXME: do some verifying here
3413     return 1;
3414 }
3415
3416 static int resolveImports(
3417     ObjectCode* oc,
3418     char *image,
3419     struct symtab_command *symLC,
3420     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3421     unsigned long *indirectSyms,
3422     struct nlist *nlist)
3423 {
3424     unsigned i;
3425
3426     for(i=0;i*4<sect->size;i++)
3427     {
3428         // according to otool, reserved1 contains the first index into the indirect symbol table
3429         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3430         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3431         void *addr = NULL;
3432
3433         if((symbol->n_type & N_TYPE) == N_UNDF
3434             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3435             addr = (void*) (symbol->n_value);
3436         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3437             ;
3438         else
3439             addr = lookupSymbol(nm);
3440         if(!addr)
3441         {
3442             errorBelch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3443             return 0;
3444         }
3445         ASSERT(addr);
3446         checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3447         ((void**)(image + sect->offset))[i] = addr;
3448     }
3449
3450     return 1;
3451 }
3452
3453 static char* relocateAddress(
3454     ObjectCode* oc,
3455     int nSections,
3456     struct section* sections,
3457     unsigned long address)
3458 {
3459     int i;
3460     for(i = 0; i < nSections; i++)
3461     {
3462         if(sections[i].addr <= address
3463             && address < sections[i].addr + sections[i].size)
3464         {
3465             return oc->image + sections[i].offset + address - sections[i].addr;
3466         }
3467     }
3468     barf("Invalid Mach-O file:"
3469          "Address out of bounds while relocating object file");
3470     return NULL;
3471 }
3472
3473 static int relocateSection(
3474     ObjectCode* oc,
3475     char *image,
3476     struct symtab_command *symLC, struct nlist *nlist,
3477     int nSections, struct section* sections, struct section *sect)
3478 {
3479     struct relocation_info *relocs;
3480     int i,n;
3481
3482     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3483         return 1;
3484     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3485         return 1;
3486
3487     n = sect->nreloc;
3488     relocs = (struct relocation_info*) (image + sect->reloff);
3489
3490     for(i=0;i<n;i++)
3491     {
3492         if(relocs[i].r_address & R_SCATTERED)
3493         {
3494             struct scattered_relocation_info *scat =
3495                 (struct scattered_relocation_info*) &relocs[i];
3496
3497             if(!scat->r_pcrel)
3498             {
3499                 if(scat->r_length == 2)
3500                 {
3501                     unsigned long word = 0;
3502                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
3503                     checkProddableBlock(oc,wordPtr);
3504
3505                     // Step 1: Figure out what the relocated value should be
3506                     if(scat->r_type == GENERIC_RELOC_VANILLA)
3507                     {
3508                         word = *wordPtr + (unsigned long) relocateAddress(
3509                                                                 oc,
3510                                                                 nSections,
3511                                                                 sections,
3512                                                                 scat->r_value)
3513                                         - scat->r_value;
3514                     }
3515                     else if(scat->r_type == PPC_RELOC_SECTDIFF
3516                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
3517                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
3518                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3519                     {
3520                         struct scattered_relocation_info *pair =
3521                                 (struct scattered_relocation_info*) &relocs[i+1];
3522
3523                         if(!pair->r_scattered || pair->r_type != PPC_RELOC_PAIR)
3524                             barf("Invalid Mach-O file: "
3525                                  "PPC_RELOC_*_SECTDIFF not followed by PPC_RELOC_PAIR");
3526
3527                         word = (unsigned long)
3528                                (relocateAddress(oc, nSections, sections, scat->r_value)
3529                               - relocateAddress(oc, nSections, sections, pair->r_value));
3530                         i++;
3531                     }
3532                     else if(scat->r_type == PPC_RELOC_HI16
3533                          || scat->r_type == PPC_RELOC_LO16
3534                          || scat->r_type == PPC_RELOC_HA16
3535                          || scat->r_type == PPC_RELOC_LO14)
3536                     {   // these are generated by label+offset things
3537                         struct relocation_info *pair = &relocs[i+1];
3538                         if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR)
3539                             barf("Invalid Mach-O file: "
3540                                  "PPC_RELOC_* not followed by PPC_RELOC_PAIR");
3541
3542                         if(scat->r_type == PPC_RELOC_LO16)
3543                         {
3544                             word = ((unsigned short*) wordPtr)[1];
3545                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3546                         }
3547                         else if(scat->r_type == PPC_RELOC_LO14)
3548                         {
3549                             barf("Unsupported Relocation: PPC_RELOC_LO14");
3550                             word = ((unsigned short*) wordPtr)[1] & 0xFFFC;
3551                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3552                         }
3553                         else if(scat->r_type == PPC_RELOC_HI16)
3554                         {
3555                             word = ((unsigned short*) wordPtr)[1] << 16;
3556                             word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3557                         }
3558                         else if(scat->r_type == PPC_RELOC_HA16)
3559                         {
3560                             word = ((unsigned short*) wordPtr)[1] << 16;
3561                             word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3562                         }
3563
3564
3565                         word += (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value)
3566                                                 - scat->r_value;
3567
3568                         i++;
3569                     }
3570                     else
3571                         continue;  // ignore the others
3572
3573                     if(scat->r_type == GENERIC_RELOC_VANILLA
3574                         || scat->r_type == PPC_RELOC_SECTDIFF)
3575                     {
3576                         *wordPtr = word;
3577                     }
3578                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16)
3579                     {
3580                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3581                     }
3582                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16)
3583                     {
3584                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3585                     }
3586                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16)
3587                     {
3588                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3589                             + ((word & (1<<15)) ? 1 : 0);
3590                     }
3591                 }
3592             }
3593
3594             continue; // FIXME: I hope it's OK to ignore all the others.
3595         }
3596         else
3597         {
3598             struct relocation_info *reloc = &relocs[i];
3599             if(reloc->r_pcrel && !reloc->r_extern)
3600                 continue;
3601
3602             if(reloc->r_length == 2)
3603             {
3604                 unsigned long word = 0;
3605                 unsigned long jumpIsland = 0;
3606                 long offsetToJumpIsland;
3607
3608                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
3609                 checkProddableBlock(oc,wordPtr);
3610
3611                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3612                 {
3613                     word = *wordPtr;
3614                 }
3615                 else if(reloc->r_type == PPC_RELOC_LO16)
3616                 {
3617                     word = ((unsigned short*) wordPtr)[1];
3618                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3619                 }
3620                 else if(reloc->r_type == PPC_RELOC_HI16)
3621                 {
3622                     word = ((unsigned short*) wordPtr)[1] << 16;
3623                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3624                 }
3625                 else if(reloc->r_type == PPC_RELOC_HA16)
3626                 {
3627                     word = ((unsigned short*) wordPtr)[1] << 16;
3628                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3629                 }
3630                 else if(reloc->r_type == PPC_RELOC_BR24)
3631                 {
3632                     word = *wordPtr;
3633                     word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0);
3634                 }
3635
3636
3637                 if(!reloc->r_extern)
3638                 {
3639                     long delta =
3640                         sections[reloc->r_symbolnum-1].offset
3641                         - sections[reloc->r_symbolnum-1].addr
3642                         + ((long) image);
3643
3644                     word += delta;
3645                 }
3646                 else
3647                 {
3648                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3649                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3650                     unsigned long symbolAddress = (unsigned long) (lookupSymbol(nm));
3651                     if(!symbolAddress)
3652                     {
3653                         errorBelch("\nunknown symbol `%s'", nm);
3654                         return 0;
3655                     }
3656
3657                     if(reloc->r_pcrel)
3658                     {
3659                             // In the .o file, this should be a relative jump to NULL
3660                             // and we'll change it to a jump to a relative jump to the symbol
3661                         ASSERT(-word == reloc->r_address);
3662                         word = symbolAddress;
3663                         jumpIsland = makeJumpIsland(oc,reloc->r_symbolnum,word);
3664                         word -= ((long)image) + sect->offset + reloc->r_address;
3665                         if(jumpIsland != 0)
3666                         {
3667                             offsetToJumpIsland = jumpIsland
3668                                 - (((long)image) + sect->offset + reloc->r_address);
3669                         }
3670                     }
3671                     else
3672                     {
3673                         word += symbolAddress;
3674                     }
3675                 }
3676
3677                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3678                 {
3679                     *wordPtr = word;
3680                     continue;
3681                 }
3682                 else if(reloc->r_type == PPC_RELOC_LO16)
3683                 {
3684                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3685                     i++; continue;
3686                 }
3687                 else if(reloc->r_type == PPC_RELOC_HI16)
3688                 {
3689                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3690                     i++; continue;
3691                 }
3692                 else if(reloc->r_type == PPC_RELOC_HA16)
3693                 {
3694                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3695                         + ((word & (1<<15)) ? 1 : 0);
3696                     i++; continue;
3697                 }
3698                 else if(reloc->r_type == PPC_RELOC_BR24)
3699                 {
3700                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3701                     {
3702                         // The branch offset is too large.
3703                         // Therefore, we try to use a jump island.
3704                         if(jumpIsland == 0)
3705                         {
3706                             barf("unconditional relative branch out of range: "
3707                                  "no jump island available");
3708                         }
3709
3710                         word = offsetToJumpIsland;
3711                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3712                             barf("unconditional relative branch out of range: "
3713                                  "jump island out of range");
3714                     }
3715                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
3716                     continue;
3717                 }
3718             }
3719             barf("\nunknown relocation %d",reloc->r_type);
3720             return 0;
3721         }
3722     }
3723     return 1;
3724 }
3725
3726 static int ocGetNames_MachO(ObjectCode* oc)
3727 {
3728     char *image = (char*) oc->image;
3729     struct mach_header *header = (struct mach_header*) image;
3730     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3731     unsigned i,curSymbol;
3732     struct segment_command *segLC = NULL;
3733     struct section *sections;
3734     struct symtab_command *symLC = NULL;
3735     struct nlist *nlist;
3736     unsigned long commonSize = 0;
3737     char    *commonStorage = NULL;
3738     unsigned long commonCounter;
3739
3740     for(i=0;i<header->ncmds;i++)
3741     {
3742         if(lc->cmd == LC_SEGMENT)
3743             segLC = (struct segment_command*) lc;
3744         else if(lc->cmd == LC_SYMTAB)
3745             symLC = (struct symtab_command*) lc;
3746         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3747     }
3748
3749     sections = (struct section*) (segLC+1);
3750     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
3751                   : NULL;
3752
3753     for(i=0;i<segLC->nsects;i++)
3754     {
3755         if(sections[i].size == 0)
3756             continue;
3757
3758         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
3759         {
3760             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
3761                                       "ocGetNames_MachO(common symbols)");
3762             sections[i].offset = zeroFillArea - image;
3763         }
3764
3765         if(!strcmp(sections[i].sectname,"__text"))
3766             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3767                 (void*) (image + sections[i].offset),
3768                 (void*) (image + sections[i].offset + sections[i].size));
3769         else if(!strcmp(sections[i].sectname,"__const"))
3770             addSection(oc, SECTIONKIND_RWDATA,
3771                 (void*) (image + sections[i].offset),
3772                 (void*) (image + sections[i].offset + sections[i].size));
3773         else if(!strcmp(sections[i].sectname,"__data"))
3774             addSection(oc, SECTIONKIND_RWDATA,
3775                 (void*) (image + sections[i].offset),
3776                 (void*) (image + sections[i].offset + sections[i].size));
3777         else if(!strcmp(sections[i].sectname,"__bss")
3778                 || !strcmp(sections[i].sectname,"__common"))
3779             addSection(oc, SECTIONKIND_RWDATA,
3780                 (void*) (image + sections[i].offset),
3781                 (void*) (image + sections[i].offset + sections[i].size));
3782
3783         addProddableBlock(oc, (void*) (image + sections[i].offset),
3784                                         sections[i].size);
3785     }
3786
3787         // count external symbols defined here
3788     oc->n_symbols = 0;
3789     if(symLC)
3790     {
3791         for(i=0;i<symLC->nsyms;i++)
3792         {
3793             if(nlist[i].n_type & N_STAB)
3794                 ;
3795             else if(nlist[i].n_type & N_EXT)
3796             {
3797                 if((nlist[i].n_type & N_TYPE) == N_UNDF
3798                     && (nlist[i].n_value != 0))
3799                 {
3800                     commonSize += nlist[i].n_value;
3801                     oc->n_symbols++;
3802                 }
3803                 else if((nlist[i].n_type & N_TYPE) == N_SECT)
3804                     oc->n_symbols++;
3805             }
3806         }
3807     }
3808     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3809                                    "ocGetNames_MachO(oc->symbols)");
3810
3811     if(symLC)
3812     {
3813         curSymbol = 0;
3814         for(i=0;i<symLC->nsyms;i++)
3815         {
3816             if(nlist[i].n_type & N_STAB)
3817                 ;
3818             else if((nlist[i].n_type & N_TYPE) == N_SECT)
3819             {
3820                 if(nlist[i].n_type & N_EXT)
3821                 {
3822                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3823                     ghciInsertStrHashTable(oc->fileName, symhash, nm,
3824                                             image
3825                                             + sections[nlist[i].n_sect-1].offset
3826                                             - sections[nlist[i].n_sect-1].addr
3827                                             + nlist[i].n_value);
3828                     oc->symbols[curSymbol++] = nm;
3829                 }
3830                 else
3831                 {
3832                     char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3833                     ghciInsertStrHashTable(oc->fileName, oc->lochash, nm,
3834                                             image
3835                                             + sections[nlist[i].n_sect-1].offset
3836                                             - sections[nlist[i].n_sect-1].addr
3837                                             + nlist[i].n_value);
3838                 }
3839             }
3840         }
3841     }
3842
3843     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
3844     commonCounter = (unsigned long)commonStorage;
3845     if(symLC)
3846     {
3847         for(i=0;i<symLC->nsyms;i++)
3848         {
3849             if((nlist[i].n_type & N_TYPE) == N_UNDF
3850                     && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3851             {
3852                 char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3853                 unsigned long sz = nlist[i].n_value;
3854
3855                 nlist[i].n_value = commonCounter;
3856
3857                 ghciInsertStrHashTable(oc->fileName, symhash, nm,
3858                                        (void*)commonCounter);
3859                 oc->symbols[curSymbol++] = nm;
3860
3861                 commonCounter += sz;
3862             }
3863         }
3864     }
3865     return 1;
3866 }
3867
3868 static int ocResolve_MachO(ObjectCode* oc)
3869 {
3870     char *image = (char*) oc->image;
3871     struct mach_header *header = (struct mach_header*) image;
3872     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3873     unsigned i;
3874     struct segment_command *segLC = NULL;
3875     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3876     struct symtab_command *symLC = NULL;
3877     struct dysymtab_command *dsymLC = NULL;
3878     struct nlist *nlist;
3879
3880     for(i=0;i<header->ncmds;i++)
3881     {
3882         if(lc->cmd == LC_SEGMENT)
3883             segLC = (struct segment_command*) lc;
3884         else if(lc->cmd == LC_SYMTAB)
3885             symLC = (struct symtab_command*) lc;
3886         else if(lc->cmd == LC_DYSYMTAB)
3887             dsymLC = (struct dysymtab_command*) lc;
3888         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3889     }
3890
3891     sections = (struct section*) (segLC+1);
3892     nlist = symLC ? (struct nlist*) (image + symLC->symoff)
3893                   : NULL;
3894
3895     for(i=0;i<segLC->nsects;i++)
3896     {
3897         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3898             la_ptrs = &sections[i];
3899         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3900             nl_ptrs = &sections[i];
3901     }
3902
3903     if(dsymLC)
3904     {
3905         unsigned long *indirectSyms
3906             = (unsigned long*) (image + dsymLC->indirectsymoff);
3907
3908         if(la_ptrs)
3909             if(!resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist))
3910                 return 0;
3911         if(nl_ptrs)
3912             if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
3913                 return 0;
3914     }
3915
3916     for(i=0;i<segLC->nsects;i++)
3917     {
3918         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
3919             return 0;
3920     }
3921
3922     /* Free the local symbol table; we won't need it again. */
3923     freeHashTable(oc->lochash, NULL);
3924     oc->lochash = NULL;
3925
3926 #if defined (powerpc_HOST_ARCH)
3927     ocFlushInstructionCache( oc );
3928 #endif
3929
3930     return 1;
3931 }
3932
3933 /*
3934  * The Mach-O object format uses leading underscores. But not everywhere.
3935  * There is a small number of runtime support functions defined in
3936  * libcc_dynamic.a whose name does not have a leading underscore.
3937  * As a consequence, we can't get their address from C code.
3938  * We have to use inline assembler just to take the address of a function.
3939  * Yuck.
3940  */
3941
3942 static void machoInitSymbolsWithoutUnderscore()
3943 {
3944     extern void* symbolsWithoutUnderscore[];
3945     void **p = symbolsWithoutUnderscore;
3946     __asm__ volatile(".data\n_symbolsWithoutUnderscore:");
3947
3948 #undef Sym
3949 #define Sym(x)  \
3950     __asm__ volatile(".long " # x);
3951
3952     RTS_MACHO_NOUNDERLINE_SYMBOLS
3953
3954     __asm__ volatile(".text");
3955
3956 #undef Sym
3957 #define Sym(x)  \
3958     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
3959
3960     RTS_MACHO_NOUNDERLINE_SYMBOLS
3961
3962 #undef Sym
3963 }
3964 #endif