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_TARGET_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_TARGET_ARCH) && defined(linux_TARGET_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_TARGET_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_TARGET_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_TARGET_ARCH)
  98 static unsigned char *obscure_ccall_ret_code;
  99 #endif
 100
 101 #if defined(alpha_TARGET_ARCH)
 102 /* To get the definition of PAL_imb: */
 103 # if defined(linux_TARGET_OS)
 104 #  include <asm/pal.h>
 105 # else
 106 #  include <machine/pal.h>
 107 # endif
 108 #endif
 109
 110 #if defined(ia64_TARGET_ARCH)
 111 #include "Storage.h"
 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(BYTE_ARR_CTS(arr));
 138 }
 139 #endif
 140
 141 #if defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_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_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
 151 #if !(defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_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_TARGET_ARCH) && defined(darwin_TARGET_OS)
 160     unsigned        lis;
 161     unsigned        ori;
 162     unsigned        lwz;
 163     unsigned        mtctr;
 164     unsigned        bctr;
 165     StgFunPtr       code;
 166 #elif defined(powerpc64_TARGET_ARCH) && defined(darwin_TARGET_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 void*
 195 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr, char *typeString)
 196 {
 197   void *adjustor = NULL;
 198
 199   switch (cconv)
 200   {
 201   case 0: /* _stdcall */
 202 #if defined(i386_TARGET_ARCH)
 203     /* Magic constant computed by inspecting the code length of
 204        the following assembly language snippet
 205        (offset and machine code prefixed):
 206
 207      <0>:       58                popl   %eax              # temp. remove ret addr..
 208      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
 209                                                            # hold a StgStablePtr
 210      <6>:       50                pushl  %eax              # put back ret. addr
 211      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
 212      <c>:       ff e0             jmp    %eax              # and jump to it.
 213                 # the callee cleans up the stack
 214     */
 215     adjustor = mallocBytesRWX(14);
 216     {
 217         unsigned char *const adj_code = (unsigned char *)adjustor;
 218         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 219
 220         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 221         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 222
 223         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 224
 225         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 226         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 227
 228         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 229         adj_code[0x0d] = (unsigned char)0xe0;
 230     }
 231 #endif
 232     break;
 233
 234   case 1: /* _ccall */
 235 #if defined(i386_TARGET_ARCH)
 236   /* Magic constant computed by inspecting the code length of
 237      the following assembly language snippet
 238      (offset and machine code prefixed):
 239
 240   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 241                                                    # hold a StgStablePtr
 242   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 243   <0a>: 68 ef be ad de     pushl  $obscure_ccall_ret_code # push the return address
 244   <0f>: ff e0              jmp    *%eax            # jump to wptr
 245
 246     The ccall'ing version is a tad different, passing in the return
 247     address of the caller to the auto-generated C stub (which enters
 248     via the stable pointer.) (The auto-generated C stub is in on this
 249     game, don't worry :-)
 250
 251     See the comment next to obscure_ccall_ret_code why we need to
 252     perform a tail jump instead of a call, followed by some C stack
 253     fixup.
 254
 255     Note: The adjustor makes the assumption that any return value
 256     coming back from the C stub is not stored on the stack.
 257     That's (thankfully) the case here with the restricted set of
 258     return types that we support.
 259   */
 260     adjustor = mallocBytesRWX(17);
 261     {
 262         unsigned char *const adj_code = (unsigned char *)adjustor;
 263
 264         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 265         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 266
 267         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 268         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 269
 270         adj_code[0x0a] = (unsigned char)0x68;  /* pushl obscure_ccall_ret_code */
 271         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)obscure_ccall_ret_code;
 272
 273         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 274         adj_code[0x10] = (unsigned char)0xe0;
 275     }
 276 #elif defined(sparc_TARGET_ARCH)
 277   /* Magic constant computed by inspecting the code length of the following
 278      assembly language snippet (offset and machine code prefixed):
 279
 280      <00>: 9C23A008   sub   %sp, 8, %sp         ! make room for %o4/%o5 in caller's frame
 281      <04>: DA23A060   st    %o5, [%sp + 96]     ! shift registers by 2 positions
 282      <08>: D823A05C   st    %o4, [%sp + 92]
 283      <0C>: 9A10000B   mov   %o3, %o5
 284      <10>: 9810000A   mov   %o2, %o4
 285      <14>: 96100009   mov   %o1, %o3
 286      <18>: 94100008   mov   %o0, %o2
 287      <1C>: 13000000   sethi %hi(wptr), %o1      ! load up wptr (1 of 2)
 288      <20>: 11000000   sethi %hi(hptr), %o0      ! load up hptr (1 of 2)
 289      <24>: 81C26000   jmp   %o1 + %lo(wptr)     ! jump to wptr (load 2 of 2)
 290      <28>: 90122000   or    %o0, %lo(hptr), %o0 ! load up hptr (2 of 2, delay slot)
 291      <2C>  00000000                             ! place for getting hptr back easily
 292
 293      ccall'ing on SPARC is easy, because we are quite lucky to push a
 294      multiple of 8 bytes (1 word hptr + 1 word dummy arg) in front of the
 295      existing arguments (note that %sp must stay double-word aligned at
 296      all times, see ABI spec at http://www.sparc.org/standards/psABI3rd.pdf).
 297      To do this, we extend the *caller's* stack frame by 2 words and shift
 298      the output registers used for argument passing (%o0 - %o5, we are a *leaf*
 299      procedure because of the tail-jump) by 2 positions. This makes room in
 300      %o0 and %o1 for the additinal arguments, namely  hptr and a dummy (used
 301      for destination addr of jump on SPARC, return address on x86, ...). This
 302      shouldn't cause any problems for a C-like caller: alloca is implemented
 303      similarly, and local variables should be accessed via %fp, not %sp. In a
 304      nutshell: This should work! (Famous last words! :-)
 305   */
 306     adjustor = mallocBytesRWX(4*(11+1));
 307     {
 308         unsigned long *const adj_code = (unsigned long *)adjustor;
 309
 310         adj_code[ 0]  = 0x9C23A008UL;   /* sub   %sp, 8, %sp         */
 311         adj_code[ 1]  = 0xDA23A060UL;   /* st    %o5, [%sp + 96]     */
 312         adj_code[ 2]  = 0xD823A05CUL;   /* st    %o4, [%sp + 92]     */
 313         adj_code[ 3]  = 0x9A10000BUL;   /* mov   %o3, %o5            */
 314         adj_code[ 4]  = 0x9810000AUL;   /* mov   %o2, %o4            */
 315         adj_code[ 5]  = 0x96100009UL;   /* mov   %o1, %o3            */
 316         adj_code[ 6]  = 0x94100008UL;   /* mov   %o0, %o2            */
 317         adj_code[ 7]  = 0x13000000UL;   /* sethi %hi(wptr), %o1      */
 318         adj_code[ 7] |= ((unsigned long)wptr) >> 10;
 319         adj_code[ 8]  = 0x11000000UL;   /* sethi %hi(hptr), %o0      */
 320         adj_code[ 8] |= ((unsigned long)hptr) >> 10;
 321         adj_code[ 9]  = 0x81C26000UL;   /* jmp   %o1 + %lo(wptr)     */
 322         adj_code[ 9] |= ((unsigned long)wptr) & 0x000003FFUL;
 323         adj_code[10]  = 0x90122000UL;   /* or    %o0, %lo(hptr), %o0 */
 324         adj_code[10] |= ((unsigned long)hptr) & 0x000003FFUL;
 325
 326         adj_code[11]  = (unsigned long)hptr;
 327
 328         /* flush cache */
 329         asm("flush %0" : : "r" (adj_code     ));
 330         asm("flush %0" : : "r" (adj_code +  2));
 331         asm("flush %0" : : "r" (adj_code +  4));
 332         asm("flush %0" : : "r" (adj_code +  6));
 333         asm("flush %0" : : "r" (adj_code + 10));
 334
 335         /* max. 5 instructions latency, and we need at >= 1 for returning */
 336         asm("nop");
 337         asm("nop");
 338         asm("nop");
 339         asm("nop");
 340     }
 341 #elif defined(alpha_TARGET_ARCH)
 342   /* Magic constant computed by inspecting the code length of
 343      the following assembly language snippet
 344      (offset and machine code prefixed; note that the machine code
 345      shown is longwords stored in little-endian order):
 346
 347   <00>: 46520414        mov     a2, a4
 348   <04>: 46100412        mov     a0, a2
 349   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 350   <0c>: 46730415        mov     a3, a5
 351   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 352   <14>: 46310413        mov     a1, a3
 353   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 354   <1c>: 00000000                                # padding for alignment
 355   <20>: [8 bytes for hptr quadword]
 356   <28>: [8 bytes for wptr quadword]
 357
 358      The "computed" jump at <08> above is really a jump to a fixed
 359      location.  Accordingly, we place an always-correct hint in the
 360      jump instruction, namely the address offset from <0c> to wptr,
 361      divided by 4, taking the lowest 14 bits.
 362
 363      We only support passing 4 or fewer argument words, for the same
 364      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 365      On the Alpha the first 6 integer arguments are in a0 through a5,
 366      and the rest on the stack.  Hence we want to shuffle the original
 367      caller's arguments by two.
 368
 369      On the Alpha the calling convention is so complex and dependent
 370      on the callee's signature -- for example, the stack pointer has
 371      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 372      to handle the general case correctly without changing how the
 373      adjustor is called from C.  For now, our solution of shuffling
 374      registers only and ignoring the stack only works if the original
 375      caller passed 4 or fewer argument words.
 376
 377 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 378       header information (more precisely, if the overhead is no more than
 379       4 bytes), we should move the first three instructions above down by
 380       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 381   */
 382     ASSERT(((StgWord64)wptr & 3) == 0);
 383     adjustor = mallocBytesRWX(48);
 384     {
 385         StgWord64 *const code = (StgWord64 *)adjustor;
 386
 387         code[0] = 0x4610041246520414L;
 388         code[1] = 0x46730415a61b0020L;
 389         code[2] = 0x46310413a77b0028L;
 390         code[3] = 0x000000006bfb0000L
 391                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 392
 393         code[4] = (StgWord64)hptr;
 394         code[5] = (StgWord64)wptr;
 395
 396         /* Ensure that instruction cache is consistent with our new code */
 397         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 398     }
 399 #elif defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
 400
 401 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 402 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 403     {
 404         /* The PowerPC Linux (32-bit) calling convention is annoyingly complex.
 405            We need to calculate all the details of the stack frame layout,
 406            taking into account the types of all the arguments, and then
 407            generate code on the fly. */
 408
 409         int src_gpr = 3, dst_gpr = 5;
 410         int fpr = 3;
 411         int src_offset = 0, dst_offset = 0;
 412         int n = strlen(typeString),i;
 413         int src_locs[n], dst_locs[n];
 414         int frameSize;
 415         unsigned *code;
 416
 417             /* Step 1:
 418                Calculate where the arguments should go.
 419                src_locs[] will contain the locations of the arguments in the
 420                original stack frame passed to the adjustor.
 421                dst_locs[] will contain the locations of the arguments after the
 422                adjustor runs, on entry to the wrapper proc pointed to by wptr.
 423
 424                This algorithm is based on the one described on page 3-19 of the
 425                System V ABI PowerPC Processor Supplement.
 426             */
 427         for(i=0;typeString[i];i++)
 428         {
 429             char t = typeString[i];
 430             if((t == 'f' || t == 'd') && fpr <= 8)
 431                 src_locs[i] = dst_locs[i] = -32-(fpr++);
 432             else
 433             {
 434                 if(t == 'l' && src_gpr <= 9)
 435                 {
 436                     if((src_gpr & 1) == 0)
 437                         src_gpr++;
 438                     src_locs[i] = -src_gpr;
 439                     src_gpr += 2;
 440                 }
 441                 else if(t == 'i' && src_gpr <= 10)
 442                 {
 443                     src_locs[i] = -(src_gpr++);
 444                 }
 445                 else
 446                 {
 447                     if(t == 'l' || t == 'd')
 448                     {
 449                         if(src_offset % 8)
 450                             src_offset += 4;
 451                     }
 452                     src_locs[i] = src_offset;
 453                     src_offset += (t == 'l' || t == 'd') ? 8 : 4;
 454                 }
 455
 456                 if(t == 'l' && dst_gpr <= 9)
 457                 {
 458                     if((dst_gpr & 1) == 0)
 459                         dst_gpr++;
 460                     dst_locs[i] = -dst_gpr;
 461                     dst_gpr += 2;
 462                 }
 463                 else if(t == 'i' && dst_gpr <= 10)
 464                 {
 465                     dst_locs[i] = -(dst_gpr++);
 466                 }
 467                 else
 468                 {
 469                     if(t == 'l' || t == 'd')
 470                     {
 471                         if(dst_offset % 8)
 472                             dst_offset += 4;
 473                     }
 474                     dst_locs[i] = dst_offset;
 475                     dst_offset += (t == 'l' || t == 'd') ? 8 : 4;
 476                 }
 477             }
 478         }
 479
 480         frameSize = dst_offset + 8;
 481         frameSize = (frameSize+15) & ~0xF;
 482
 483             /* Step 2:
 484                Build the adjustor.
 485             */
 486                     // allocate space for at most 4 insns per parameter
 487                     // plus 14 more instructions.
 488         adjustor = mallocBytesRWX(4 * (4*n + 14));
 489         code = (unsigned*)adjustor;
 490
 491         *code++ = 0x48000008; // b *+8
 492             // * Put the hptr in a place where freeHaskellFunctionPtr
 493             //   can get at it.
 494         *code++ = (unsigned) hptr;
 495
 496             // * save the link register
 497         *code++ = 0x7c0802a6; // mflr r0;
 498         *code++ = 0x90010004; // stw r0, 4(r1);
 499             // * and build a new stack frame
 500         *code++ = OP_LO(0x9421, -frameSize); // stwu r1, -frameSize(r1)
 501
 502             // * now generate instructions to copy arguments
 503             //   from the old stack frame into the new stack frame.
 504         for(i=n-1;i>=0;i--)
 505         {
 506             if(src_locs[i] < -32)
 507                 ASSERT(dst_locs[i] == src_locs[i]);
 508             else if(src_locs[i] < 0)
 509             {
 510                 // source in GPR.
 511                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 512                 if(dst_locs[i] < 0)
 513                 {
 514                     ASSERT(dst_locs[i] > -32);
 515                         // dst is in GPR, too.
 516
 517                     if(typeString[i] == 'l')
 518                     {
 519                             // mr dst+1, src+1
 520                         *code++ = 0x7c000378
 521                                 | ((-dst_locs[i]+1) << 16)
 522                                 | ((-src_locs[i]+1) << 11)
 523                                 | ((-src_locs[i]+1) << 21);
 524                     }
 525                     // mr dst, src
 526                     *code++ = 0x7c000378
 527                             | ((-dst_locs[i]) << 16)
 528                             | ((-src_locs[i]) << 11)
 529                             | ((-src_locs[i]) << 21);
 530                 }
 531                 else
 532                 {
 533                     if(typeString[i] == 'l')
 534                     {
 535                             // stw src+1, dst_offset+4(r1)
 536                         *code++ = 0x90010000
 537                                 | ((-src_locs[i]+1) << 21)
 538                                 | (dst_locs[i] + 4);
 539                     }
 540
 541                         // stw src, dst_offset(r1)
 542                     *code++ = 0x90010000
 543                             | ((-src_locs[i]) << 21)
 544                             | (dst_locs[i] + 8);
 545                 }
 546             }
 547             else
 548             {
 549                 ASSERT(dst_locs[i] >= 0);
 550                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 551
 552                 if(typeString[i] == 'l')
 553                 {
 554                     // lwz r0, src_offset(r1)
 555                         *code++ = 0x80010000
 556                                 | (src_locs[i] + frameSize + 8 + 4);
 557                     // stw r0, dst_offset(r1)
 558                         *code++ = 0x90010000
 559                                 | (dst_locs[i] + 8 + 4);
 560                     }
 561                 // lwz r0, src_offset(r1)
 562                     *code++ = 0x80010000
 563                             | (src_locs[i] + frameSize + 8);
 564                 // stw r0, dst_offset(r1)
 565                     *code++ = 0x90010000
 566                             | (dst_locs[i] + 8);
 567            }
 568         }
 569
 570             // * hptr will be the new first argument.
 571             // lis r3, hi(hptr)
 572         *code++ = OP_HI(0x3c60, hptr);
 573             // ori r3,r3,lo(hptr)
 574         *code++ = OP_LO(0x6063, hptr);
 575
 576             // * we need to return to a piece of code
 577             //   which will tear down the stack frame.
 578             // lis r11,hi(obscure_ccall_ret_code)
 579         *code++ = OP_HI(0x3d60, obscure_ccall_ret_code);
 580             // ori r11,r11,lo(obscure_ccall_ret_code)
 581         *code++ = OP_LO(0x616b, obscure_ccall_ret_code);
 582             // mtlr r11
 583         *code++ = 0x7d6803a6;
 584
 585             // * jump to wptr
 586             // lis r11,hi(wptr)
 587         *code++ = OP_HI(0x3d60, wptr);
 588             // ori r11,r11,lo(wptr)
 589         *code++ = OP_LO(0x616b, wptr);
 590             // mtctr r11
 591         *code++ = 0x7d6903a6;
 592             // bctr
 593         *code++ = 0x4e800420;
 594
 595         // Flush the Instruction cache:
 596         {
 597             unsigned *p = adjustor;
 598             while(p < code)
 599             {
 600                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 601                                  : : "r" (p));
 602                 p++;
 603             }
 604             __asm__ volatile ("sync\n\tisync");
 605         }
 606     }
 607
 608 #elif defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
 609
 610 #define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
 611 #define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
 612         {
 613             AdjustorStub *adjustorStub;
 614             int sz = 0, extra_sz, total_sz;
 615
 616                   // from AdjustorAsm.s
 617                   // not declared as a function so that AIX-style
 618                   // fundescs can never get in the way.
 619             extern void *adjustorCode;
 620
 621 #ifdef FUNDESCS
 622             adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
 623 #else
 624             adjustorStub = mallocBytesRWX(sizeof(AdjustorStub));
 625 #endif
 626             adjustor = adjustorStub;
 627
 628             adjustorStub->code = (void*) &adjustorCode;
 629
 630 #ifdef FUNDESCS
 631                 // function descriptors are a cool idea.
 632                 // We don't need to generate any code at runtime.
 633             adjustorStub->toc = adjustorStub;
 634 #else
 635
 636                 // no function descriptors :-(
 637                 // We need to do things "by hand".
 638 #if defined(powerpc_TARGET_ARCH)
 639                 // lis  r2, hi(adjustorStub)
 640             adjustorStub->lis = OP_HI(0x3c40, adjustorStub);
 641                 // ori  r2, r2, lo(adjustorStub)
 642             adjustorStub->ori = OP_LO(0x6042, adjustorStub);
 643                 // lwz r0, code(r2)
 644             adjustorStub->lwz = OP_LO(0x8002, (char*)(&adjustorStub->code)
 645                                             - (char*)adjustorStub);
 646                 // mtctr r0
 647             adjustorStub->mtctr = 0x7c0903a6;
 648                 // bctr
 649             adjustorStub->bctr = 0x4e800420;
 650 #else
 651             barf("adjustor creation not supported on this platform");
 652 #endif
 653
 654             // Flush the Instruction cache:
 655             {
 656                 int n = sizeof(AdjustorStub)/sizeof(unsigned);
 657                 unsigned *p = (unsigned*)adjustor;
 658                 while(n--)
 659                 {
 660                     __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 661                                         : : "r" (p));
 662                     p++;
 663                 }
 664                 __asm__ volatile ("sync\n\tisync");
 665             }
 666 #endif
 667
 668             printf("createAdjustor: %s\n", typeString);
 669             while(*typeString)
 670             {
 671                 char t = *typeString++;
 672
 673                 switch(t)
 674                 {
 675 #if defined(powerpc64_TARGET_ARCH)
 676                     case 'd': sz += 1; break;
 677                     case 'l': sz += 1; break;
 678 #else
 679                     case 'd': sz += 2; break;
 680                     case 'l': sz += 2; break;
 681 #endif
 682                     case 'f': sz += 1; break;
 683                     case 'i': sz += 1; break;
 684                 }
 685             }
 686             extra_sz = sz - 8;
 687             if(extra_sz < 0)
 688                 extra_sz = 0;
 689             total_sz = (6 /* linkage area */
 690                       + 8 /* minimum parameter area */
 691                       + 2 /* two extra arguments */
 692                       + extra_sz)*sizeof(StgWord);
 693
 694                 // align to 16 bytes.
 695                 // AIX only requires 8 bytes, but who cares?
 696             total_sz = (total_sz+15) & ~0xF;
 697
 698             adjustorStub->hptr = hptr;
 699             adjustorStub->wptr = wptr;
 700             adjustorStub->negative_framesize = -total_sz;
 701             adjustorStub->extrawords_plus_one = extra_sz + 1;
 702         }
 703
 704 #elif defined(ia64_TARGET_ARCH)
 705 /*
 706     Up to 8 inputs are passed in registers.  We flush the last two inputs to
 707     the stack, initially into the 16-byte scratch region left by the caller.
 708     We then shuffle the others along by 4 (taking 2 registers for ourselves
 709     to save return address and previous function state - we need to come back
 710     here on the way out to restore the stack, so this is a real function
 711     rather than just a trampoline).
 712
 713     The function descriptor we create contains the gp of the target function
 714     so gp is already loaded correctly.
 715
 716         [MLX]       alloc r16=ar.pfs,10,2,0
 717                     movl r17=wptr
 718         [MII]       st8.spill [r12]=r38,8               // spill in6 (out4)
 719                     mov r41=r37                         // out7 = in5 (out3)
 720                     mov r40=r36;;                       // out6 = in4 (out2)
 721         [MII]       st8.spill [r12]=r39                 // spill in7 (out5)
 722                     mov.sptk b6=r17,50
 723                     mov r38=r34;;                       // out4 = in2 (out0)
 724         [MII]       mov r39=r35                         // out5 = in3 (out1)
 725                     mov r37=r33                         // out3 = in1 (loc1)
 726                     mov r36=r32                         // out2 = in0 (loc0)
 727         [MLX]       adds r12=-24,r12                    // update sp
 728                     movl r34=hptr;;                     // out0 = hptr
 729         [MIB]       mov r33=r16                         // loc1 = ar.pfs
 730                     mov r32=b0                          // loc0 = retaddr
 731                     br.call.sptk.many b0=b6;;
 732
 733         [MII]       adds r12=-16,r12
 734                     mov b0=r32
 735                     mov.i ar.pfs=r33
 736         [MFB]       nop.m 0x0
 737                     nop.f 0x0
 738                     br.ret.sptk.many b0;;
 739 */
 740
 741 /* These macros distribute a long constant into the two words of an MLX bundle */
 742 #define BITS(val,start,count)   (((val) >> (start)) & ((1 << (count))-1))
 743 #define MOVL_LOWORD(val)        (BITS(val,22,18) << 46)
 744 #define MOVL_HIWORD(val)        (BITS(val,40,23) | (BITS(val,0,7) << 36) | (BITS(val,7,9) << 50) \
 745                                 | (BITS(val,16,5) << 55) | (BITS(val,21,1) << 44) | BITS(val,63,1) << 59)
 746
 747     {
 748         StgStablePtr stable;
 749         IA64FunDesc *wdesc = (IA64FunDesc *)wptr;
 750         StgWord64 wcode = wdesc->ip;
 751         IA64FunDesc *fdesc;
 752         StgWord64 *code;
 753
 754         /* we allocate on the Haskell heap since malloc'd memory isn't executable - argh */
 755         adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8, &stable);
 756
 757         fdesc = (IA64FunDesc *)adjustor;
 758         code = (StgWord64 *)(fdesc + 1);
 759         fdesc->ip = (StgWord64)code;
 760         fdesc->gp = wdesc->gp;
 761
 762         code[0]  = 0x0000058004288004 | MOVL_LOWORD(wcode);
 763         code[1]  = 0x6000000220000000 | MOVL_HIWORD(wcode);
 764         code[2]  = 0x029015d818984001;
 765         code[3]  = 0x8401200500420094;
 766         code[4]  = 0x886011d8189c0001;
 767         code[5]  = 0x84011004c00380c0;
 768         code[6]  = 0x0250210046013800;
 769         code[7]  = 0x8401000480420084;
 770         code[8]  = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr);
 771         code[9]  = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr);
 772         code[10] = 0x0200210020010811;
 773         code[11] = 0x1080006800006200;
 774         code[12] = 0x0000210018406000;
 775         code[13] = 0x00aa021000038005;
 776         code[14] = 0x000000010000001d;
 777         code[15] = 0x0084000880000200;
 778
 779         /* save stable pointers in convenient form */
 780         code[16] = (StgWord64)hptr;
 781         code[17] = (StgWord64)stable;
 782     }
 783 #else
 784     barf("adjustor creation not supported on this platform");
 785 #endif
 786     break;
 787
 788   default:
 789     ASSERT(0);
 790     break;
 791   }
 792
 793   /* Have fun! */
 794   return adjustor;
 795 }
 796
 797
 798 void
 799 freeHaskellFunctionPtr(void* ptr)
 800 {
 801 #if defined(i386_TARGET_ARCH)
 802  if ( *(unsigned char*)ptr != 0x68 &&
 803       *(unsigned char*)ptr != 0x58 ) {
 804    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 805    return;
 806  }
 807
 808  /* Free the stable pointer first..*/
 809  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 810     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 811  } else {
 812     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 813  }
 814 #elif defined(sparc_TARGET_ARCH)
 815  if ( *(unsigned long*)ptr != 0x9C23A008UL ) {
 816    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 817    return;
 818  }
 819
 820  /* Free the stable pointer first..*/
 821  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 11)));
 822 #elif defined(alpha_TARGET_ARCH)
 823  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 824    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 825    return;
 826  }
 827
 828  /* Free the stable pointer first..*/
 829  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 830 #elif defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
 831  if ( *(StgWord*)ptr != 0x48000008 ) {
 832    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 833    return;
 834  }
 835  freeStablePtr(((StgStablePtr*)ptr)[1]);
 836 #elif defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
 837  extern void* adjustorCode;
 838  if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
 839    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 840    return;
 841  }
 842  freeStablePtr(((AdjustorStub*)ptr)->hptr);
 843 #elif defined(ia64_TARGET_ARCH)
 844  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
 845  StgWord64 *code = (StgWord64 *)(fdesc+1);
 846
 847  if (fdesc->ip != (StgWord64)code) {
 848    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 849    return;
 850  }
 851  freeStablePtr((StgStablePtr)code[16]);
 852  freeStablePtr((StgStablePtr)code[17]);
 853  return;
 854 #else
 855  ASSERT(0);
 856 #endif
 857  *((unsigned char*)ptr) = '\0';
 858
 859  stgFree(ptr);
 860 }
 861
 862
 863 /*
 864  * Function: initAdjustor()
 865  *
 866  * Perform initialisation of adjustor thunk layer (if needed.)
 867  */
 868 void
 869 initAdjustor(void)
 870 {
 871 #if defined(i386_TARGET_ARCH)
 872   /* Now here's something obscure for you:
 873
 874   When generating an adjustor thunk that uses the C calling
 875   convention, we have to make sure that the thunk kicks off
 876   the process of jumping into Haskell with a tail jump. Why?
 877   Because as a result of jumping in into Haskell we may end
 878   up freeing the very adjustor thunk we came from using
 879   freeHaskellFunctionPtr(). Hence, we better not return to
 880   the adjustor code on our way  out, since it could by then
 881   point to junk.
 882
 883   The fix is readily at hand, just include the opcodes
 884   for the C stack fixup code that we need to perform when
 885   returning in some static piece of memory and arrange
 886   to return to it before tail jumping from the adjustor thunk.
 887   */
 888
 889   obscure_ccall_ret_code = mallocBytesRWX(4);
 890
 891   obscure_ccall_ret_code[0x00] = (unsigned char)0x83;  /* addl $0x4, %esp */
 892   obscure_ccall_ret_code[0x01] = (unsigned char)0xc4;
 893   obscure_ccall_ret_code[0x02] = (unsigned char)0x04;
 894
 895   obscure_ccall_ret_code[0x03] = (unsigned char)0xc3;  /* ret */
 896 #endif
 897 }