ghc/rts/Linker.c

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