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