ghc/rts/Linker.c

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