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