ghc/rts/Linker.c

   1 /* -----------------------------------------------------------------------------
   2  * $Id: Linker.c,v 1.140 2003/11/12 15:45:49 sof 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          * Nov2003 update: the GNU linker still doesn't correctly
1915          * handle the generation of relocatable object files with
1916          * overflown relocations. Hence the output to warn of potential
1917          * troubles.
1918          */
1919         COFF_reloc* rel = (COFF_reloc*)
1920                            myindex ( sizeof_COFF_reloc, reltab, 0 );
1921         noRelocs = rel->VirtualAddress;
1922         fprintf(stderr, "WARNING: Overflown relocation field (# relocs found: %u)\n", noRelocs); fflush(stderr);
1923         j = 1;
1924       } else {
1925         noRelocs = sectab_i->NumberOfRelocations;
1926         j = 0;
1927       }
1928
1929
1930       for (; j < noRelocs; j++) {
1931          COFF_symbol* sym;
1932          COFF_reloc* reltab_j
1933             = (COFF_reloc*)
1934               myindex ( sizeof_COFF_reloc, reltab, j );
1935
1936          /* the location to patch */
1937          pP = (UInt32*)(
1938                  ((UChar*)(oc->image))
1939                  + (sectab_i->PointerToRawData
1940                     + reltab_j->VirtualAddress
1941                     - sectab_i->VirtualAddress )
1942               );
1943          /* the existing contents of pP */
1944          A = *pP;
1945          /* the symbol to connect to */
1946          sym = (COFF_symbol*)
1947                myindex ( sizeof_COFF_symbol,
1948                          symtab, reltab_j->SymbolTableIndex );
1949          IF_DEBUG(linker,
1950                   fprintf ( stderr,
1951                             "reloc sec %2d num %3d:  type 0x%-4x   "
1952                             "vaddr 0x%-8x   name `",
1953                             i, j,
1954                             (UInt32)reltab_j->Type,
1955                             reltab_j->VirtualAddress );
1956                             printName ( sym->Name, strtab );
1957                             fprintf ( stderr, "'\n" ));
1958
1959          if (sym->StorageClass == MYIMAGE_SYM_CLASS_STATIC) {
1960             COFF_section* section_sym
1961                = findPEi386SectionCalled ( oc, sym->Name );
1962             if (!section_sym) {
1963                belch("%s: can't find section `%s'", oc->fileName, sym->Name);
1964                return 0;
1965             }
1966             S = ((UInt32)(oc->image))
1967                 + (section_sym->PointerToRawData
1968                    + sym->Value);
1969          } else {
1970             copyName ( sym->Name, strtab, symbol, 1000-1 );
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             zapTrailingAtSign ( symbol );
1976             (void*)S = lookupLocalSymbol( oc, symbol );
1977             if ((void*)S != NULL) goto foundit;
1978             (void*)S = lookupSymbol( symbol );
1979             if ((void*)S != NULL) goto foundit;
1980             /* Newline first because the interactive linker has printed "linking..." */
1981             belch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
1982             return 0;
1983            foundit:
1984          }
1985          checkProddableBlock(oc, pP);
1986          switch (reltab_j->Type) {
1987             case MYIMAGE_REL_I386_DIR32:
1988                *pP = A + S;
1989                break;
1990             case MYIMAGE_REL_I386_REL32:
1991                /* Tricky.  We have to insert a displacement at
1992                   pP which, when added to the PC for the _next_
1993                   insn, gives the address of the target (S).
1994                   Problem is to know the address of the next insn
1995                   when we only know pP.  We assume that this
1996                   literal field is always the last in the insn,
1997                   so that the address of the next insn is pP+4
1998                   -- hence the constant 4.
1999                   Also I don't know if A should be added, but so
2000                   far it has always been zero.
2001                */
2002                ASSERT(A==0);
2003                *pP = S - ((UInt32)pP) - 4;
2004                break;
2005             default:
2006                belch("%s: unhandled PEi386 relocation type %d",
2007                      oc->fileName, reltab_j->Type);
2008                return 0;
2009          }
2010
2011       }
2012    }
2013
2014    IF_DEBUG(linker, belch("completed %s", oc->fileName));
2015    return 1;
2016 }
2017
2018 #endif /* defined(OBJFORMAT_PEi386) */
2019
2020
2021 /* --------------------------------------------------------------------------
2022  * ELF specifics
2023  * ------------------------------------------------------------------------*/
2024
2025 #if defined(OBJFORMAT_ELF)
2026
2027 #define FALSE 0
2028 #define TRUE  1
2029
2030 #if defined(sparc_TARGET_ARCH)
2031 #  define ELF_TARGET_SPARC  /* Used inside <elf.h> */
2032 #elif defined(i386_TARGET_ARCH)
2033 #  define ELF_TARGET_386    /* Used inside <elf.h> */
2034 #elif defined(x86_64_TARGET_ARCH)
2035 #  define ELF_TARGET_X64_64
2036 #  define ELF_64BIT
2037 #elif defined (ia64_TARGET_ARCH)
2038 #  define ELF_TARGET_IA64   /* Used inside <elf.h> */
2039 #  define ELF_64BIT
2040 #  define ELF_FUNCTION_DESC /* calling convention uses function descriptors */
2041 #  define ELF_NEED_GOT      /* needs Global Offset Table */
2042 #  define ELF_NEED_PLT      /* needs Procedure Linkage Tables */
2043 #endif
2044
2045 #if !defined(openbsd_TARGET_OS)
2046 #include <elf.h>
2047 #else
2048 /* openbsd elf has things in different places, with diff names */
2049 #include <elf_abi.h>
2050 #include <machine/reloc.h>
2051 #define R_386_32    RELOC_32
2052 #define R_386_PC32  RELOC_PC32
2053 #endif
2054
2055 /*
2056  * Define a set of types which can be used for both ELF32 and ELF64
2057  */
2058
2059 #ifdef ELF_64BIT
2060 #define ELFCLASS    ELFCLASS64
2061 #define Elf_Addr    Elf64_Addr
2062 #define Elf_Word    Elf64_Word
2063 #define Elf_Sword   Elf64_Sword
2064 #define Elf_Ehdr    Elf64_Ehdr
2065 #define Elf_Phdr    Elf64_Phdr
2066 #define Elf_Shdr    Elf64_Shdr
2067 #define Elf_Sym     Elf64_Sym
2068 #define Elf_Rel     Elf64_Rel
2069 #define Elf_Rela    Elf64_Rela
2070 #define ELF_ST_TYPE ELF64_ST_TYPE
2071 #define ELF_ST_BIND ELF64_ST_BIND
2072 #define ELF_R_TYPE  ELF64_R_TYPE
2073 #define ELF_R_SYM   ELF64_R_SYM
2074 #else
2075 #define ELFCLASS    ELFCLASS32
2076 #define Elf_Addr    Elf32_Addr
2077 #define Elf_Word    Elf32_Word
2078 #define Elf_Sword   Elf32_Sword
2079 #define Elf_Ehdr    Elf32_Ehdr
2080 #define Elf_Phdr    Elf32_Phdr
2081 #define Elf_Shdr    Elf32_Shdr
2082 #define Elf_Sym     Elf32_Sym
2083 #define Elf_Rel     Elf32_Rel
2084 #define Elf_Rela    Elf32_Rela
2085 #ifndef ELF_ST_TYPE
2086 #define ELF_ST_TYPE ELF32_ST_TYPE
2087 #endif
2088 #ifndef ELF_ST_BIND
2089 #define ELF_ST_BIND ELF32_ST_BIND
2090 #endif
2091 #ifndef ELF_R_TYPE
2092 #define ELF_R_TYPE  ELF32_R_TYPE
2093 #endif
2094 #ifndef ELF_R_SYM
2095 #define ELF_R_SYM   ELF32_R_SYM
2096 #endif
2097 #endif
2098
2099
2100 /*
2101  * Functions to allocate entries in dynamic sections.  Currently we simply
2102  * preallocate a large number, and we don't check if a entry for the given
2103  * target already exists (a linear search is too slow).  Ideally these
2104  * entries would be associated with symbols.
2105  */
2106
2107 /* These sizes sufficient to load HSbase + HShaskell98 + a few modules */
2108 #define GOT_SIZE            0x20000
2109 #define FUNCTION_TABLE_SIZE 0x10000
2110 #define PLT_SIZE            0x08000
2111
2112 #ifdef ELF_NEED_GOT
2113 static Elf_Addr got[GOT_SIZE];
2114 static unsigned int gotIndex;
2115 static Elf_Addr gp_val = (Elf_Addr)got;
2116
2117 static Elf_Addr
2118 allocateGOTEntry(Elf_Addr target)
2119 {
2120    Elf_Addr *entry;
2121
2122    if (gotIndex >= GOT_SIZE)
2123       barf("Global offset table overflow");
2124
2125    entry = &got[gotIndex++];
2126    *entry = target;
2127    return (Elf_Addr)entry;
2128 }
2129 #endif
2130
2131 #ifdef ELF_FUNCTION_DESC
2132 typedef struct {
2133    Elf_Addr ip;
2134    Elf_Addr gp;
2135 } FunctionDesc;
2136
2137 static FunctionDesc functionTable[FUNCTION_TABLE_SIZE];
2138 static unsigned int functionTableIndex;
2139
2140 static Elf_Addr
2141 allocateFunctionDesc(Elf_Addr target)
2142 {
2143    FunctionDesc *entry;
2144
2145    if (functionTableIndex >= FUNCTION_TABLE_SIZE)
2146       barf("Function table overflow");
2147
2148    entry = &functionTable[functionTableIndex++];
2149    entry->ip = target;
2150    entry->gp = (Elf_Addr)gp_val;
2151    return (Elf_Addr)entry;
2152 }
2153
2154 static Elf_Addr
2155 copyFunctionDesc(Elf_Addr target)
2156 {
2157    FunctionDesc *olddesc = (FunctionDesc *)target;
2158    FunctionDesc *newdesc;
2159
2160    newdesc = (FunctionDesc *)allocateFunctionDesc(olddesc->ip);
2161    newdesc->gp = olddesc->gp;
2162    return (Elf_Addr)newdesc;
2163 }
2164 #endif
2165
2166 #ifdef ELF_NEED_PLT
2167 #ifdef ia64_TARGET_ARCH
2168 static void ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value);
2169 static void ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc);
2170
2171 static unsigned char plt_code[] =
2172 {
2173    /* taken from binutils bfd/elfxx-ia64.c */
2174    0x0b, 0x78, 0x00, 0x02, 0x00, 0x24,  /*   [MMI]       addl r15=0,r1;;    */
2175    0x00, 0x41, 0x3c, 0x30, 0x28, 0xc0,  /*               ld8 r16=[r15],8    */
2176    0x01, 0x08, 0x00, 0x84,              /*               mov r14=r1;;       */
2177    0x11, 0x08, 0x00, 0x1e, 0x18, 0x10,  /*   [MIB]       ld8 r1=[r15]       */
2178    0x60, 0x80, 0x04, 0x80, 0x03, 0x00,  /*               mov b6=r16         */
2179    0x60, 0x00, 0x80, 0x00               /*               br.few b6;;        */
2180 };
2181
2182 /* If we can't get to the function descriptor via gp, take a local copy of it */
2183 #define PLT_RELOC(code, target) { \
2184    Elf64_Sxword rel_value = target - gp_val; \
2185    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff)) \
2186       ia64_reloc_gprel22((Elf_Addr)code, copyFunctionDesc(target)); \
2187    else \
2188       ia64_reloc_gprel22((Elf_Addr)code, target); \
2189    }
2190 #endif
2191
2192 typedef struct {
2193    unsigned char code[sizeof(plt_code)];
2194 } PLTEntry;
2195
2196 static Elf_Addr
2197 allocatePLTEntry(Elf_Addr target, ObjectCode *oc)
2198 {
2199    PLTEntry *plt = (PLTEntry *)oc->plt;
2200    PLTEntry *entry;
2201
2202    if (oc->pltIndex >= PLT_SIZE)
2203       barf("Procedure table overflow");
2204
2205    entry = &plt[oc->pltIndex++];
2206    memcpy(entry->code, plt_code, sizeof(entry->code));
2207    PLT_RELOC(entry->code, target);
2208    return (Elf_Addr)entry;
2209 }
2210
2211 static unsigned int
2212 PLTSize(void)
2213 {
2214    return (PLT_SIZE * sizeof(PLTEntry));
2215 }
2216 #endif
2217
2218
2219 /*
2220  * Generic ELF functions
2221  */
2222
2223 static char *
2224 findElfSection ( void* objImage, Elf_Word sh_type )
2225 {
2226    char* ehdrC = (char*)objImage;
2227    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2228    Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
2229    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2230    char* ptr = NULL;
2231    int i;
2232
2233    for (i = 0; i < ehdr->e_shnum; i++) {
2234       if (shdr[i].sh_type == sh_type
2235           /* Ignore the section header's string table. */
2236           && i != ehdr->e_shstrndx
2237           /* Ignore string tables named .stabstr, as they contain
2238              debugging info. */
2239           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2240          ) {
2241          ptr = ehdrC + shdr[i].sh_offset;
2242          break;
2243       }
2244    }
2245    return ptr;
2246 }
2247
2248 #if defined(ia64_TARGET_ARCH)
2249 static Elf_Addr
2250 findElfSegment ( void* objImage, Elf_Addr vaddr )
2251 {
2252    char* ehdrC = (char*)objImage;
2253    Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
2254    Elf_Phdr* phdr = (Elf_Phdr*)(ehdrC + ehdr->e_phoff);
2255    Elf_Addr segaddr = 0;
2256    int i;
2257
2258    for (i = 0; i < ehdr->e_phnum; i++) {
2259       segaddr = phdr[i].p_vaddr;
2260       if ((vaddr >= segaddr) && (vaddr < segaddr + phdr[i].p_memsz))
2261               break;
2262    }
2263    return segaddr;
2264 }
2265 #endif
2266
2267 static int
2268 ocVerifyImage_ELF ( ObjectCode* oc )
2269 {
2270    Elf_Shdr* shdr;
2271    Elf_Sym*  stab;
2272    int i, j, nent, nstrtab, nsymtabs;
2273    char* sh_strtab;
2274    char* strtab;
2275
2276    char*     ehdrC = (char*)(oc->image);
2277    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
2278
2279    if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
2280        ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
2281        ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
2282        ehdr->e_ident[EI_MAG3] != ELFMAG3) {
2283       belch("%s: not an ELF object", oc->fileName);
2284       return 0;
2285    }
2286
2287    if (ehdr->e_ident[EI_CLASS] != ELFCLASS) {
2288       belch("%s: unsupported ELF format", oc->fileName);
2289       return 0;
2290    }
2291
2292    if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
2293        IF_DEBUG(linker,belch( "Is little-endian" ));
2294    } else
2295    if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
2296        IF_DEBUG(linker,belch( "Is big-endian" ));
2297    } else {
2298        belch("%s: unknown endiannness", oc->fileName);
2299        return 0;
2300    }
2301
2302    if (ehdr->e_type != ET_REL) {
2303       belch("%s: not a relocatable object (.o) file", oc->fileName);
2304       return 0;
2305    }
2306    IF_DEBUG(linker, belch( "Is a relocatable object (.o) file" ));
2307
2308    IF_DEBUG(linker,belch( "Architecture is " ));
2309    switch (ehdr->e_machine) {
2310       case EM_386:   IF_DEBUG(linker,belch( "x86" )); break;
2311       case EM_SPARC: IF_DEBUG(linker,belch( "sparc" )); break;
2312 #ifdef EM_IA_64
2313       case EM_IA_64: IF_DEBUG(linker,belch( "ia64" )); break;
2314 #endif
2315       default:       IF_DEBUG(linker,belch( "unknown" ));
2316                      belch("%s: unknown architecture", oc->fileName);
2317                      return 0;
2318    }
2319
2320    IF_DEBUG(linker,belch(
2321              "\nSection header table: start %d, n_entries %d, ent_size %d",
2322              ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize  ));
2323
2324    ASSERT (ehdr->e_shentsize == sizeof(Elf_Shdr));
2325
2326    shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2327
2328    if (ehdr->e_shstrndx == SHN_UNDEF) {
2329       belch("%s: no section header string table", oc->fileName);
2330       return 0;
2331    } else {
2332       IF_DEBUG(linker,belch( "Section header string table is section %d",
2333                           ehdr->e_shstrndx));
2334       sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2335    }
2336
2337    for (i = 0; i < ehdr->e_shnum; i++) {
2338       IF_DEBUG(linker,fprintf(stderr, "%2d:  ", i ));
2339       IF_DEBUG(linker,fprintf(stderr, "type=%2d  ", (int)shdr[i].sh_type ));
2340       IF_DEBUG(linker,fprintf(stderr, "size=%4d  ", (int)shdr[i].sh_size ));
2341       IF_DEBUG(linker,fprintf(stderr, "offs=%4d  ", (int)shdr[i].sh_offset ));
2342       IF_DEBUG(linker,fprintf(stderr, "  (%p .. %p)  ",
2343                ehdrC + shdr[i].sh_offset,
2344                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
2345
2346       if (shdr[i].sh_type == SHT_REL) {
2347           IF_DEBUG(linker,fprintf(stderr, "Rel  " ));
2348       } else if (shdr[i].sh_type == SHT_RELA) {
2349           IF_DEBUG(linker,fprintf(stderr, "RelA " ));
2350       } else {
2351           IF_DEBUG(linker,fprintf(stderr,"     "));
2352       }
2353       if (sh_strtab) {
2354           IF_DEBUG(linker,fprintf(stderr, "sname=%s\n", sh_strtab + shdr[i].sh_name ));
2355       }
2356    }
2357
2358    IF_DEBUG(linker,belch( "\nString tables" ));
2359    strtab = NULL;
2360    nstrtab = 0;
2361    for (i = 0; i < ehdr->e_shnum; i++) {
2362       if (shdr[i].sh_type == SHT_STRTAB
2363           /* Ignore the section header's string table. */
2364           && i != ehdr->e_shstrndx
2365           /* Ignore string tables named .stabstr, as they contain
2366              debugging info. */
2367           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
2368          ) {
2369          IF_DEBUG(linker,belch("   section %d is a normal string table", i ));
2370          strtab = ehdrC + shdr[i].sh_offset;
2371          nstrtab++;
2372       }
2373    }
2374    if (nstrtab != 1) {
2375       belch("%s: no string tables, or too many", oc->fileName);
2376       return 0;
2377    }
2378
2379    nsymtabs = 0;
2380    IF_DEBUG(linker,belch( "\nSymbol tables" ));
2381    for (i = 0; i < ehdr->e_shnum; i++) {
2382       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2383       IF_DEBUG(linker,belch( "section %d is a symbol table", i ));
2384       nsymtabs++;
2385       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2386       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2387       IF_DEBUG(linker,belch( "   number of entries is apparently %d (%d rem)",
2388                nent,
2389                shdr[i].sh_size % sizeof(Elf_Sym)
2390              ));
2391       if (0 != shdr[i].sh_size % sizeof(Elf_Sym)) {
2392          belch("%s: non-integral number of symbol table entries", oc->fileName);
2393          return 0;
2394       }
2395       for (j = 0; j < nent; j++) {
2396          IF_DEBUG(linker,fprintf(stderr, "   %2d  ", j ));
2397          IF_DEBUG(linker,fprintf(stderr, "  sec=%-5d  size=%-3d  val=%5p  ",
2398                              (int)stab[j].st_shndx,
2399                              (int)stab[j].st_size,
2400                              (char*)stab[j].st_value ));
2401
2402          IF_DEBUG(linker,fprintf(stderr, "type=" ));
2403          switch (ELF_ST_TYPE(stab[j].st_info)) {
2404             case STT_NOTYPE:  IF_DEBUG(linker,fprintf(stderr, "notype " )); break;
2405             case STT_OBJECT:  IF_DEBUG(linker,fprintf(stderr, "object " )); break;
2406             case STT_FUNC  :  IF_DEBUG(linker,fprintf(stderr, "func   " )); break;
2407             case STT_SECTION: IF_DEBUG(linker,fprintf(stderr, "section" )); break;
2408             case STT_FILE:    IF_DEBUG(linker,fprintf(stderr, "file   " )); break;
2409             default:          IF_DEBUG(linker,fprintf(stderr, "?      " )); break;
2410          }
2411          IF_DEBUG(linker,fprintf(stderr, "  " ));
2412
2413          IF_DEBUG(linker,fprintf(stderr, "bind=" ));
2414          switch (ELF_ST_BIND(stab[j].st_info)) {
2415             case STB_LOCAL :  IF_DEBUG(linker,fprintf(stderr, "local " )); break;
2416             case STB_GLOBAL:  IF_DEBUG(linker,fprintf(stderr, "global" )); break;
2417             case STB_WEAK  :  IF_DEBUG(linker,fprintf(stderr, "weak  " )); break;
2418             default:          IF_DEBUG(linker,fprintf(stderr, "?     " )); break;
2419          }
2420          IF_DEBUG(linker,fprintf(stderr, "  " ));
2421
2422          IF_DEBUG(linker,fprintf(stderr, "name=%s\n", strtab + stab[j].st_name ));
2423       }
2424    }
2425
2426    if (nsymtabs == 0) {
2427       belch("%s: didn't find any symbol tables", oc->fileName);
2428       return 0;
2429    }
2430
2431    return 1;
2432 }
2433
2434
2435 static int
2436 ocGetNames_ELF ( ObjectCode* oc )
2437 {
2438    int i, j, k, nent;
2439    Elf_Sym* stab;
2440
2441    char*     ehdrC    = (char*)(oc->image);
2442    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
2443    char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
2444    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2445
2446    ASSERT(symhash != NULL);
2447
2448    if (!strtab) {
2449       belch("%s: no strtab", oc->fileName);
2450       return 0;
2451    }
2452
2453    k = 0;
2454    for (i = 0; i < ehdr->e_shnum; i++) {
2455       /* Figure out what kind of section it is.  Logic derived from
2456          Figure 1.14 ("Special Sections") of the ELF document
2457          ("Portable Formats Specification, Version 1.1"). */
2458       Elf_Shdr    hdr    = shdr[i];
2459       SectionKind kind   = SECTIONKIND_OTHER;
2460       int         is_bss = FALSE;
2461
2462       if (hdr.sh_type == SHT_PROGBITS
2463           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_EXECINSTR)) {
2464          /* .text-style section */
2465          kind = SECTIONKIND_CODE_OR_RODATA;
2466       }
2467       else
2468       if (hdr.sh_type == SHT_PROGBITS
2469           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2470          /* .data-style section */
2471          kind = SECTIONKIND_RWDATA;
2472       }
2473       else
2474       if (hdr.sh_type == SHT_PROGBITS
2475           && (hdr.sh_flags & SHF_ALLOC) && !(hdr.sh_flags & SHF_WRITE)) {
2476          /* .rodata-style section */
2477          kind = SECTIONKIND_CODE_OR_RODATA;
2478       }
2479       else
2480       if (hdr.sh_type == SHT_NOBITS
2481           && (hdr.sh_flags & SHF_ALLOC) && (hdr.sh_flags & SHF_WRITE)) {
2482          /* .bss-style section */
2483          kind = SECTIONKIND_RWDATA;
2484          is_bss = TRUE;
2485       }
2486
2487       if (is_bss && shdr[i].sh_size > 0) {
2488          /* This is a non-empty .bss section.  Allocate zeroed space for
2489             it, and set its .sh_offset field such that
2490             ehdrC + .sh_offset == addr_of_zeroed_space.  */
2491          char* zspace = stgCallocBytes(1, shdr[i].sh_size,
2492                                        "ocGetNames_ELF(BSS)");
2493          shdr[i].sh_offset = ((char*)zspace) - ((char*)ehdrC);
2494          /*
2495          fprintf(stderr, "BSS section at 0x%x, size %d\n",
2496                          zspace, shdr[i].sh_size);
2497          */
2498       }
2499
2500       /* fill in the section info */
2501       if (kind != SECTIONKIND_OTHER && shdr[i].sh_size > 0) {
2502          addProddableBlock(oc, ehdrC + shdr[i].sh_offset, shdr[i].sh_size);
2503          addSection(oc, kind, ehdrC + shdr[i].sh_offset,
2504                         ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
2505       }
2506
2507       if (shdr[i].sh_type != SHT_SYMTAB) continue;
2508
2509       /* copy stuff into this module's object symbol table */
2510       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
2511       nent = shdr[i].sh_size / sizeof(Elf_Sym);
2512
2513       oc->n_symbols = nent;
2514       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
2515                                    "ocGetNames_ELF(oc->symbols)");
2516
2517       for (j = 0; j < nent; j++) {
2518
2519          char  isLocal = FALSE; /* avoids uninit-var warning */
2520          char* ad      = NULL;
2521          char* nm      = strtab + stab[j].st_name;
2522          int   secno   = stab[j].st_shndx;
2523
2524          /* Figure out if we want to add it; if so, set ad to its
2525             address.  Otherwise leave ad == NULL. */
2526
2527          if (secno == SHN_COMMON) {
2528             isLocal = FALSE;
2529             ad = stgCallocBytes(1, stab[j].st_size, "ocGetNames_ELF(COMMON)");
2530             /*
2531             fprintf(stderr, "COMMON symbol, size %d name %s\n",
2532                             stab[j].st_size, nm);
2533             */
2534             /* Pointless to do addProddableBlock() for this area,
2535                since the linker should never poke around in it. */
2536          }
2537          else
2538          if ( ( ELF_ST_BIND(stab[j].st_info)==STB_GLOBAL
2539                 || ELF_ST_BIND(stab[j].st_info)==STB_LOCAL
2540               )
2541               /* and not an undefined symbol */
2542               && stab[j].st_shndx != SHN_UNDEF
2543               /* and not in a "special section" */
2544               && stab[j].st_shndx < SHN_LORESERVE
2545               &&
2546               /* and it's a not a section or string table or anything silly */
2547               ( ELF_ST_TYPE(stab[j].st_info)==STT_FUNC ||
2548                 ELF_ST_TYPE(stab[j].st_info)==STT_OBJECT ||
2549                 ELF_ST_TYPE(stab[j].st_info)==STT_NOTYPE
2550               )
2551             ) {
2552             /* Section 0 is the undefined section, hence > and not >=. */
2553             ASSERT(secno > 0 && secno < ehdr->e_shnum);
2554             /*
2555             if (shdr[secno].sh_type == SHT_NOBITS) {
2556                fprintf(stderr, "   BSS symbol, size %d off %d name %s\n",
2557                                stab[j].st_size, stab[j].st_value, nm);
2558             }
2559             */
2560             ad = ehdrC + shdr[ secno ].sh_offset + stab[j].st_value;
2561             if (ELF_ST_BIND(stab[j].st_info)==STB_LOCAL) {
2562                isLocal = TRUE;
2563             } else {
2564 #ifdef ELF_FUNCTION_DESC
2565                /* dlsym() and the initialisation table both give us function
2566                 * descriptors, so to be consistent we store function descriptors
2567                 * in the symbol table */
2568                if (ELF_ST_TYPE(stab[j].st_info) == STT_FUNC)
2569                    ad = (char *)allocateFunctionDesc((Elf_Addr)ad);
2570 #endif
2571                IF_DEBUG(linker,belch( "addOTabName(GLOB): %10p  %s %s",
2572                                       ad, oc->fileName, nm ));
2573                isLocal = FALSE;
2574             }
2575          }
2576
2577          /* And the decision is ... */
2578
2579          if (ad != NULL) {
2580             ASSERT(nm != NULL);
2581             oc->symbols[j] = nm;
2582             /* Acquire! */
2583             if (isLocal) {
2584                /* Ignore entirely. */
2585             } else {
2586                ghciInsertStrHashTable(oc->fileName, symhash, nm, ad);
2587             }
2588          } else {
2589             /* Skip. */
2590             IF_DEBUG(linker,belch( "skipping `%s'",
2591                                    strtab + stab[j].st_name ));
2592             /*
2593             fprintf(stderr,
2594                     "skipping   bind = %d,  type = %d,  shndx = %d   `%s'\n",
2595                     (int)ELF_ST_BIND(stab[j].st_info),
2596                     (int)ELF_ST_TYPE(stab[j].st_info),
2597                     (int)stab[j].st_shndx,
2598                     strtab + stab[j].st_name
2599                    );
2600             */
2601             oc->symbols[j] = NULL;
2602          }
2603
2604       }
2605    }
2606
2607    return 1;
2608 }
2609
2610 /* Do ELF relocations which lack an explicit addend.  All x86-linux
2611    relocations appear to be of this form. */
2612 static int
2613 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
2614                          Elf_Shdr* shdr, int shnum,
2615                          Elf_Sym*  stab, char* strtab )
2616 {
2617    int j;
2618    char *symbol;
2619    Elf_Word* targ;
2620    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
2621    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
2622    int target_shndx = shdr[shnum].sh_info;
2623    int symtab_shndx = shdr[shnum].sh_link;
2624
2625    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2626    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
2627    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2628                           target_shndx, symtab_shndx ));
2629
2630    for (j = 0; j < nent; j++) {
2631       Elf_Addr offset = rtab[j].r_offset;
2632       Elf_Addr info   = rtab[j].r_info;
2633
2634       Elf_Addr  P  = ((Elf_Addr)targ) + offset;
2635       Elf_Word* pP = (Elf_Word*)P;
2636       Elf_Addr  A  = *pP;
2637       Elf_Addr  S;
2638       Elf_Addr  value;
2639
2640       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p)",
2641                              j, (void*)offset, (void*)info ));
2642       if (!info) {
2643          IF_DEBUG(linker,belch( " ZERO" ));
2644          S = 0;
2645       } else {
2646          Elf_Sym sym = stab[ELF_R_SYM(info)];
2647          /* First see if it is a local symbol. */
2648          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2649             /* Yes, so we can get the address directly from the ELF symbol
2650                table. */
2651             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2652             S = (Elf_Addr)
2653                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2654                        + stab[ELF_R_SYM(info)].st_value);
2655
2656          } else {
2657             /* No, so look up the name in our global table. */
2658             symbol = strtab + sym.st_name;
2659             (void*)S = lookupSymbol( symbol );
2660          }
2661          if (!S) {
2662             belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2663             return 0;
2664          }
2665          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2666       }
2667
2668       IF_DEBUG(linker,belch( "Reloc: P = %p   S = %p   A = %p",
2669                              (void*)P, (void*)S, (void*)A ));
2670       checkProddableBlock ( oc, pP );
2671
2672       value = S + A;
2673
2674       switch (ELF_R_TYPE(info)) {
2675 #        ifdef i386_TARGET_ARCH
2676          case R_386_32:   *pP = value;     break;
2677          case R_386_PC32: *pP = value - P; break;
2678 #        endif
2679          default:
2680             belch("%s: unhandled ELF relocation(Rel) type %d\n",
2681                   oc->fileName, ELF_R_TYPE(info));
2682             return 0;
2683       }
2684
2685    }
2686    return 1;
2687 }
2688
2689 /* Do ELF relocations for which explicit addends are supplied.
2690    sparc-solaris relocations appear to be of this form. */
2691 static int
2692 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
2693                           Elf_Shdr* shdr, int shnum,
2694                           Elf_Sym*  stab, char* strtab )
2695 {
2696    int j;
2697    char *symbol;
2698    Elf_Addr targ;
2699    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
2700    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
2701    int target_shndx = shdr[shnum].sh_info;
2702    int symtab_shndx = shdr[shnum].sh_link;
2703
2704    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
2705    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
2706    IF_DEBUG(linker,belch( "relocations for section %d using symtab %d",
2707                           target_shndx, symtab_shndx ));
2708
2709    for (j = 0; j < nent; j++) {
2710 #if defined(DEBUG) || defined(sparc_TARGET_ARCH) || defined(ia64_TARGET_ARCH)
2711       /* This #ifdef only serves to avoid unused-var warnings. */
2712       Elf_Addr  offset = rtab[j].r_offset;
2713       Elf_Addr  P      = targ + offset;
2714 #endif
2715       Elf_Addr  info   = rtab[j].r_info;
2716       Elf_Addr  A      = rtab[j].r_addend;
2717       Elf_Addr  S;
2718       Elf_Addr  value;
2719 #     if defined(sparc_TARGET_ARCH)
2720       Elf_Word* pP = (Elf_Word*)P;
2721       Elf_Word  w1, w2;
2722 #     elif defined(ia64_TARGET_ARCH)
2723       Elf64_Xword *pP = (Elf64_Xword *)P;
2724       Elf_Addr addr;
2725 #     endif
2726
2727       IF_DEBUG(linker,belch( "Rel entry %3d is raw(%6p %6p %6p)   ",
2728                              j, (void*)offset, (void*)info,
2729                                 (void*)A ));
2730       if (!info) {
2731          IF_DEBUG(linker,belch( " ZERO" ));
2732          S = 0;
2733       } else {
2734          Elf_Sym sym = stab[ELF_R_SYM(info)];
2735          /* First see if it is a local symbol. */
2736          if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) {
2737             /* Yes, so we can get the address directly from the ELF symbol
2738                table. */
2739             symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name;
2740             S = (Elf_Addr)
2741                 (ehdrC + shdr[ sym.st_shndx ].sh_offset
2742                        + stab[ELF_R_SYM(info)].st_value);
2743 #ifdef ELF_FUNCTION_DESC
2744             /* Make a function descriptor for this function */
2745             if (S && ELF_ST_TYPE(sym.st_info) == STT_FUNC) {
2746                S = allocateFunctionDesc(S + A);
2747                A = 0;
2748             }
2749 #endif
2750          } else {
2751             /* No, so look up the name in our global table. */
2752             symbol = strtab + sym.st_name;
2753             (void*)S = lookupSymbol( symbol );
2754
2755 #ifdef ELF_FUNCTION_DESC
2756             /* If a function, already a function descriptor - we would
2757                have to copy it to add an offset. */
2758             if (S && (ELF_ST_TYPE(sym.st_info) == STT_FUNC) && (A != 0))
2759                belch("%s: function %s with addend %p", oc->fileName, symbol, (void *)A);
2760 #endif
2761          }
2762          if (!S) {
2763            belch("%s: unknown symbol `%s'", oc->fileName, symbol);
2764            return 0;
2765          }
2766          IF_DEBUG(linker,belch( "`%s' resolves to %p", symbol, (void*)S ));
2767       }
2768
2769       IF_DEBUG(linker,fprintf ( stderr, "Reloc: P = %p   S = %p   A = %p\n",
2770                                         (void*)P, (void*)S, (void*)A ));
2771       /* checkProddableBlock ( oc, (void*)P ); */
2772
2773       value = S + A;
2774
2775       switch (ELF_R_TYPE(info)) {
2776 #        if defined(sparc_TARGET_ARCH)
2777          case R_SPARC_WDISP30:
2778             w1 = *pP & 0xC0000000;
2779             w2 = (Elf_Word)((value - P) >> 2);
2780             ASSERT((w2 & 0xC0000000) == 0);
2781             w1 |= w2;
2782             *pP = w1;
2783             break;
2784          case R_SPARC_HI22:
2785             w1 = *pP & 0xFFC00000;
2786             w2 = (Elf_Word)(value >> 10);
2787             ASSERT((w2 & 0xFFC00000) == 0);
2788             w1 |= w2;
2789             *pP = w1;
2790             break;
2791          case R_SPARC_LO10:
2792             w1 = *pP & ~0x3FF;
2793             w2 = (Elf_Word)(value & 0x3FF);
2794             ASSERT((w2 & ~0x3FF) == 0);
2795             w1 |= w2;
2796             *pP = w1;
2797             break;
2798          /* According to the Sun documentation:
2799             R_SPARC_UA32
2800             This relocation type resembles R_SPARC_32, except it refers to an
2801             unaligned word. That is, the word to be relocated must be treated
2802             as four separate bytes with arbitrary alignment, not as a word
2803             aligned according to the architecture requirements.
2804
2805             (JRS: which means that freeloading on the R_SPARC_32 case
2806             is probably wrong, but hey ...)
2807          */
2808          case R_SPARC_UA32:
2809          case R_SPARC_32:
2810             w2 = (Elf_Word)value;
2811             *pP = w2;
2812             break;
2813 #        elif defined(ia64_TARGET_ARCH)
2814          case R_IA64_DIR64LSB:
2815          case R_IA64_FPTR64LSB:
2816             *pP = value;
2817             break;
2818          case R_IA64_PCREL64LSB:
2819             *pP = value - P;
2820             break;
2821          case R_IA64_SEGREL64LSB:
2822             addr = findElfSegment(ehdrC, value);
2823             *pP = value - addr;
2824             break;
2825          case R_IA64_GPREL22:
2826             ia64_reloc_gprel22(P, value);
2827             break;
2828          case R_IA64_LTOFF22:
2829          case R_IA64_LTOFF22X:
2830          case R_IA64_LTOFF_FPTR22:
2831             addr = allocateGOTEntry(value);
2832             ia64_reloc_gprel22(P, addr);
2833             break;
2834          case R_IA64_PCREL21B:
2835             ia64_reloc_pcrel21(P, S, oc);
2836             break;
2837          case R_IA64_LDXMOV:
2838             /* This goes with R_IA64_LTOFF22X and points to the load to
2839              * convert into a move.  We don't implement relaxation. */
2840             break;
2841 #        endif
2842          default:
2843             belch("%s: unhandled ELF relocation(RelA) type %d\n",
2844                   oc->fileName, ELF_R_TYPE(info));
2845             return 0;
2846       }
2847
2848    }
2849    return 1;
2850 }
2851
2852 static int
2853 ocResolve_ELF ( ObjectCode* oc )
2854 {
2855    char *strtab;
2856    int   shnum, ok;
2857    Elf_Sym*  stab  = NULL;
2858    char*     ehdrC = (char*)(oc->image);
2859    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
2860    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
2861    char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
2862
2863    /* first find "the" symbol table */
2864    stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
2865
2866    /* also go find the string table */
2867    strtab = findElfSection ( ehdrC, SHT_STRTAB );
2868
2869    if (stab == NULL || strtab == NULL) {
2870       belch("%s: can't find string or symbol table", oc->fileName);
2871       return 0;
2872    }
2873
2874    /* Process the relocation sections. */
2875    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
2876
2877       /* Skip sections called ".rel.stab".  These appear to contain
2878          relocation entries that, when done, make the stabs debugging
2879          info point at the right places.  We ain't interested in all
2880          dat jazz, mun. */
2881       if (0 == memcmp(".rel.stab", sh_strtab + shdr[shnum].sh_name, 9))
2882          continue;
2883
2884       if (shdr[shnum].sh_type == SHT_REL ) {
2885          ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
2886                                        shnum, stab, strtab );
2887          if (!ok) return ok;
2888       }
2889       else
2890       if (shdr[shnum].sh_type == SHT_RELA) {
2891          ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
2892                                         shnum, stab, strtab );
2893          if (!ok) return ok;
2894       }
2895    }
2896
2897    /* Free the local symbol table; we won't need it again. */
2898    freeHashTable(oc->lochash, NULL);
2899    oc->lochash = NULL;
2900
2901    return 1;
2902 }
2903
2904 /*
2905  * IA64 specifics
2906  * Instructions are 41 bits long, packed into 128 bit bundles with a 5-bit template
2907  * at the front.  The following utility functions pack and unpack instructions, and
2908  * take care of the most common relocations.
2909  */
2910
2911 #ifdef ia64_TARGET_ARCH
2912
2913 static Elf64_Xword
2914 ia64_extract_instruction(Elf64_Xword *target)
2915 {
2916    Elf64_Xword w1, w2;
2917    int slot = (Elf_Addr)target & 3;
2918    (Elf_Addr)target &= ~3;
2919
2920    w1 = *target;
2921    w2 = *(target+1);
2922
2923    switch (slot)
2924    {
2925       case 0:
2926          return ((w1 >> 5) & 0x1ffffffffff);
2927       case 1:
2928          return (w1 >> 46) | ((w2 & 0x7fffff) << 18);
2929       case 2:
2930          return (w2 >> 23);
2931       default:
2932          barf("ia64_extract_instruction: invalid slot %p", target);
2933    }
2934 }
2935
2936 static void
2937 ia64_deposit_instruction(Elf64_Xword *target, Elf64_Xword value)
2938 {
2939    int slot = (Elf_Addr)target & 3;
2940    (Elf_Addr)target &= ~3;
2941
2942    switch (slot)
2943    {
2944       case 0:
2945          *target |= value << 5;
2946          break;
2947       case 1:
2948          *target |= value << 46;
2949          *(target+1) |= value >> 18;
2950          break;
2951       case 2:
2952          *(target+1) |= value << 23;
2953          break;
2954    }
2955 }
2956
2957 static void
2958 ia64_reloc_gprel22(Elf_Addr target, Elf_Addr value)
2959 {
2960    Elf64_Xword instruction;
2961    Elf64_Sxword rel_value;
2962
2963    rel_value = value - gp_val;
2964    if ((rel_value > 0x1fffff) || (rel_value < -0x1fffff))
2965       barf("GP-relative data out of range (address = 0x%lx, gp = 0x%lx)", value, gp_val);
2966
2967    instruction = ia64_extract_instruction((Elf64_Xword *)target);
2968    instruction |= (((rel_value >> 0) & 0x07f) << 13)            /* imm7b */
2969                     | (((rel_value >> 7) & 0x1ff) << 27)        /* imm9d */
2970                     | (((rel_value >> 16) & 0x01f) << 22)       /* imm5c */
2971                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
2972    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
2973 }
2974
2975 static void
2976 ia64_reloc_pcrel21(Elf_Addr target, Elf_Addr value, ObjectCode *oc)
2977 {
2978    Elf64_Xword instruction;
2979    Elf64_Sxword rel_value;
2980    Elf_Addr entry;
2981
2982    entry = allocatePLTEntry(value, oc);
2983
2984    rel_value = (entry >> 4) - (target >> 4);
2985    if ((rel_value > 0xfffff) || (rel_value < -0xfffff))
2986       barf("PLT entry too far away (entry = 0x%lx, target = 0x%lx)", entry, target);
2987
2988    instruction = ia64_extract_instruction((Elf64_Xword *)target);
2989    instruction |= ((rel_value & 0xfffff) << 13)                 /* imm20b */
2990                     | ((Elf64_Xword)(rel_value < 0) << 36);     /* s */
2991    ia64_deposit_instruction((Elf64_Xword *)target, instruction);
2992 }
2993
2994 #endif /* ia64 */
2995
2996 #endif /* ELF */
2997
2998 /* --------------------------------------------------------------------------
2999  * Mach-O specifics
3000  * ------------------------------------------------------------------------*/
3001
3002 #if defined(OBJFORMAT_MACHO)
3003
3004 /*
3005   Support for MachO linking on Darwin/MacOS X on PowerPC chips
3006   by Wolfgang Thaller (wolfgang.thaller@gmx.net)
3007
3008   I hereby formally apologize for the hackish nature of this code.
3009   Things that need to be done:
3010   *) implement ocVerifyImage_MachO
3011   *) add still more sanity checks.
3012 */
3013
3014
3015 /*
3016   ocAllocateJumpIslands_MachO
3017
3018   Allocate additional space at the end of the object file image to make room
3019   for jump islands.
3020
3021   PowerPC relative branch instructions have a 24 bit displacement field.
3022   As PPC code is always 4-byte-aligned, this yields a +-32MB range.
3023   If a particular imported symbol is outside this range, we have to redirect
3024   the jump to a short piece of new code that just loads the 32bit absolute
3025   address and jumps there.
3026   This function just allocates space for one 16 byte jump island for every
3027   undefined symbol in the object file. The code for the islands is filled in by
3028   makeJumpIsland below.
3029 */
3030
3031 static const int islandSize = 16;
3032
3033 static int ocAllocateJumpIslands_MachO(ObjectCode* oc)
3034 {
3035     char *image = (char*) oc->image;
3036     struct mach_header *header = (struct mach_header*) image;
3037     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3038     unsigned i;
3039
3040     for(i=0;i<header->ncmds;i++)
3041     {
3042         if(lc->cmd == LC_DYSYMTAB)
3043         {
3044             struct dysymtab_command *dsymLC = (struct dysymtab_command*) lc;
3045             unsigned long nundefsym = dsymLC->nundefsym;
3046             oc->island_start_symbol = dsymLC->iundefsym;
3047             oc->n_islands = nundefsym;
3048
3049             if(nundefsym > 0)
3050             {
3051 #ifdef USE_MMAP
3052                 #error ocAllocateJumpIslands_MachO doesnt want USE_MMAP to be defined
3053 #else
3054                 oc->image = stgReallocBytes(
3055                     image, oc->fileSize + islandSize * nundefsym,
3056                     "ocAllocateJumpIslands_MachO");
3057 #endif
3058                 oc->jump_islands = oc->image + oc->fileSize;
3059                 memset(oc->jump_islands, 0, islandSize * nundefsym);
3060             }
3061
3062             break;  // there can be only one LC_DSYMTAB
3063         }
3064         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3065     }
3066     return 1;
3067 }
3068
3069 static int ocVerifyImage_MachO(ObjectCode* oc)
3070 {
3071     // FIXME: do some verifying here
3072     return 1;
3073 }
3074
3075 static int resolveImports(
3076     ObjectCode* oc,
3077     char *image,
3078     struct symtab_command *symLC,
3079     struct section *sect,    // ptr to lazy or non-lazy symbol pointer section
3080     unsigned long *indirectSyms,
3081     struct nlist *nlist)
3082 {
3083     unsigned i;
3084
3085     for(i=0;i*4<sect->size;i++)
3086     {
3087         // according to otool, reserved1 contains the first index into the indirect symbol table
3088         struct nlist *symbol = &nlist[indirectSyms[sect->reserved1+i]];
3089         char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3090         void *addr = NULL;
3091
3092         if((symbol->n_type & N_TYPE) == N_UNDF
3093             && (symbol->n_type & N_EXT) && (symbol->n_value != 0))
3094             addr = (void*) (symbol->n_value);
3095         else if((addr = lookupLocalSymbol(oc,nm)) != NULL)
3096             ;
3097         else
3098             addr = lookupSymbol(nm);
3099         if(!addr)
3100         {
3101             belch("\n%s: unknown symbol `%s'", oc->fileName, nm);
3102             return 0;
3103         }
3104         ASSERT(addr);
3105         checkProddableBlock(oc,((void**)(image + sect->offset)) + i);
3106         ((void**)(image + sect->offset))[i] = addr;
3107     }
3108
3109     return 1;
3110 }
3111
3112 static void* makeJumpIsland(
3113     ObjectCode* oc,
3114     unsigned long symbolNumber,
3115     void* target)
3116 {
3117     if(symbolNumber < oc->island_start_symbol ||
3118         symbolNumber - oc->island_start_symbol > oc->n_islands)
3119         return NULL;
3120     symbolNumber -= oc->island_start_symbol;
3121
3122     void *island = (void*) ((char*)oc->jump_islands + islandSize * symbolNumber);
3123     unsigned long *p = (unsigned long*) island;
3124
3125         // lis r12, hi16(target)
3126     *p++ = 0x3d800000 | ( ((unsigned long) target) >> 16 );
3127         // ori r12, r12, lo16(target)
3128     *p++ = 0x618c0000 | ( ((unsigned long) target) & 0xFFFF );
3129         // mtctr r12
3130     *p++ = 0x7d8903a6;
3131         // bctr
3132     *p++ = 0x4e800420;
3133
3134     return (void*) island;
3135 }
3136
3137 static char* relocateAddress(
3138     ObjectCode* oc,
3139     int nSections,
3140     struct section* sections,
3141     unsigned long address)
3142 {
3143     int i;
3144     for(i = 0; i < nSections; i++)
3145     {
3146         if(sections[i].addr <= address
3147             && address < sections[i].addr + sections[i].size)
3148         {
3149             return oc->image + sections[i].offset + address - sections[i].addr;
3150         }
3151     }
3152     barf("Invalid Mach-O file:"
3153          "Address out of bounds while relocating object file");
3154     return NULL;
3155 }
3156
3157 static int relocateSection(
3158     ObjectCode* oc,
3159     char *image,
3160     struct symtab_command *symLC, struct nlist *nlist,
3161     int nSections, struct section* sections, struct section *sect)
3162 {
3163     struct relocation_info *relocs;
3164     int i,n;
3165
3166     if(!strcmp(sect->sectname,"__la_symbol_ptr"))
3167         return 1;
3168     else if(!strcmp(sect->sectname,"__nl_symbol_ptr"))
3169         return 1;
3170
3171     n = sect->nreloc;
3172     relocs = (struct relocation_info*) (image + sect->reloff);
3173
3174     for(i=0;i<n;i++)
3175     {
3176         if(relocs[i].r_address & R_SCATTERED)
3177         {
3178             struct scattered_relocation_info *scat =
3179                 (struct scattered_relocation_info*) &relocs[i];
3180
3181             if(!scat->r_pcrel)
3182             {
3183                 if(scat->r_length == 2)
3184                 {
3185                     unsigned long word = 0;
3186                     unsigned long* wordPtr = (unsigned long*) (image + sect->offset + scat->r_address);
3187                     checkProddableBlock(oc,wordPtr);
3188
3189                     // Step 1: Figure out what the relocated value should be
3190                     if(scat->r_type == GENERIC_RELOC_VANILLA)
3191                     {
3192                         word = scat->r_value + sect->offset + ((long) image);
3193                     }
3194                     else if(scat->r_type == PPC_RELOC_SECTDIFF
3195                         || scat->r_type == PPC_RELOC_LO16_SECTDIFF
3196                         || scat->r_type == PPC_RELOC_HI16_SECTDIFF
3197                         || scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3198                     {
3199                         struct scattered_relocation_info *pair =
3200                                 (struct scattered_relocation_info*) &relocs[i+1];
3201
3202                         if(!pair->r_scattered || pair->r_type != PPC_RELOC_PAIR)
3203                             barf("Invalid Mach-O file: "
3204                                  "PPC_RELOC_*_SECTDIFF not followed by PPC_RELOC_PAIR");
3205
3206                         word = (unsigned long)
3207                                (relocateAddress(oc, nSections, sections, scat->r_value)
3208                               - relocateAddress(oc, nSections, sections, pair->r_value));
3209                         i++;
3210                     }
3211                     else
3212                         continue;  // ignore the others
3213
3214                     if(scat->r_type == GENERIC_RELOC_VANILLA
3215                         || scat->r_type == PPC_RELOC_SECTDIFF)
3216                     {
3217                         *wordPtr = word;
3218                     }
3219                     else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF)
3220                     {
3221                         ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3222                     }
3223                     else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF)
3224                     {
3225                         ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3226                     }
3227                     else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF)
3228                     {
3229                         ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3230                             + ((word & (1<<15)) ? 1 : 0);
3231                     }
3232                 }
3233             }
3234
3235             continue; // FIXME: I hope it's OK to ignore all the others.
3236         }
3237         else
3238         {
3239             struct relocation_info *reloc = &relocs[i];
3240             if(reloc->r_pcrel && !reloc->r_extern)
3241                 continue;
3242
3243             if(reloc->r_length == 2)
3244             {
3245                 unsigned long word = 0;
3246                 unsigned long jumpIsland = 0;
3247                 long offsetToJumpIsland;
3248
3249                 unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address);
3250                 checkProddableBlock(oc,wordPtr);
3251
3252                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3253                 {
3254                     word = *wordPtr;
3255                 }
3256                 else if(reloc->r_type == PPC_RELOC_LO16)
3257                 {
3258                     word = ((unsigned short*) wordPtr)[1];
3259                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16;
3260                 }
3261                 else if(reloc->r_type == PPC_RELOC_HI16)
3262                 {
3263                     word = ((unsigned short*) wordPtr)[1] << 16;
3264                     word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF);
3265                 }
3266                 else if(reloc->r_type == PPC_RELOC_HA16)
3267                 {
3268                     word = ((unsigned short*) wordPtr)[1] << 16;
3269                     word += ((short)relocs[i+1].r_address & (short)0xFFFF);
3270                 }
3271                 else if(reloc->r_type == PPC_RELOC_BR24)
3272                 {
3273                     word = *wordPtr;
3274                     word = (word & 0x03FFFFFC) | (word & 0x02000000) ? 0xFC000000 : 0;
3275                 }
3276
3277
3278                 if(!reloc->r_extern)
3279                 {
3280                     long delta =
3281                         sections[reloc->r_symbolnum-1].offset
3282                         - sections[reloc->r_symbolnum-1].addr
3283                         + ((long) image);
3284
3285                     word += delta;
3286                 }
3287                 else
3288                 {
3289                     struct nlist *symbol = &nlist[reloc->r_symbolnum];
3290                     char *nm = image + symLC->stroff + symbol->n_un.n_strx;
3291                     word = (unsigned long) (lookupSymbol(nm));
3292                     if(!word)
3293                     {
3294                         belch("\nunknown symbol `%s'", nm);
3295                         return 0;
3296                     }
3297
3298                     if(reloc->r_pcrel)
3299                     {
3300                         jumpIsland = (long) makeJumpIsland(oc,reloc->r_symbolnum,(void*)word);
3301                         word -= ((long)image) + sect->offset + reloc->r_address;
3302                         if(jumpIsland != 0)
3303                         {
3304                             offsetToJumpIsland = jumpIsland
3305                                 - (((long)image) + sect->offset + reloc->r_address);
3306                         }
3307                     }
3308                 }
3309
3310                 if(reloc->r_type == GENERIC_RELOC_VANILLA)
3311                 {
3312                     *wordPtr = word;
3313                     continue;
3314                 }
3315                 else if(reloc->r_type == PPC_RELOC_LO16)
3316                 {
3317                     ((unsigned short*) wordPtr)[1] = word & 0xFFFF;
3318                     i++; continue;
3319                 }
3320                 else if(reloc->r_type == PPC_RELOC_HI16)
3321                 {
3322                     ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF;
3323                     i++; continue;
3324                 }
3325                 else if(reloc->r_type == PPC_RELOC_HA16)
3326                 {
3327                     ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF)
3328                         + ((word & (1<<15)) ? 1 : 0);
3329                     i++; continue;
3330                 }
3331                 else if(reloc->r_type == PPC_RELOC_BR24)
3332                 {
3333                     if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3334                     {
3335                         // The branch offset is too large.
3336                         // Therefore, we try to use a jump island.
3337                         if(jumpIsland == 0)
3338                             barf("unconditional relative branch out of range: "
3339                                  "no jump island available");
3340
3341                         word = offsetToJumpIsland;
3342                         if((long)word > (long)0x01FFFFFF || (long)word < (long)0xFFE00000)
3343                             barf("unconditional relative branch out of range: "
3344                                  "jump island out of range");
3345                     }
3346                     *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC);
3347                     continue;
3348                 }
3349             }
3350             barf("\nunknown relocation %d",reloc->r_type);
3351             return 0;
3352         }
3353     }
3354     return 1;
3355 }
3356
3357 static int ocGetNames_MachO(ObjectCode* oc)
3358 {
3359     char *image = (char*) oc->image;
3360     struct mach_header *header = (struct mach_header*) image;
3361     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3362     unsigned i,curSymbol;
3363     struct segment_command *segLC = NULL;
3364     struct section *sections;
3365     struct symtab_command *symLC = NULL;
3366     struct dysymtab_command *dsymLC = NULL;
3367     struct nlist *nlist;
3368     unsigned long commonSize = 0;
3369     char    *commonStorage = NULL;
3370     unsigned long commonCounter;
3371
3372     for(i=0;i<header->ncmds;i++)
3373     {
3374         if(lc->cmd == LC_SEGMENT)
3375             segLC = (struct segment_command*) lc;
3376         else if(lc->cmd == LC_SYMTAB)
3377             symLC = (struct symtab_command*) lc;
3378         else if(lc->cmd == LC_DYSYMTAB)
3379             dsymLC = (struct dysymtab_command*) lc;
3380         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3381     }
3382
3383     sections = (struct section*) (segLC+1);
3384     nlist = (struct nlist*) (image + symLC->symoff);
3385
3386     for(i=0;i<segLC->nsects;i++)
3387     {
3388         if(sections[i].size == 0)
3389             continue;
3390
3391         if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL)
3392         {
3393             char * zeroFillArea = stgCallocBytes(1,sections[i].size,
3394                                       "ocGetNames_MachO(common symbols)");
3395             sections[i].offset = zeroFillArea - image;
3396         }
3397
3398         if(!strcmp(sections[i].sectname,"__text"))
3399             addSection(oc, SECTIONKIND_CODE_OR_RODATA,
3400                 (void*) (image + sections[i].offset),
3401                 (void*) (image + sections[i].offset + sections[i].size));
3402         else if(!strcmp(sections[i].sectname,"__const"))
3403             addSection(oc, SECTIONKIND_RWDATA,
3404                 (void*) (image + sections[i].offset),
3405                 (void*) (image + sections[i].offset + sections[i].size));
3406         else if(!strcmp(sections[i].sectname,"__data"))
3407             addSection(oc, SECTIONKIND_RWDATA,
3408                 (void*) (image + sections[i].offset),
3409                 (void*) (image + sections[i].offset + sections[i].size));
3410         else if(!strcmp(sections[i].sectname,"__bss")
3411                 || !strcmp(sections[i].sectname,"__common"))
3412             addSection(oc, SECTIONKIND_RWDATA,
3413                 (void*) (image + sections[i].offset),
3414                 (void*) (image + sections[i].offset + sections[i].size));
3415
3416         addProddableBlock(oc, (void*) (image + sections[i].offset),
3417                                         sections[i].size);
3418     }
3419
3420         // count external symbols defined here
3421     oc->n_symbols = 0;
3422     for(i=dsymLC->iextdefsym;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3423     {
3424         if((nlist[i].n_type & N_TYPE) == N_SECT)
3425             oc->n_symbols++;
3426     }
3427     for(i=0;i<symLC->nsyms;i++)
3428     {
3429         if((nlist[i].n_type & N_TYPE) == N_UNDF
3430                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3431         {
3432             commonSize += nlist[i].n_value;
3433             oc->n_symbols++;
3434         }
3435     }
3436     oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
3437                                    "ocGetNames_MachO(oc->symbols)");
3438
3439         // insert symbols into hash table
3440     for(i=dsymLC->iextdefsym,curSymbol=0;i<dsymLC->iextdefsym+dsymLC->nextdefsym;i++)
3441     {
3442         if((nlist[i].n_type & N_TYPE) == N_SECT)
3443         {
3444             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3445             ghciInsertStrHashTable(oc->fileName, symhash, nm, image +
3446                 sections[nlist[i].n_sect-1].offset
3447                 - sections[nlist[i].n_sect-1].addr
3448                 + nlist[i].n_value);
3449             oc->symbols[curSymbol++] = nm;
3450         }
3451     }
3452
3453         // insert local symbols into lochash
3454     for(i=dsymLC->ilocalsym;i<dsymLC->ilocalsym+dsymLC->nlocalsym;i++)
3455     {
3456         if((nlist[i].n_type & N_TYPE) == N_SECT)
3457         {
3458             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3459             ghciInsertStrHashTable(oc->fileName, oc->lochash, nm, image +
3460                 sections[nlist[i].n_sect-1].offset
3461                 - sections[nlist[i].n_sect-1].addr
3462                 + nlist[i].n_value);
3463         }
3464     }
3465
3466
3467     commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)");
3468     commonCounter = (unsigned long)commonStorage;
3469     for(i=0;i<symLC->nsyms;i++)
3470     {
3471         if((nlist[i].n_type & N_TYPE) == N_UNDF
3472                 && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0))
3473         {
3474             char *nm = image + symLC->stroff + nlist[i].n_un.n_strx;
3475             unsigned long sz = nlist[i].n_value;
3476
3477             nlist[i].n_value = commonCounter;
3478
3479             ghciInsertStrHashTable(oc->fileName, symhash, nm, (void*)commonCounter);
3480             oc->symbols[curSymbol++] = nm;
3481
3482             commonCounter += sz;
3483         }
3484     }
3485     return 1;
3486 }
3487
3488 static int ocResolve_MachO(ObjectCode* oc)
3489 {
3490     char *image = (char*) oc->image;
3491     struct mach_header *header = (struct mach_header*) image;
3492     struct load_command *lc = (struct load_command*) (image + sizeof(struct mach_header));
3493     unsigned i;
3494     struct segment_command *segLC = NULL;
3495     struct section *sections, *la_ptrs = NULL, *nl_ptrs = NULL;
3496     struct symtab_command *symLC = NULL;
3497     struct dysymtab_command *dsymLC = NULL;
3498     struct nlist *nlist;
3499     unsigned long *indirectSyms;
3500
3501     for(i=0;i<header->ncmds;i++)
3502     {
3503         if(lc->cmd == LC_SEGMENT)
3504             segLC = (struct segment_command*) lc;
3505         else if(lc->cmd == LC_SYMTAB)
3506             symLC = (struct symtab_command*) lc;
3507         else if(lc->cmd == LC_DYSYMTAB)
3508             dsymLC = (struct dysymtab_command*) lc;
3509         lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
3510     }
3511
3512     sections = (struct section*) (segLC+1);
3513     nlist = (struct nlist*) (image + symLC->symoff);
3514
3515     for(i=0;i<segLC->nsects;i++)
3516     {
3517         if(!strcmp(sections[i].sectname,"__la_symbol_ptr"))
3518             la_ptrs = &sections[i];
3519         else if(!strcmp(sections[i].sectname,"__nl_symbol_ptr"))
3520             nl_ptrs = &sections[i];
3521     }
3522
3523     indirectSyms = (unsigned long*) (image + dsymLC->indirectsymoff);
3524
3525     if(la_ptrs)
3526         if(!resolveImports(oc,image,symLC,la_ptrs,indirectSyms,nlist))
3527             return 0;
3528     if(nl_ptrs)
3529         if(!resolveImports(oc,image,symLC,nl_ptrs,indirectSyms,nlist))
3530             return 0;
3531
3532     for(i=0;i<segLC->nsects;i++)
3533     {
3534         if(!relocateSection(oc,image,symLC,nlist,segLC->nsects,sections,&sections[i]))
3535             return 0;
3536     }
3537
3538     /* Free the local symbol table; we won't need it again. */
3539     freeHashTable(oc->lochash, NULL);
3540     oc->lochash = NULL;
3541
3542     /*
3543         Flush the data & instruction caches.
3544         Because the PPC has split data/instruction caches, we have to
3545         do that whenever we modify code at runtime.
3546     */
3547     {
3548         int n = (oc->fileSize + islandSize * oc->n_islands) / 4;
3549         unsigned long *p = (unsigned long*)oc->image;
3550         while(n--)
3551         {
3552             __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
3553                                 : : "r" (p));
3554             p++;
3555         }
3556         __asm__ volatile ("sync\n\tisync");
3557     }
3558     return 1;
3559 }
3560
3561 /*
3562  * The Mach-O object format uses leading underscores. But not everywhere.
3563  * There is a small number of runtime support functions defined in
3564  * libcc_dynamic.a whose name does not have a leading underscore.
3565  * As a consequence, we can't get their address from C code.
3566  * We have to use inline assembler just to take the address of a function.
3567  * Yuck.
3568  */
3569
3570 static void machoInitSymbolsWithoutUnderscore()
3571 {
3572     void *p;
3573
3574 #undef Sym
3575 #define Sym(x)                                          \
3576     __asm__ ("lis %0,hi16(" #x ")\n\tori %0,%0,lo16(" #x ")" : "=r" (p));       \
3577     ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, p);
3578
3579     RTS_MACHO_NOUNDERLINE_SYMBOLS
3580
3581 }
3582 #endif