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