ghc/rts/Linker.c

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