ghc/rts/Linker.c

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