ghc/rts/Linker.c

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