ghc/rts/Linker.c

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