ghc/rts/Linker.c

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