ghc/rts/Linker.c

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