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