ghc/rts/Linker.c

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