ghc/rts/Linker.c

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