ghc/rts/Adjustor.c

   1 /* -----------------------------------------------------------------------------
   2  * Foreign export adjustor thunks
   3  *
   4  * Copyright (c) 1998.
   5  *
   6  * ---------------------------------------------------------------------------*/
   7
   8 /* A little bit of background...
   9
  10 An adjustor thunk is a dynamically allocated code snippet that allows
  11 Haskell closures to be viewed as C function pointers.
  12
  13 Stable pointers provide a way for the outside world to get access to,
  14 and evaluate, Haskell heap objects, with the RTS providing a small
  15 range of ops for doing so. So, assuming we've got a stable pointer in
  16 our hand in C, we can jump into the Haskell world and evaluate a callback
  17 procedure, say. This works OK in some cases where callbacks are used, but
  18 does require the external code to know about stable pointers and how to deal
  19 with them. We'd like to hide the Haskell-nature of a callback and have it
  20 be invoked just like any other C function pointer.
  21
  22 Enter adjustor thunks. An adjustor thunk is a little piece of code
  23 that's generated on-the-fly (one per Haskell closure being exported)
  24 that, when entered using some 'universal' calling convention (e.g., the
  25 C calling convention on platform X), pushes an implicit stable pointer
  26 (to the Haskell callback) before calling another (static) C function stub
  27 which takes care of entering the Haskell code via its stable pointer.
  28
  29 An adjustor thunk is allocated on the C heap, and is called from within
  30 Haskell just before handing out the function pointer to the Haskell (IO)
  31 action. User code should never have to invoke it explicitly.
  32
  33 An adjustor thunk differs from a C function pointer in one respect: when
  34 the code is through with it, it has to be freed in order to release Haskell
  35 and C resources. Failure to do so result in memory leaks on both the C and
  36 Haskell side.
  37 */
  38
  39 #include "PosixSource.h"
  40 #include "Rts.h"
  41 #include "RtsExternal.h"
  42 #include "RtsUtils.h"
  43 #include <stdlib.h>
  44
  45 #if defined(_WIN32)
  46 #include <windows.h>
  47 #endif
  48
  49 #if defined(openbsd_HOST_OS) || defined(linux_HOST_OS)
  50 #include <unistd.h>
  51 #include <sys/types.h>
  52 #include <sys/mman.h>
  53
  54 /* no C99 header stdint.h on OpenBSD? */
  55 #if defined(openbsd_HOST_OS)
  56 typedef unsigned long my_uintptr_t;
  57 #else
  58 #include <stdint.h>
  59 typedef uintptr_t my_uintptr_t;
  60 #endif
  61 #endif
  62
  63 #if defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
  64 #include <string.h>
  65 #endif
  66
  67 /* Heavily arch-specific, I'm afraid.. */
  68
  69 /*
  70  * Allocate len bytes which are readable, writable, and executable.
  71  *
  72  * ToDo: If this turns out to be a performance bottleneck, one could
  73  * e.g. cache the last VirtualProtect/mprotect-ed region and do
  74  * nothing in case of a cache hit.
  75  */
  76 static void*
  77 mallocBytesRWX(int len)
  78 {
  79   void *addr = stgMallocBytes(len, "mallocBytesRWX");
  80 #if defined(i386_HOST_ARCH) && defined(_WIN32)
  81   /* This could be necessary for processors which distinguish between READ and
  82      EXECUTE memory accesses, e.g. Itaniums. */
  83   DWORD dwOldProtect = 0;
  84   if (VirtualProtect (addr, len, PAGE_EXECUTE_READWRITE, &dwOldProtect) == 0) {
  85     barf("mallocBytesRWX: failed to protect 0x%p; error=%lu; old protection: %lu\n",
  86          addr, (unsigned long)GetLastError(), (unsigned long)dwOldProtect);
  87   }
  88 #elif defined(openbsd_HOST_OS) || defined(linux_HOST_OS)
  89   /* malloced memory isn't executable by default on OpenBSD */
  90   my_uintptr_t pageSize         = sysconf(_SC_PAGESIZE);
  91   my_uintptr_t mask             = ~(pageSize - 1);
  92   my_uintptr_t startOfFirstPage = ((my_uintptr_t)addr          ) & mask;
  93   my_uintptr_t startOfLastPage  = ((my_uintptr_t)addr + len - 1) & mask;
  94   my_uintptr_t size             = startOfLastPage - startOfFirstPage + pageSize;
  95   if (mprotect((void*)startOfFirstPage, (size_t)size, PROT_EXEC | PROT_READ | PROT_WRITE) != 0) {
  96     barf("mallocBytesRWX: failed to protect 0x%p\n", addr);
  97   }
  98 #endif
  99   return addr;
 100 }
 101
 102 #ifdef LEADING_UNDERSCORE
 103 #define UNDERSCORE "_"
 104 #else
 105 #define UNDERSCORE ""
 106 #endif
 107 #if defined(i386_HOST_ARCH)
 108 /*
 109   Now here's something obscure for you:
 110
 111   When generating an adjustor thunk that uses the C calling
 112   convention, we have to make sure that the thunk kicks off
 113   the process of jumping into Haskell with a tail jump. Why?
 114   Because as a result of jumping in into Haskell we may end
 115   up freeing the very adjustor thunk we came from using
 116   freeHaskellFunctionPtr(). Hence, we better not return to
 117   the adjustor code on our way  out, since it could by then
 118   point to junk.
 119
 120   The fix is readily at hand, just include the opcodes
 121   for the C stack fixup code that we need to perform when
 122   returning in some static piece of memory and arrange
 123   to return to it before tail jumping from the adjustor thunk.
 124 */
 125 __asm__ (
 126    ".globl " UNDERSCORE "obscure_ccall_ret_code\n"
 127    UNDERSCORE "obscure_ccall_ret_code:\n\t"
 128    "addl $0x4, %esp\n\t"
 129    "ret"
 130   );
 131 extern void obscure_ccall_ret_code(void);
 132 #endif
 133
 134 #if defined(x86_64_HOST_ARCH)
 135 __asm__ (
 136    ".globl " UNDERSCORE "obscure_ccall_ret_code\n"
 137    UNDERSCORE "obscure_ccall_ret_code:\n\t"
 138    "addq $0x8, %rsp\n\t"
 139    "ret"
 140   );
 141 extern void obscure_ccall_ret_code(void);
 142 #endif
 143
 144 #if defined(alpha_HOST_ARCH)
 145 /* To get the definition of PAL_imb: */
 146 # if defined(linux_HOST_OS)
 147 #  include <asm/pal.h>
 148 # else
 149 #  include <machine/pal.h>
 150 # endif
 151 #endif
 152
 153 #if defined(ia64_HOST_ARCH)
 154 #include "Storage.h"
 155
 156 /* Layout of a function descriptor */
 157 typedef struct _IA64FunDesc {
 158     StgWord64 ip;
 159     StgWord64 gp;
 160 } IA64FunDesc;
 161
 162 static void *
 163 stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
 164 {
 165   StgArrWords* arr;
 166   nat data_size_in_words, total_size_in_words;
 167
 168   /* round up to a whole number of words */
 169   data_size_in_words  = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_);
 170   total_size_in_words = sizeofW(StgArrWords) + data_size_in_words;
 171
 172   /* allocate and fill it in */
 173   arr = (StgArrWords *)allocate(total_size_in_words);
 174   SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words);
 175
 176   /* obtain a stable ptr */
 177   *stable = getStablePtr((StgPtr)arr);
 178
 179   /* and return a ptr to the goods inside the array */
 180   return(BYTE_ARR_CTS(arr));
 181 }
 182 #endif
 183
 184 #if defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 185 __asm__("obscure_ccall_ret_code:\n\t"
 186         "lwz 1,0(1)\n\t"
 187         "lwz 0,4(1)\n\t"
 188         "mtlr 0\n\t"
 189         "blr");
 190 extern void obscure_ccall_ret_code(void);
 191 #endif
 192
 193 #if defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 194 #if !(defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS))
 195
 196 /* !!! !!! WARNING: !!! !!!
 197  * This structure is accessed from AdjustorAsm.s
 198  * Any changes here have to be mirrored in the offsets there.
 199  */
 200
 201 typedef struct AdjustorStub {
 202 #if defined(powerpc_HOST_ARCH) && defined(darwin_HOST_OS)
 203     unsigned        lis;
 204     unsigned        ori;
 205     unsigned        lwz;
 206     unsigned        mtctr;
 207     unsigned        bctr;
 208     StgFunPtr       code;
 209 #elif defined(powerpc64_HOST_ARCH) && defined(darwin_HOST_OS)
 210         /* powerpc64-darwin: just guessing that it won't use fundescs. */
 211     unsigned        lis;
 212     unsigned        ori;
 213     unsigned        rldimi;
 214     unsigned        oris;
 215     unsigned        ori2;
 216     unsigned        lwz;
 217     unsigned        mtctr;
 218     unsigned        bctr;
 219     StgFunPtr       code;
 220 #else
 221         /* fundesc-based ABIs */
 222 #define         FUNDESCS
 223     StgFunPtr       code;
 224     struct AdjustorStub
 225                     *toc;
 226     void            *env;
 227 #endif
 228     StgStablePtr    hptr;
 229     StgFunPtr       wptr;
 230     StgInt          negative_framesize;
 231     StgInt          extrawords_plus_one;
 232 } AdjustorStub;
 233
 234 #endif
 235 #endif
 236
 237 void*
 238 createAdjustor(int cconv, StgStablePtr hptr,
 239                StgFunPtr wptr,
 240                char *typeString
 241 #if !defined(powerpc_HOST_ARCH) && !defined(powerpc64_HOST_ARCH) && !defined(x86_64_HOST_ARCH)
 242                   STG_UNUSED
 243 #endif
 244               )
 245 {
 246   void *adjustor = NULL;
 247
 248   switch (cconv)
 249   {
 250   case 0: /* _stdcall */
 251 #if defined(i386_HOST_ARCH)
 252     /* Magic constant computed by inspecting the code length of
 253        the following assembly language snippet
 254        (offset and machine code prefixed):
 255
 256      <0>:       58                popl   %eax              # temp. remove ret addr..
 257      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
 258                                                            # hold a StgStablePtr
 259      <6>:       50                pushl  %eax              # put back ret. addr
 260      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
 261      <c>:       ff e0             jmp    %eax              # and jump to it.
 262                 # the callee cleans up the stack
 263     */
 264     adjustor = mallocBytesRWX(14);
 265     {
 266         unsigned char *const adj_code = (unsigned char *)adjustor;
 267         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 268
 269         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 270         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 271
 272         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 273
 274         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 275         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 276
 277         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 278         adj_code[0x0d] = (unsigned char)0xe0;
 279     }
 280 #endif
 281     break;
 282
 283   case 1: /* _ccall */
 284 #if defined(i386_HOST_ARCH)
 285   /* Magic constant computed by inspecting the code length of
 286      the following assembly language snippet
 287      (offset and machine code prefixed):
 288
 289   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 290                                                    # hold a StgStablePtr
 291   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 292   <0a>: 68 ef be ad de     pushl  $obscure_ccall_ret_code # push the return address
 293   <0f>: ff e0              jmp    *%eax            # jump to wptr
 294
 295     The ccall'ing version is a tad different, passing in the return
 296     address of the caller to the auto-generated C stub (which enters
 297     via the stable pointer.) (The auto-generated C stub is in on this
 298     game, don't worry :-)
 299
 300     See the comment next to obscure_ccall_ret_code why we need to
 301     perform a tail jump instead of a call, followed by some C stack
 302     fixup.
 303
 304     Note: The adjustor makes the assumption that any return value
 305     coming back from the C stub is not stored on the stack.
 306     That's (thankfully) the case here with the restricted set of
 307     return types that we support.
 308   */
 309     adjustor = mallocBytesRWX(17);
 310     {
 311         unsigned char *const adj_code = (unsigned char *)adjustor;
 312
 313         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 314         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 315
 316         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 317         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 318
 319         adj_code[0x0a] = (unsigned char)0x68;  /* pushl obscure_ccall_ret_code */
 320         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)obscure_ccall_ret_code;
 321
 322         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 323         adj_code[0x10] = (unsigned char)0xe0;
 324     }
 325 #elif defined(x86_64_HOST_ARCH)
 326     /*
 327       stack at call:
 328                argn
 329                ...
 330                arg7
 331                return address
 332                %rdi,%rsi,%rdx,%rcx,%r8,%r9 = arg0..arg6
 333
 334       if there are <6 integer args, then we can just push the
 335       StablePtr into %edi and shuffle the other args up.
 336
 337       If there are >=6 integer args, then we have to flush one arg
 338       to the stack, and arrange to adjust the stack ptr on return.
 339       The stack will be rearranged to this:
 340
 341              argn
 342              ...
 343              arg7
 344              return address  *** <-- dummy arg in stub fn.
 345              arg6
 346              obscure_ccall_ret_code
 347
 348       This unfortunately means that the type of the stub function
 349       must have a dummy argument for the original return address
 350       pointer inserted just after the 6th integer argument.
 351
 352       Code for the simple case:
 353
 354    0:   4d 89 c1                mov    %r8,%r9
 355    3:   49 89 c8                mov    %rcx,%r8
 356    6:   48 89 d1                mov    %rdx,%rcx
 357    9:   48 89 f2                mov    %rsi,%rdx
 358    c:   48 89 fe                mov    %rdi,%rsi
 359    f:   48 8b 3d 0a 00 00 00    mov    10(%rip),%rdi
 360   16:   e9 00 00 00 00          jmpq   stub_function
 361   ...
 362   20: .quad 0  # aligned on 8-byte boundary
 363
 364
 365   And the version for >=6 integer arguments:
 366
 367    0:   41 51                   push   %r9
 368    2:   68 00 00 00 00          pushq  $obscure_ccall_ret_code
 369    7:   4d 89 c1                mov    %r8,%r9
 370    a:   49 89 c8                mov    %rcx,%r8
 371    d:   48 89 d1                mov    %rdx,%rcx
 372   10:   48 89 f2                mov    %rsi,%rdx
 373   13:   48 89 fe                mov    %rdi,%rsi
 374   16:   48 8b 3d 0b 00 00 00    mov    11(%rip),%rdi
 375   1d:   e9 00 00 00 00          jmpq   stub_function
 376   ...
 377   28: .quad 0  # aligned on 8-byte boundary
 378     */
 379
 380     /* we assume the small code model (gcc -mcmmodel=small) where
 381      * all symbols are <2^32, so hence wptr should fit into 32 bits.
 382      */
 383     ASSERT(((long)wptr >> 32) == 0);
 384
 385     {
 386         int i = 0;
 387         char *c;
 388
 389         // determine whether we have 6 or more integer arguments,
 390         // and therefore need to flush one to the stack.
 391         for (c = typeString; *c != '\0'; c++) {
 392             if (*c == 'i' || *c == 'l') i++;
 393             if (i == 6) break;
 394         }
 395
 396         if (i < 6) {
 397             adjustor = mallocBytesRWX(40);
 398
 399             *(StgInt32 *)adjustor      = 0x49c1894d;
 400             *(StgInt32 *)(adjustor+4)  = 0x8948c889;
 401             *(StgInt32 *)(adjustor+8)  = 0xf28948d1;
 402             *(StgInt32 *)(adjustor+12) = 0x48fe8948;
 403             *(StgInt32 *)(adjustor+16) = 0x000a3d8b;
 404             *(StgInt32 *)(adjustor+20) = 0x00e90000;
 405
 406             *(StgInt32 *)(adjustor+23) =
 407                 (StgInt32)((StgInt64)wptr - (StgInt64)adjustor - 27);
 408             *(StgInt64 *)(adjustor+32) = (StgInt64)hptr;
 409         }
 410         else
 411         {
 412             adjustor = mallocBytesRWX(48);
 413
 414             *(StgInt32 *)adjustor      = 0x00685141;
 415             *(StgInt32 *)(adjustor+4)  = 0x4d000000;
 416             *(StgInt32 *)(adjustor+8)  = 0x8949c189;
 417             *(StgInt32 *)(adjustor+12) = 0xd18948c8;
 418             *(StgInt32 *)(adjustor+16) = 0x48f28948;
 419             *(StgInt32 *)(adjustor+20) = 0x8b48fe89;
 420             *(StgInt32 *)(adjustor+24) = 0x00000b3d;
 421             *(StgInt32 *)(adjustor+28) = 0x0000e900;
 422
 423             *(StgInt32 *)(adjustor+3) =
 424                 (StgInt32)(StgInt64)obscure_ccall_ret_code;
 425             *(StgInt32 *)(adjustor+30) =
 426                 (StgInt32)((StgInt64)wptr - (StgInt64)adjustor - 34);
 427             *(StgInt64 *)(adjustor+40) = (StgInt64)hptr;
 428         }
 429     }
 430 #elif defined(sparc_HOST_ARCH)
 431   /* Magic constant computed by inspecting the code length of the following
 432      assembly language snippet (offset and machine code prefixed):
 433
 434      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 435      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 436      <08>: D823A05C   st    %o4, [%sp + 92]
 437      <0C>: 9A10000B   mov   %o3, %o5
 438      <10>: 9810000A   mov   %o2, %o4
 439      <14>: 96100009   mov   %o1, %o3
 440      <18>: 94100008   mov   %o0, %o2
 441      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 442      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 443      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 444      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 445      <2C>  00000000                             ! place for getting hptr back easily
 446
 447      ccall'ing on SPARC is easy, because we are quite lucky to push a
 448      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 449      existing arguments (note that %sp must stay double-word aligned at
 450      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 451      To do this, we extend the *caller's* stack frame by 2 words and shift
 452      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 453      procedure because of the tail-jump) by 2 positions. This makes room in
 454      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 455      for destination addr of jump on SPARC, return address on x86, ...). This
 456      shouldn't cause any problems for a C-like caller: alloca is implemented
 457      similarly, and local variables should be accessed via %fp, not %sp. In a
 458      nutshell: This should work! (Famous last words! :-)
 459   */
 460     adjustor = mallocBytesRWX(4*(11+1));
 461     {
 462         unsigned long *const adj_code = (unsigned long *)adjustor;
 463
 464         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 465         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 466         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 467         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 468         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 469         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 470         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 471         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 472         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 473         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 474         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 475         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 476         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 477         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 478         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 479
 480         adj_code[11]  = (unsigned long)hptr;
 481
 482         /* flush cache */
 483         asm("flush %0" : : "r" (adj_code     ));
 484         asm("flush %0" : : "r" (adj_code +  2));
 485         asm("flush %0" : : "r" (adj_code +  4));
 486         asm("flush %0" : : "r" (adj_code +  6));
 487         asm("flush %0" : : "r" (adj_code + 10));
 488
 489         /* max. 5 instructions latency, and we need at >= 1 for returning */
 490         asm("nop");
 491         asm("nop");
 492         asm("nop");
 493         asm("nop");
 494     }
 495 #elif defined(alpha_HOST_ARCH)
 496   /* Magic constant computed by inspecting the code length of
 497      the following assembly language snippet
 498      (offset and machine code prefixed; note that the machine code
 499      shown is longwords stored in little-endian order):
 500
 501   <00>: 46520414        mov     a2, a4
 502   <04>: 46100412        mov     a0, a2
 503   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 504   <0c>: 46730415        mov     a3, a5
 505   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 506   <14>: 46310413        mov     a1, a3
 507   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 508   <1c>: 00000000                                # padding for alignment
 509   <20>: [8 bytes for hptr quadword]
 510   <28>: [8 bytes for wptr quadword]
 511
 512      The "computed" jump at <08> above is really a jump to a fixed
 513      location.  Accordingly, we place an always-correct hint in the
 514      jump instruction, namely the address offset from <0c> to wptr,
 515      divided by 4, taking the lowest 14 bits.
 516
 517      We only support passing 4 or fewer argument words, for the same
 518      reason described under sparc_HOST_ARCH above by JRS, 21 Aug 01.
 519      On the Alpha the first 6 integer arguments are in a0 through a5,
 520      and the rest on the stack.  Hence we want to shuffle the original
 521      caller's arguments by two.
 522
 523      On the Alpha the calling convention is so complex and dependent
 524      on the callee's signature -- for example, the stack pointer has
 525      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 526      to handle the general case correctly without changing how the
 527      adjustor is called from C.  For now, our solution of shuffling
 528      registers only and ignoring the stack only works if the original
 529      caller passed 4 or fewer argument words.
 530
 531 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 532       header information (more precisely, if the overhead is no more than
 533       4 bytes), we should move the first three instructions above down by
 534       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 535   */
 536     ASSERT(((StgWord64)wptr & 3) == 0);
 537     adjustor = mallocBytesRWX(48);
 538     {
 539         StgWord64 *const code = (StgWord64 *)adjustor;
 540
 541         code[0] = 0x4610041246520414L;
 542         code[1] = 0x46730415a61b0020L;
 543         code[2] = 0x46310413a77b0028L;
 544         code[3] = 0x000000006bfb0000L
 545                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 546
 547         code[4] = (StgWord64)hptr;
 548         code[5] = (StgWord64)wptr;
 549
 550         /* Ensure that instruction cache is consistent with our new code */
 551         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 552     }
 553 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 554
 555 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 556 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 557     {
 558         /* The PowerPC Linux (32-bit) calling convention is annoyingly complex.
 559            We need to calculate all the details of the stack frame layout,
 560            taking into account the types of all the arguments, and then
 561            generate code on the fly. */
 562
 563         int src_gpr = 3, dst_gpr = 5;
 564         int fpr = 3;
 565         int src_offset = 0, dst_offset = 0;
 566         int n = strlen(typeString),i;
 567         int src_locs[n], dst_locs[n];
 568         int frameSize;
 569         unsigned *code;
 570
 571             /* Step 1:
 572                Calculate where the arguments should go.
 573                src_locs[] will contain the locations of the arguments in the
 574                original stack frame passed to the adjustor.
 575                dst_locs[] will contain the locations of the arguments after the
 576                adjustor runs, on entry to the wrapper proc pointed to by wptr.
 577
 578                This algorithm is based on the one described on page 3-19 of the
 579                System V ABI PowerPC Processor Supplement.
 580             */
 581         for(i=0;typeString[i];i++)
 582         {
 583             char t = typeString[i];
 584             if((t == 'f' || t == 'd') && fpr <= 8)
 585                 src_locs[i] = dst_locs[i] = -32-(fpr++);
 586             else
 587             {
 588                 if(t == 'l' && src_gpr <= 9)
 589                 {
 590                     if((src_gpr & 1) == 0)
 591                         src_gpr++;
 592                     src_locs[i] = -src_gpr;
 593                     src_gpr += 2;
 594                 }
 595                 else if(t == 'i' && src_gpr <= 10)
 596                 {
 597                     src_locs[i] = -(src_gpr++);
 598                 }
 599                 else
 600                 {
 601                     if(t == 'l' || t == 'd')
 602                     {
 603                         if(src_offset % 8)
 604                             src_offset += 4;
 605                     }
 606                     src_locs[i] = src_offset;
 607                     src_offset += (t == 'l' || t == 'd') ? 8 : 4;
 608                 }
 609
 610                 if(t == 'l' && dst_gpr <= 9)
 611                 {
 612                     if((dst_gpr & 1) == 0)
 613                         dst_gpr++;
 614                     dst_locs[i] = -dst_gpr;
 615                     dst_gpr += 2;
 616                 }
 617                 else if(t == 'i' && dst_gpr <= 10)
 618                 {
 619                     dst_locs[i] = -(dst_gpr++);
 620                 }
 621                 else
 622                 {
 623                     if(t == 'l' || t == 'd')
 624                     {
 625                         if(dst_offset % 8)
 626                             dst_offset += 4;
 627                     }
 628                     dst_locs[i] = dst_offset;
 629                     dst_offset += (t == 'l' || t == 'd') ? 8 : 4;
 630                 }
 631             }
 632         }
 633
 634         frameSize = dst_offset + 8;
 635         frameSize = (frameSize+15) & ~0xF;
 636
 637             /* Step 2:
 638                Build the adjustor.
 639             */
 640                     // allocate space for at most 4 insns per parameter
 641                     // plus 14 more instructions.
 642         adjustor = mallocBytesRWX(4 * (4*n + 14));
 643         code = (unsigned*)adjustor;
 644
 645         *code++ = 0x48000008; // b *+8
 646             // * Put the hptr in a place where freeHaskellFunctionPtr
 647             //   can get at it.
 648         *code++ = (unsigned) hptr;
 649
 650             // * save the link register
 651         *code++ = 0x7c0802a6; // mflr r0;
 652         *code++ = 0x90010004; // stw r0, 4(r1);
 653             // * and build a new stack frame
 654         *code++ = OP_LO(0x9421, -frameSize); // stwu r1, -frameSize(r1)
 655
 656             // * now generate instructions to copy arguments
 657             //   from the old stack frame into the new stack frame.
 658         for(i=n-1;i>=0;i--)
 659         {
 660             if(src_locs[i] < -32)
 661                 ASSERT(dst_locs[i] == src_locs[i]);
 662             else if(src_locs[i] < 0)
 663             {
 664                 // source in GPR.
 665                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 666                 if(dst_locs[i] < 0)
 667                 {
 668                     ASSERT(dst_locs[i] > -32);
 669                         // dst is in GPR, too.
 670
 671                     if(typeString[i] == 'l')
 672                     {
 673                             // mr dst+1, src+1
 674                         *code++ = 0x7c000378
 675                                 | ((-dst_locs[i]+1) << 16)
 676                                 | ((-src_locs[i]+1) << 11)
 677                                 | ((-src_locs[i]+1) << 21);
 678                     }
 679                     // mr dst, src
 680                     *code++ = 0x7c000378
 681                             | ((-dst_locs[i]) << 16)
 682                             | ((-src_locs[i]) << 11)
 683                             | ((-src_locs[i]) << 21);
 684                 }
 685                 else
 686                 {
 687                     if(typeString[i] == 'l')
 688                     {
 689                             // stw src+1, dst_offset+4(r1)
 690                         *code++ = 0x90010000
 691                                 | ((-src_locs[i]+1) << 21)
 692                                 | (dst_locs[i] + 4);
 693                     }
 694
 695                         // stw src, dst_offset(r1)
 696                     *code++ = 0x90010000
 697                             | ((-src_locs[i]) << 21)
 698                             | (dst_locs[i] + 8);
 699                 }
 700             }
 701             else
 702             {
 703                 ASSERT(dst_locs[i] >= 0);
 704                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 705
 706                 if(typeString[i] == 'l')
 707                 {
 708                     // lwz r0, src_offset(r1)
 709                         *code++ = 0x80010000
 710                                 | (src_locs[i] + frameSize + 8 + 4);
 711                     // stw r0, dst_offset(r1)
 712                         *code++ = 0x90010000
 713                                 | (dst_locs[i] + 8 + 4);
 714                     }
 715                 // lwz r0, src_offset(r1)
 716                     *code++ = 0x80010000
 717                             | (src_locs[i] + frameSize + 8);
 718                 // stw r0, dst_offset(r1)
 719                     *code++ = 0x90010000
 720                             | (dst_locs[i] + 8);
 721            }
 722         }
 723
 724             // * hptr will be the new first argument.
 725             // lis r3, hi(hptr)
 726         *code++ = OP_HI(0x3c60, hptr);
 727             // ori r3,r3,lo(hptr)
 728         *code++ = OP_LO(0x6063, hptr);
 729
 730             // * we need to return to a piece of code
 731             //   which will tear down the stack frame.
 732             // lis r11,hi(obscure_ccall_ret_code)
 733         *code++ = OP_HI(0x3d60, obscure_ccall_ret_code);
 734             // ori r11,r11,lo(obscure_ccall_ret_code)
 735         *code++ = OP_LO(0x616b, obscure_ccall_ret_code);
 736             // mtlr r11
 737         *code++ = 0x7d6803a6;
 738
 739             // * jump to wptr
 740             // lis r11,hi(wptr)
 741         *code++ = OP_HI(0x3d60, wptr);
 742             // ori r11,r11,lo(wptr)
 743         *code++ = OP_LO(0x616b, wptr);
 744             // mtctr r11
 745         *code++ = 0x7d6903a6;
 746             // bctr
 747         *code++ = 0x4e800420;
 748
 749         // Flush the Instruction cache:
 750         {
 751             unsigned *p = adjustor;
 752             while(p < code)
 753             {
 754                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 755                                  : : "r" (p));
 756                 p++;
 757             }
 758             __asm__ volatile ("sync\n\tisync");
 759         }
 760     }
 761
 762 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 763
 764 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 765 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 766     {
 767         /* The following code applies to all PowerPC and PowerPC64 platforms
 768            whose stack layout is based on the AIX ABI.
 769
 770            Besides (obviously) AIX, this includes
 771             Mac OS 9 and BeOS/PPC (may they rest in peace),
 772                 which use the 32-bit AIX ABI
 773             powerpc64-linux,
 774                 which uses the 64-bit AIX ABI
 775             and Darwin (Mac OS X),
 776                 which uses the same stack layout as AIX,
 777                 but no function descriptors.
 778
 779            The actual stack-frame shuffling is implemented out-of-line
 780            in the function adjustorCode, in AdjustorAsm.S.
 781            Here, we set up an AdjustorStub structure, which
 782            is a function descriptor (on platforms that have function
 783            descriptors) or a short piece of stub code (on Darwin) to call
 784            adjustorCode with a pointer to the AdjustorStub struct loaded
 785            into register r2.
 786
 787            One nice thing about this is that there is _no_ code generated at
 788            runtime on the platforms that have function descriptors.
 789         */
 790         AdjustorStub *adjustorStub;
 791         int sz = 0, extra_sz, total_sz;
 792
 793             // from AdjustorAsm.s
 794             // not declared as a function so that AIX-style
 795             // fundescs can never get in the way.
 796         extern void *adjustorCode;
 797
 798 #ifdef FUNDESCS
 799         adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
 800 #else
 801         adjustorStub = mallocBytesRWX(sizeof(AdjustorStub));
 802 #endif
 803         adjustor = adjustorStub;
 804
 805         adjustorStub->code = (void*) &adjustorCode;
 806
 807 #ifdef FUNDESCS
 808             // function descriptors are a cool idea.
 809             // We don't need to generate any code at runtime.
 810         adjustorStub->toc = adjustorStub;
 811 #else
 812
 813             // no function descriptors :-(
 814             // We need to do things "by hand".
 815 #if defined(powerpc_HOST_ARCH)
 816             // lis  r2, hi(adjustorStub)
 817         adjustorStub->lis = OP_HI(0x3c40, adjustorStub);
 818             // ori  r2, r2, lo(adjustorStub)
 819         adjustorStub->ori = OP_LO(0x6042, adjustorStub);
 820             // lwz r0, code(r2)
 821         adjustorStub->lwz = OP_LO(0x8002, (char*)(&adjustorStub->code)
 822                                         - (char*)adjustorStub);
 823             // mtctr r0
 824         adjustorStub->mtctr = 0x7c0903a6;
 825             // bctr
 826         adjustorStub->bctr = 0x4e800420;
 827 #else
 828         barf("adjustor creation not supported on this platform");
 829 #endif
 830
 831         // Flush the Instruction cache:
 832         {
 833             int n = sizeof(AdjustorStub)/sizeof(unsigned);
 834             unsigned *p = (unsigned*)adjustor;
 835             while(n--)
 836             {
 837                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 838                                     : : "r" (p));
 839                 p++;
 840             }
 841             __asm__ volatile ("sync\n\tisync");
 842         }
 843 #endif
 844
 845             // Calculate the size of the stack frame, in words.
 846         while(*typeString)
 847         {
 848             char t = *typeString++;
 849
 850             switch(t)
 851             {
 852 #if defined(powerpc_HOST_ARCH)
 853                     // on 32-bit platforms, Double and Int64 occupy two words.
 854                 case 'd':
 855                 case 'l':
 856                     sz += 2;
 857                     break;
 858 #endif
 859                     // everything else is one word.
 860                 default:
 861                     sz += 1;
 862             }
 863         }
 864             // The first eight words of the parameter area
 865             // are just "backing store" for the parameters passed in
 866             // the GPRs. extra_sz is the number of words beyond those first
 867             // 8 words.
 868         extra_sz = sz - 8;
 869         if(extra_sz < 0)
 870             extra_sz = 0;
 871
 872             // Calculate the total size of the stack frame.
 873         total_sz = (6 /* linkage area */
 874                   + 8 /* minimum parameter area */
 875                   + 2 /* two extra arguments */
 876                   + extra_sz)*sizeof(StgWord);
 877
 878             // align to 16 bytes.
 879             // AIX only requires 8 bytes, but who cares?
 880         total_sz = (total_sz+15) & ~0xF;
 881
 882             // Fill in the information that adjustorCode in AdjustorAsm.S
 883             // will use to create a new stack frame with the additional args.
 884         adjustorStub->hptr = hptr;
 885         adjustorStub->wptr = wptr;
 886         adjustorStub->negative_framesize = -total_sz;
 887         adjustorStub->extrawords_plus_one = extra_sz + 1;
 888     }
 889
 890 #elif defined(ia64_HOST_ARCH)
 891 /*
 892     Up to 8 inputs are passed in registers.  We flush the last two inputs to
 893     the stack, initially into the 16-byte scratch region left by the caller.
 894     We then shuffle the others along by 4 (taking 2 registers for ourselves
 895     to save return address and previous function state - we need to come back
 896     here on the way out to restore the stack, so this is a real function
 897     rather than just a trampoline).
 898
 899     The function descriptor we create contains the gp of the target function
 900     so gp is already loaded correctly.
 901
 902         [MLX]       alloc r16=ar.pfs,10,2,0
 903                     movl r17=wptr
 904         [MII]       st8.spill [r12]=r38,8               // spill in6 (out4)
 905                     mov r41=r37                         // out7 = in5 (out3)
 906                     mov r40=r36;;                       // out6 = in4 (out2)
 907         [MII]       st8.spill [r12]=r39                 // spill in7 (out5)
 908                     mov.sptk b6=r17,50
 909                     mov r38=r34;;                       // out4 = in2 (out0)
 910         [MII]       mov r39=r35                         // out5 = in3 (out1)
 911                     mov r37=r33                         // out3 = in1 (loc1)
 912                     mov r36=r32                         // out2 = in0 (loc0)
 913         [MLX]       adds r12=-24,r12                    // update sp
 914                     movl r34=hptr;;                     // out0 = hptr
 915         [MIB]       mov r33=r16                         // loc1 = ar.pfs
 916                     mov r32=b0                          // loc0 = retaddr
 917                     br.call.sptk.many b0=b6;;
 918
 919         [MII]       adds r12=-16,r12
 920                     mov b0=r32
 921                     mov.i ar.pfs=r33
 922         [MFB]       nop.m 0x0
 923                     nop.f 0x0
 924                     br.ret.sptk.many b0;;
 925 */
 926
 927 /* These macros distribute a long constant into the two words of an MLX bundle */
 928 #define BITS(val,start,count)   (((val) >> (start)) & ((1 << (count))-1))
 929 #define MOVL_LOWORD(val)        (BITS(val,22,18) << 46)
 930 #define MOVL_HIWORD(val)        (BITS(val,40,23) | (BITS(val,0,7) << 36) | (BITS(val,7,9) << 50) \
 931                                 | (BITS(val,16,5) << 55) | (BITS(val,21,1) << 44) | BITS(val,63,1) << 59)
 932
 933     {
 934         StgStablePtr stable;
 935         IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
 936         StgWord64 wcode = wdesc->ip;
 937         IA64FunDesc *fdesc;
 938         StgWord64 *code;
 939
 940         /* we allocate on the Haskell heap since malloc'd memory isn't executable - argh */
 941         adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8, &stable);
 942
 943         fdesc = (IA64FunDesc *)adjustor;
 944         code = (StgWord64 *)(fdesc + 1);
 945         fdesc->ip = (StgWord64)code;
 946         fdesc->gp = wdesc->gp;
 947
 948         code[0]  = 0x0000058004288004 | MOVL_LOWORD(wcode);
 949         code[1]  = 0x6000000220000000 | MOVL_HIWORD(wcode);
 950         code[2]  = 0x029015d818984001;
 951         code[3]  = 0x8401200500420094;
 952         code[4]  = 0x886011d8189c0001;
 953         code[5]  = 0x84011004c00380c0;
 954         code[6]  = 0x0250210046013800;
 955         code[7]  = 0x8401000480420084;
 956         code[8]  = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr);
 957         code[9]  = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr);
 958         code[10] = 0x0200210020010811;
 959         code[11] = 0x1080006800006200;
 960         code[12] = 0x0000210018406000;
 961         code[13] = 0x00aa021000038005;
 962         code[14] = 0x000000010000001d;
 963         code[15] = 0x0084000880000200;
 964
 965         /* save stable pointers in convenient form */
 966         code[16] = (StgWord64)hptr;
 967         code[17] = (StgWord64)stable;
 968     }
 969 #else
 970     barf("adjustor creation not supported on this platform");
 971 #endif
 972     break;
 973
 974   default:
 975     ASSERT(0);
 976     break;
 977   }
 978
 979   /* Have fun! */
 980   return adjustor;
 981 }
 982
 983
 984 void
 985 freeHaskellFunctionPtr(void* ptr)
 986 {
 987 #if defined(i386_HOST_ARCH)
 988  if ( *(unsigned char*)ptr != 0x68 &&
 989       *(unsigned char*)ptr != 0x58 ) {
 990    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 991    return;
 992  }
 993
 994  /* Free the stable pointer first..*/
 995  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 996     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 997  } else {
 998     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 999  }
