ghc/rts/Linker.c

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