ghc/rts/Linker.c

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