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     /* we assume the small code model (gcc -mcmmodel=small) where
 421      * all symbols are <2^32, so hence wptr should fit into 32 bits.
 422      */
 423     ASSERT(((long)wptr >> 32) == 0);
 424
 425     {
 426         int i = 0;
 427         char *c;
 428
 429         // determine whether we have 6 or more integer arguments,
 430         // and therefore need to flush one to the stack.
 431         for (c = typeString; *c != '\0'; c++) {
 432             if (*c == 'i' || *c == 'l') i++;
 433             if (i == 6) break;
 434         }
 435
 436         if (i < 6) {
 437             adjustor = allocateExec(0x30);
 438
 439             *(StgInt32 *)adjustor        = 0x49c1894d;
 440             *(StgInt32 *)(adjustor+0x4)  = 0x8948c889;
 441             *(StgInt32 *)(adjustor+0x8)  = 0xf28948d1;
 442             *(StgInt32 *)(adjustor+0xc)  = 0x48fe8948;
 443             *(StgInt32 *)(adjustor+0x10) = 0x000a3d8b;
 444             *(StgInt32 *)(adjustor+0x14) = 0x25ff0000;
 445             *(StgInt32 *)(adjustor+0x18) = 0x0000000c;
 446             *(StgInt64 *)(adjustor+0x20) = (StgInt64)hptr;
 447             *(StgInt64 *)(adjustor+0x28) = (StgInt64)wptr;
 448         }
 449         else
 450         {
 451             adjustor = allocateExec(0x40);
 452
 453             *(StgInt32 *)adjustor        = 0x35ff5141;
 454             *(StgInt32 *)(adjustor+0x4)  = 0x00000020;
 455             *(StgInt32 *)(adjustor+0x8)  = 0x49c1894d;
 456             *(StgInt32 *)(adjustor+0xc)  = 0x8948c889;
 457             *(StgInt32 *)(adjustor+0x10) = 0xf28948d1;
 458             *(StgInt32 *)(adjustor+0x14) = 0x48fe8948;
 459             *(StgInt32 *)(adjustor+0x18) = 0x00123d8b;
 460             *(StgInt32 *)(adjustor+0x1c) = 0x25ff0000;
 461             *(StgInt32 *)(adjustor+0x20) = 0x00000014;
 462
 463             *(StgInt64 *)(adjustor+0x28) = (StgInt64)obscure_ccall_ret_code;
 464             *(StgInt64 *)(adjustor+0x30) = (StgInt64)hptr;
 465             *(StgInt64 *)(adjustor+0x38) = (StgInt64)wptr;
 466         }
 467     }
 468 #elif defined(sparc_HOST_ARCH)
 469   /* Magic constant computed by inspecting the code length of the following
 470      assembly language snippet (offset and machine code prefixed):
 471
 472      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 473      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 474      <08>: D823A05C   st    %o4, [%sp + 92]
 475      <0C>: 9A10000B   mov   %o3, %o5
 476      <10>: 9810000A   mov   %o2, %o4
 477      <14>: 96100009   mov   %o1, %o3
 478      <18>: 94100008   mov   %o0, %o2
 479      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 480      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 481      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 482      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 483      <2C>  00000000                             ! place for getting hptr back easily
 484
 485      ccall'ing on SPARC is easy, because we are quite lucky to push a
 486      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 487      existing arguments (note that %sp must stay double-word aligned at
 488      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 489      To do this, we extend the *caller's* stack frame by 2 words and shift
 490      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 491      procedure because of the tail-jump) by 2 positions. This makes room in
 492      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 493      for destination addr of jump on SPARC, return address on x86, ...). This
 494      shouldn't cause any problems for a C-like caller: alloca is implemented
 495      similarly, and local variables should be accessed via %fp, not %sp. In a
 496      nutshell: This should work! (Famous last words! :-)
 497   */
 498     adjustor = allocateExec(4*(11+1));
 499     {
 500         unsigned long *const adj_code = (unsigned long *)adjustor;
 501
 502         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 503         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 504         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 505         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 506         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 507         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 508         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 509         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 510         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 511         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 512         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 513         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 514         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 515         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 516         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 517
 518         adj_code[11]  = (unsigned long)hptr;
 519
 520         /* flush cache */
 521         asm("flush %0" : : "r" (adj_code     ));
 522         asm("flush %0" : : "r" (adj_code +  2));
 523         asm("flush %0" : : "r" (adj_code +  4));
 524         asm("flush %0" : : "r" (adj_code +  6));
 525         asm("flush %0" : : "r" (adj_code + 10));
 526
 527         /* max. 5 instructions latency, and we need at >= 1 for returning */
 528         asm("nop");
 529         asm("nop");
 530         asm("nop");
 531         asm("nop");
 532     }
 533 #elif defined(alpha_HOST_ARCH)
 534   /* Magic constant computed by inspecting the code length of
 535      the following assembly language snippet
 536      (offset and machine code prefixed; note that the machine code
 537      shown is longwords stored in little-endian order):
 538
 539   <00>: 46520414        mov     a2, a4
 540   <04>: 46100412        mov     a0, a2
 541   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 542   <0c>: 46730415        mov     a3, a5
 543   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 544   <14>: 46310413        mov     a1, a3
 545   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 546   <1c>: 00000000                                # padding for alignment
 547   <20>: [8 bytes for hptr quadword]
 548   <28>: [8 bytes for wptr quadword]
 549
 550      The "computed" jump at <08> above is really a jump to a fixed
 551      location.  Accordingly, we place an always-correct hint in the
 552      jump instruction, namely the address offset from <0c> to wptr,
 553      divided by 4, taking the lowest 14 bits.
 554
 555      We only support passing 4 or fewer argument words, for the same
 556      reason described under sparc_HOST_ARCH above by JRS, 21 Aug 01.
 557      On the Alpha the first 6 integer arguments are in a0 through a5,
 558      and the rest on the stack.  Hence we want to shuffle the original
 559      caller's arguments by two.
 560
 561      On the Alpha the calling convention is so complex and dependent
 562      on the callee's signature -- for example, the stack pointer has
 563      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 564      to handle the general case correctly without changing how the
 565      adjustor is called from C.  For now, our solution of shuffling
 566      registers only and ignoring the stack only works if the original
 567      caller passed 4 or fewer argument words.
 568
 569 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 570       header information (more precisely, if the overhead is no more than
 571       4 bytes), we should move the first three instructions above down by
 572       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 573   */
 574     ASSERT(((StgWord64)wptr & 3) == 0);
 575     adjustor = allocateExec(48);
 576     {
 577         StgWord64 *const code = (StgWord64 *)adjustor;
 578
 579         code[0] = 0x4610041246520414L;
 580         code[1] = 0x46730415a61b0020L;
 581         code[2] = 0x46310413a77b0028L;
 582         code[3] = 0x000000006bfb0000L
 583                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 584
 585         code[4] = (StgWord64)hptr;
 586         code[5] = (StgWord64)wptr;
 587
 588         /* Ensure that instruction cache is consistent with our new code */
 589         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 590     }
 591 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
 592
 593 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 594 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 595     {
 596         /* The PowerPC Linux (32-bit) calling convention is annoyingly complex.
 597            We need to calculate all the details of the stack frame layout,
 598            taking into account the types of all the arguments, and then
 599            generate code on the fly. */
 600
 601         int src_gpr = 3, dst_gpr = 5;
 602         int fpr = 3;
 603         int src_offset = 0, dst_offset = 0;
 604         int n = strlen(typeString),i;
 605         int src_locs[n], dst_locs[n];
 606         int frameSize;
 607         unsigned *code;
 608
 609             /* Step 1:
 610                Calculate where the arguments should go.
 611                src_locs[] will contain the locations of the arguments in the
 612                original stack frame passed to the adjustor.
 613                dst_locs[] will contain the locations of the arguments after the
 614                adjustor runs, on entry to the wrapper proc pointed to by wptr.
 615
 616                This algorithm is based on the one described on page 3-19 of the
 617                System V ABI PowerPC Processor Supplement.
 618             */
 619         for(i=0;typeString[i];i++)
 620         {
 621             char t = typeString[i];
 622             if((t == 'f' || t == 'd') && fpr <= 8)
 623                 src_locs[i] = dst_locs[i] = -32-(fpr++);
 624             else
 625             {
 626                 if(t == 'l' && src_gpr <= 9)
 627                 {
 628                     if((src_gpr & 1) == 0)
 629                         src_gpr++;
 630                     src_locs[i] = -src_gpr;
 631                     src_gpr += 2;
 632                 }
 633                 else if(t == 'i' && src_gpr <= 10)
 634                 {
 635                     src_locs[i] = -(src_gpr++);
 636                 }
 637                 else
 638                 {
 639                     if(t == 'l' || t == 'd')
 640                     {
 641                         if(src_offset % 8)
 642                             src_offset += 4;
 643                     }
 644                     src_locs[i] = src_offset;
 645                     src_offset += (t == 'l' || t == 'd') ? 8 : 4;
 646                 }
 647
 648                 if(t == 'l' && dst_gpr <= 9)
 649                 {
 650                     if((dst_gpr & 1) == 0)
 651                         dst_gpr++;
 652                     dst_locs[i] = -dst_gpr;
 653                     dst_gpr += 2;
 654                 }
 655                 else if(t == 'i' && dst_gpr <= 10)
 656                 {
 657                     dst_locs[i] = -(dst_gpr++);
 658                 }
 659                 else
 660                 {
 661                     if(t == 'l' || t == 'd')
 662                     {
 663                         if(dst_offset % 8)
 664                             dst_offset += 4;
 665                     }
 666                     dst_locs[i] = dst_offset;
 667                     dst_offset += (t == 'l' || t == 'd') ? 8 : 4;
 668                 }
 669             }
 670         }
 671
 672         frameSize = dst_offset + 8;
 673         frameSize = (frameSize+15) & ~0xF;
 674
 675             /* Step 2:
 676                Build the adjustor.
 677             */
 678                     // allocate space for at most 4 insns per parameter
 679                     // plus 14 more instructions.
 680         adjustor = allocateExec(4 * (4*n + 14));
 681         code = (unsigned*)adjustor;
 682
 683         *code++ = 0x48000008; // b *+8
 684             // * Put the hptr in a place where freeHaskellFunctionPtr
 685             //   can get at it.
 686         *code++ = (unsigned) hptr;
 687
 688             // * save the link register
 689         *code++ = 0x7c0802a6; // mflr r0;
 690         *code++ = 0x90010004; // stw r0, 4(r1);
 691             // * and build a new stack frame
 692         *code++ = OP_LO(0x9421, -frameSize); // stwu r1, -frameSize(r1)
 693
 694             // * now generate instructions to copy arguments
 695             //   from the old stack frame into the new stack frame.
 696         for(i=n-1;i>=0;i--)
 697         {
 698             if(src_locs[i] < -32)
 699                 ASSERT(dst_locs[i] == src_locs[i]);
 700             else if(src_locs[i] < 0)
 701             {
 702                 // source in GPR.
 703                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 704                 if(dst_locs[i] < 0)
 705                 {
 706                     ASSERT(dst_locs[i] > -32);
 707                         // dst is in GPR, too.
 708
 709                     if(typeString[i] == 'l')
 710                     {
 711                             // mr dst+1, src+1
 712                         *code++ = 0x7c000378
 713                                 | ((-dst_locs[i]+1) << 16)
 714                                 | ((-src_locs[i]+1) << 11)
 715                                 | ((-src_locs[i]+1) << 21);
 716                     }
 717                     // mr dst, src
 718                     *code++ = 0x7c000378
 719                             | ((-dst_locs[i]) << 16)
 720                             | ((-src_locs[i]) << 11)
 721                             | ((-src_locs[i]) << 21);
 722                 }
 723                 else
 724                 {
 725                     if(typeString[i] == 'l')
 726                     {
 727                             // stw src+1, dst_offset+4(r1)
 728                         *code++ = 0x90010000
 729                                 | ((-src_locs[i]+1) << 21)
 730                                 | (dst_locs[i] + 4);
 731                     }
 732
 733                         // stw src, dst_offset(r1)
 734                     *code++ = 0x90010000
 735                             | ((-src_locs[i]) << 21)
 736                             | (dst_locs[i] + 8);
 737                 }
 738             }
 739             else
 740             {
 741                 ASSERT(dst_locs[i] >= 0);
 742                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 743
 744                 if(typeString[i] == 'l')
 745                 {
 746                     // lwz r0, src_offset(r1)
 747                         *code++ = 0x80010000
 748                                 | (src_locs[i] + frameSize + 8 + 4);
 749                     // stw r0, dst_offset(r1)
 750                         *code++ = 0x90010000
 751                                 | (dst_locs[i] + 8 + 4);
 752                     }
 753                 // lwz r0, src_offset(r1)
 754                     *code++ = 0x80010000
 755                             | (src_locs[i] + frameSize + 8);
 756                 // stw r0, dst_offset(r1)
 757                     *code++ = 0x90010000
 758                             | (dst_locs[i] + 8);
 759            }
 760         }
 761
 762             // * hptr will be the new first argument.
 763             // lis r3, hi(hptr)
 764         *code++ = OP_HI(0x3c60, hptr);
 765             // ori r3,r3,lo(hptr)
 766         *code++ = OP_LO(0x6063, hptr);
 767
 768             // * we need to return to a piece of code
 769             //   which will tear down the stack frame.
 770             // lis r11,hi(obscure_ccall_ret_code)
 771         *code++ = OP_HI(0x3d60, obscure_ccall_ret_code);
 772             // ori r11,r11,lo(obscure_ccall_ret_code)
 773         *code++ = OP_LO(0x616b, obscure_ccall_ret_code);
 774             // mtlr r11
 775         *code++ = 0x7d6803a6;
 776
 777             // * jump to wptr
 778             // lis r11,hi(wptr)
 779         *code++ = OP_HI(0x3d60, wptr);
 780             // ori r11,r11,lo(wptr)
 781         *code++ = OP_LO(0x616b, wptr);
 782             // mtctr r11
 783         *code++ = 0x7d6903a6;
 784             // bctr
 785         *code++ = 0x4e800420;
 786
 787         // Flush the Instruction cache:
 788         {
 789             unsigned *p = adjustor;
 790             while(p < code)
 791             {
 792                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 793                                  : : "r" (p));
 794                 p++;
 795             }
 796             __asm__ volatile ("sync\n\tisync");
 797         }
 798     }
 799
 800 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
 801
 802 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 803 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 804     {
 805         /* The following code applies to all PowerPC and PowerPC64 platforms
 806            whose stack layout is based on the AIX ABI.
 807
 808            Besides (obviously) AIX, this includes
 809             Mac OS 9 and BeOS/PPC (may they rest in peace),
 810                 which use the 32-bit AIX ABI
 811             powerpc64-linux,
 812                 which uses the 64-bit AIX ABI
 813             and Darwin (Mac OS X),
 814                 which uses the same stack layout as AIX,
 815                 but no function descriptors.
 816
 817            The actual stack-frame shuffling is implemented out-of-line
 818            in the function adjustorCode, in AdjustorAsm.S.
 819            Here, we set up an AdjustorStub structure, which
 820            is a function descriptor (on platforms that have function
 821            descriptors) or a short piece of stub code (on Darwin) to call
 822            adjustorCode with a pointer to the AdjustorStub struct loaded
 823            into register r2.
 824
 825            One nice thing about this is that there is _no_ code generated at
 826            runtime on the platforms that have function descriptors.
 827         */
 828         AdjustorStub *adjustorStub;
 829         int sz = 0, extra_sz, total_sz;
 830
 831             // from AdjustorAsm.s
 832             // not declared as a function so that AIX-style
 833             // fundescs can never get in the way.
 834         extern void *adjustorCode;
 835
 836 #ifdef FUNDESCS
 837         adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
 838 #else
 839         adjustorStub = allocateExec(sizeof(AdjustorStub));
 840 #endif
 841         adjustor = adjustorStub;
 842
 843         adjustorStub->code = (void*) &adjustorCode;
 844
 845 #ifdef FUNDESCS
 846             // function descriptors are a cool idea.
 847             // We don't need to generate any code at runtime.
 848         adjustorStub->toc = adjustorStub;
 849 #else
 850
 851             // no function descriptors :-(
 852             // We need to do things "by hand".
 853 #if defined(powerpc_HOST_ARCH)
 854             // lis  r2, hi(adjustorStub)
 855         adjustorStub->lis = OP_HI(0x3c40, adjustorStub);
 856             // ori  r2, r2, lo(adjustorStub)
 857         adjustorStub->ori = OP_LO(0x6042, adjustorStub);
 858             // lwz r0, code(r2)
 859         adjustorStub->lwz = OP_LO(0x8002, (char*)(&adjustorStub->code)
 860                                         - (char*)adjustorStub);
 861             // mtctr r0
 862         adjustorStub->mtctr = 0x7c0903a6;
 863             // bctr
 864         adjustorStub->bctr = 0x4e800420;
 865 #else
 866         barf("adjustor creation not supported on this platform");
 867 #endif
 868
 869         // Flush the Instruction cache:
 870         {
 871             int n = sizeof(AdjustorStub)/sizeof(unsigned);
 872             unsigned *p = (unsigned*)adjustor;
 873             while(n--)
 874             {
 875                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 876                                     : : "r" (p));
 877                 p++;
 878             }
 879             __asm__ volatile ("sync\n\tisync");
 880         }
 881 #endif
 882
 883             // Calculate the size of the stack frame, in words.
 884         sz = totalArgumentSize(typeString);
 885
 886             // The first eight words of the parameter area
 887             // are just "backing store" for the parameters passed in
 888             // the GPRs. extra_sz is the number of words beyond those first
 889             // 8 words.
 890         extra_sz = sz - 8;
 891         if(extra_sz < 0)
 892             extra_sz = 0;
 893
 894             // Calculate the total size of the stack frame.
 895         total_sz = (6 /* linkage area */
 896                   + 8 /* minimum parameter area */
 897                   + 2 /* two extra arguments */
 898                   + extra_sz)*sizeof(StgWord);
 899
 900             // align to 16 bytes.
 901             // AIX only requires 8 bytes, but who cares?
 902         total_sz = (total_sz+15) & ~0xF;
 903
 904             // Fill in the information that adjustorCode in AdjustorAsm.S
 905             // will use to create a new stack frame with the additional args.
 906         adjustorStub->hptr = hptr;
 907         adjustorStub->wptr = wptr;
 908         adjustorStub->negative_framesize = -total_sz;
 909         adjustorStub->extrawords_plus_one = extra_sz + 1;
 910     }
 911
 912 #elif defined(ia64_HOST_ARCH)
 913 /*
 914     Up to 8 inputs are passed in registers.  We flush the last two inputs to
 915     the stack, initially into the 16-byte scratch region left by the caller.
 916     We then shuffle the others along by 4 (taking 2 registers for ourselves
 917     to save return address and previous function state - we need to come back
 918     here on the way out to restore the stack, so this is a real function
 919     rather than just a trampoline).
 920
 921     The function descriptor we create contains the gp of the target function
 922     so gp is already loaded correctly.
 923
 924         [MLX]       alloc r16=ar.pfs,10,2,0
 925                     movl r17=wptr
 926         [MII]       st8.spill [r12]=r38,8               // spill in6 (out4)
 927                     mov r41=r37                         // out7 = in5 (out3)
 928                     mov r40=r36;;                       // out6 = in4 (out2)
 929         [MII]       st8.spill [r12]=r39                 // spill in7 (out5)
 930                     mov.sptk b6=r17,50
 931                     mov r38=r34;;                       // out4 = in2 (out0)
 932         [MII]       mov r39=r35                         // out5 = in3 (out1)
 933                     mov r37=r33                         // out3 = in1 (loc1)
 934                     mov r36=r32                         // out2 = in0 (loc0)
 935         [MLX]       adds r12=-24,r12                    // update sp
 936                     movl r34=hptr;;                     // out0 = hptr
 937         [MIB]       mov r33=r16                         // loc1 = ar.pfs
 938                     mov r32=b0                          // loc0 = retaddr
 939                     br.call.sptk.many b0=b6;;
 940
 941         [MII]       adds r12=-16,r12
 942                     mov b0=r32
 943                     mov.i ar.pfs=r33
 944         [MFB]       nop.m 0x0
 945                     nop.f 0x0
 946                     br.ret.sptk.many b0;;
 947 */
 948
 949 /* These macros distribute a long constant into the two words of an MLX bundle */
 950 #define BITS(val,start,count)   (((val) >> (start)) & ((1 << (count))-1))
 951 #define MOVL_LOWORD(val)        (BITS(val,22,18) << 46)
 952 #define MOVL_HIWORD(val)        ( (BITS(val,0,7)    << 36)      \
 953                                 | (BITS(val,7,9)    << 50)      \
 954                                 | (BITS(val,16,5)   << 45)      \
 955                                 | (BITS(val,21,1)   << 44)      \
 956                                 | (BITS(val,40,23))             \
 957                                 | (BITS(val,63,1)    << 59))
 958
 959     {
 960         StgStablePtr stable;
 961         IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
 962         StgWord64 wcode = wdesc->ip;
 963         IA64FunDesc *fdesc;
 964         StgWord64 *code;
 965
 966         /* we allocate on the Haskell heap since malloc'd memory isn't
 967          * executable - argh */
 968         /* Allocated memory is word-aligned (8 bytes) but functions on ia64
 969          * must be aligned to 16 bytes.  We allocate an extra 8 bytes of
 970          * wiggle room so that we can put the code on a 16 byte boundary. */
 971         adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8+8, &stable);
 972
 973         fdesc = (IA64FunDesc *)adjustor;
 974         code = (StgWord64 *)(fdesc + 1);
 975         /* add 8 bytes to code if needed to align to a 16-byte boundary */
 976         if ((StgWord64)code & 15) code++;
 977         fdesc->ip = (StgWord64)code;
 978         fdesc->gp = wdesc->gp;
 979
 980         code[0]  = 0x0000058004288004 | MOVL_LOWORD(wcode);
 981         code[1]  = 0x6000000220000000 | MOVL_HIWORD(wcode);
 982         code[2]  = 0x029015d818984001;
 983         code[3]  = 0x8401200500420094;
 984         code[4]  = 0x886011d8189c0001;
 985         code[5]  = 0x84011004c00380c0;
 986         code[6]  = 0x0250210046013800;
 987         code[7]  = 0x8401000480420084;
 988         code[8]  = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr);
 989         code[9]  = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr);
 990         code[10] = 0x0200210020010811;
 991         code[11] = 0x1080006800006200;
 992         code[12] = 0x0000210018406000;
 993         code[13] = 0x00aa021000038005;
 994         code[14] = 0x000000010000001d;
 995         code[15] = 0x0084000880000200;
 996
 997         /* save stable pointers in convenient form */
 998         code[16] = (StgWord64)hptr;
 999         code[17] = (StgWord64)stable;
