ghc/rts/Linker.c

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