1000 #elif defined(x86_64_HOST_ARCH)
1001  if ( *(StgWord16 *)ptr == 0x894d ) {
1002      freeStablePtr(*(StgStablePtr*)(ptr+32));
1003  } else if ( *(StgWord16 *)ptr == 0x5141 ) {
1004      freeStablePtr(*(StgStablePtr*)(ptr+40));
1005  } else {
1006    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1007    return;
1008  }
1009 #elif defined(sparc_HOST_ARCH)
1010  if ( *(unsigned long*)ptr != 0x9C23A008UL ) {
1011    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1012    return;
1013  }
1014
1015  /* Free the stable pointer first..*/
1016  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11)));
1017 #elif defined(alpha_HOST_ARCH)
1018  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
1019    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1020    return;
1021  }
1022
1023  /* Free the stable pointer first..*/
1024  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
1025 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
1026  if ( *(StgWord*)ptr != 0x48000008 ) {
1027    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1028    return;
1029  }
1030  freeStablePtr(((StgStablePtr*)ptr)[1]);
1031 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
1032  extern void* adjustorCode;
1033  if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
1034    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1035    return;
1036  }
1037  freeStablePtr(((AdjustorStub*)ptr)->hptr);
1038 #elif defined(ia64_HOST_ARCH)
1039  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
1040  StgWord64 *code = (StgWord64 *)(fdesc+1);
1041
1042  if (fdesc->ip != (StgWord64)code) {
1043    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1044    return;
1045  }
1046  freeStablePtr((StgStablePtr)code[16]);
1047  freeStablePtr((StgStablePtr)code[17]);
1048  return;
1049 #else
1050  ASSERT(0);
1051 #endif
1052  *((unsigned char*)ptr) = '\0';
1053
1054  stgFree(ptr);
1055 }
1056
1057
1058 /*
1059  * Function: initAdjustor()
1060  *
1061  * Perform initialisation of adjustor thunk layer (if needed.)
1062  */
1063 void
1064 initAdjustor(void)
1065 {
1066 }