ghc/rts/Adjustor.c

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