ghc/rts/Linker.c

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