1000     }
1001 #else
1002     barf("adjustor creation not supported on this platform");
1003 #endif
1004     break;
1005
1006   default:
1007     ASSERT(0);
1008     break;
1009   }
1010
1011   /* Have fun! */
1012   return adjustor;
1013 }
1014
1015
1016 void
1017 freeHaskellFunctionPtr(void* ptr)
1018 {
1019 #if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS)
1020  if ( *(unsigned char*)ptr != 0x68 &&
1021       *(unsigned char*)ptr != 0x58 ) {
1022    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1023    return;
1024  }
1025
1026  /* Free the stable pointer first..*/
1027  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
1028     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
1029  } else {
1030     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
1031  }
1032 #elif defined(x86_HOST_ARCH) && defined(darwin_HOST_OS)
1033 if ( *(unsigned char*)ptr != 0xe8 ) {
1034    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1035    return;
1036  }
1037  freeStablePtr(((AdjustorStub*)ptr)->hptr);
1038 #elif defined(x86_64_HOST_ARCH)
1039  if ( *(StgWord16 *)ptr == 0x894d ) {
1040      freeStablePtr(*(StgStablePtr*)(ptr+0x20));
1041  } else if ( *(StgWord16 *)ptr == 0x5141 ) {
1042      freeStablePtr(*(StgStablePtr*)(ptr+0x30));
1043  } else {
1044    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1045    return;
1046  }
1047 #elif defined(sparc_HOST_ARCH)
1048  if ( *(unsigned long*)ptr != 0x9C23A008UL ) {
1049    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1050    return;
1051  }
1052
1053  /* Free the stable pointer first..*/
1054  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11)));
1055 #elif defined(alpha_HOST_ARCH)
1056  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
1057    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1058    return;
1059  }
1060
1061  /* Free the stable pointer first..*/
1062  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
1063 #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS)
1064  if ( *(StgWord*)ptr != 0x48000008 ) {
1065    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1066    return;
1067  }
1068  freeStablePtr(((StgStablePtr*)ptr)[1]);
1069 #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH)
1070  extern void* adjustorCode;
1071  if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
1072    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1073    return;
1074  }
1075  freeStablePtr(((AdjustorStub*)ptr)->hptr);
1076 #elif defined(ia64_HOST_ARCH)
1077  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
1078  StgWord64 *code = (StgWord64 *)(fdesc+1);
1079
1080  if (fdesc->ip != (StgWord64)code) {
1081    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
1082    return;
1083  }
1084  freeStablePtr((StgStablePtr)code[16]);
1085  freeStablePtr((StgStablePtr)code[17]);
1086  return;
1087 #else
1088  ASSERT(0);
1089 #endif
1090  *((unsigned char*)ptr) = '\0';
1091
1092  freeExec(ptr);
1093 }