ghc/rts/Linker.c

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