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 "RtsUtils.h"
  42 #include "RtsFlags.h"
  43
  44 /* Heavily arch-specific, I'm afraid.. */
  45 #if defined(i386_TARGET_ARCH) || defined(sparc_TARGET_ARCH) || defined(alpha_TARGET_ARCH) || defined(powerpc_TARGET_ARCH)
  46
  47 #if defined(i386_TARGET_ARCH)
  48 /* Now here's something obscure for you:
  49
  50    When generating an adjustor thunk that uses the C calling
  51    convention, we have to make sure that the thunk kicks off
  52    the process of jumping into Haskell with a tail jump. Why?
  53    Because as a result of jumping in into Haskell we may end
  54    up freeing the very adjustor thunk we came from using
  55    freeHaskellFunctionPtr(). Hence, we better not return to
  56    the adjustor code on our way  out, since it could by then
  57    point to junk.
  58
  59    The fix is readily at hand, just include the opcodes
  60    for the C stack fixup code that we need to perform when
  61    returning in some static piece of memory and arrange
  62    to return to it before tail jumping from the adjustor thunk.
  63
  64    For this to work we make the assumption that bytes in .data
  65    are considered executable.
  66 */
  67 static unsigned char __obscure_ccall_ret_code [] =
  68   { 0x83, 0xc4, 0x04 /* addl $0x4, %esp */
  69   , 0xc3             /* ret */
  70   };
  71 #endif
  72
  73 #if defined(alpha_TARGET_ARCH)
  74 /* To get the definition of PAL_imb: */
  75 #include <machine/pal.h>
  76 #endif
  77
  78 void*
  79 createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
  80 {
  81   void *adjustor = NULL;
  82
  83   switch (cconv)
  84   {
  85   case 0: /* _stdcall */
  86 #if defined(i386_TARGET_ARCH)
  87     /* Magic constant computed by inspecting the code length of
  88        the following assembly language snippet
  89        (offset and machine code prefixed):
  90
  91      <0>:       58                popl   %eax              # temp. remove ret addr..
  92      <1>:       68 fd fc fe fa    pushl  0xfafefcfd        # constant is large enough to
  93                                                            # hold a StgStablePtr
  94      <6>:       50                pushl  %eax              # put back ret. addr
  95      <7>:       b8 fa ef ff 00    movl   $0x00ffeffa, %eax # load up wptr
  96      <c>:       ff e0             jmp    %eax              # and jump to it.
  97                 # the callee cleans up the stack
  98     */
  99     if ((adjustor = stgMallocBytes(14, "createAdjustor")) != NULL) {
 100         unsigned char *const adj_code = (unsigned char *)adjustor;
 101         adj_code[0x00] = (unsigned char)0x58;  /* popl %eax  */
 102
 103         adj_code[0x01] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 104         *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr;
 105
 106         adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */
 107
 108         adj_code[0x07] = (unsigned char)0xb8; /* movl  $wptr, %eax */
 109         *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr;
 110
 111         adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */
 112         adj_code[0x0d] = (unsigned char)0xe0;
 113     }
 114 #endif
 115     break;
 116
 117   case 1: /* _ccall */
 118 #if defined(i386_TARGET_ARCH)
 119   /* Magic constant computed by inspecting the code length of
 120      the following assembly language snippet
 121      (offset and machine code prefixed):
 122
 123   <00>: 68 ef be ad de     pushl  $0xdeadbeef      # constant is large enough to
 124                                                    # hold a StgStablePtr
 125   <05>: b8 fa ef ff 00     movl   $0x00ffeffa, %eax # load up wptr
 126   <0a>: 68 ef be ad de     pushl  $__obscure_ccall_ret_code # push the return address
 127   <0f>: ff e0              jmp    *%eax            # jump to wptr
 128
 129     The ccall'ing version is a tad different, passing in the return
 130     address of the caller to the auto-generated C stub (which enters
 131     via the stable pointer.) (The auto-generated C stub is in on this
 132     game, don't worry :-)
 133
 134     See the comment next to __obscure_ccall_ret_code why we need to
 135     perform a tail jump instead of a call, followed by some C stack
 136     fixup.
 137
 138     Note: The adjustor makes the assumption that any return value
 139     coming back from the C stub is not stored on the stack.
 140     That's (thankfully) the case here with the restricted set of
 141     return types that we support.
 142   */
 143     if ((adjustor = stgMallocBytes(17, "createAdjustor")) != NULL) {
 144         unsigned char *const adj_code = (unsigned char *)adjustor;
 145
 146         adj_code[0x00] = (unsigned char)0x68;  /* pushl hptr (which is a dword immediate ) */
 147         *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr;
 148
 149         adj_code[0x05] = (unsigned char)0xb8;  /* movl  $wptr, %eax */
 150         *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr;
 151
 152         adj_code[0x0a] = (unsigned char)0x68;  /* pushl __obscure_ccall_ret_code */
 153         *((StgFunPtr*)(adj_code + 0x0b)) = (StgFunPtr)__obscure_ccall_ret_code;
 154
 155         adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */
 156         adj_code[0x10] = (unsigned char)0xe0;
 157     }
 158 #elif defined(sparc_TARGET_ARCH)
 159   /* Magic constant computed by inspecting the code length of
 160      the following assembly language snippet
 161      (offset and machine code prefixed):
 162
 163   <00>: BA 10 00 1B     mov    %i3, %i5
 164   <04>: B8 10 00 1A     mov    %i2, %i4
 165   <08>: B6 10 00 19     mov    %i1, %i3
 166   <0c>: B4 10 00 18     mov    %i0, %i2
 167   <10>: 13 00 3f fb     sethi  %hi(0x00ffeffa), %o1 # load up wptr (1 of 2)
 168   <14>: 11 37 ab 6f     sethi  %hi(0xdeadbeef), %o0 # load up hptr (1 of 2)
 169   <18>: 81 c2 63 fa     jmp    %o1+%lo(0x00ffeffa)  # jump to wptr (load 2 of 2)
 170   <1c>: 90 12 22 ef     or     %o0, %lo(0xdeadbeef), %o0 # load up hptr (2 of 2)
 171                                                          # [in delay slot]
 172   <20>: de ad be ef     # Place the value of the StgStablePtr somewhere readable
 173
 174     ccall'ing on a SPARC leaves little to be performed by the caller.
 175     The callee shifts the window on entry and restores it on exit.
 176     Input paramters and results are passed via registers. (%o0 in the
 177     code above contains the input paramter to wptr.) The return address
 178     is stored in %o7/%i7. Since we don't shift the window in this code,
 179     the return address is preserved and wptr will return to our caller.
 180
 181     JRS, 21 Aug 01: the above para is a fiction.  The caller passes
 182     args in %i0 .. %i5 and then the rest at [%sp+92].  We want to
 183     tailjump to wptr, passing hptr as the new first arg, and a dummy
 184     second arg, which would be where the return address is on x86.
 185     That means we have to shuffle the original caller's args along by
 186     two.
 187
 188     We do a half-correct solution which works only if the original
 189     caller passed 4 or fewer arg words.  Move %i0 .. %i3 into %i3
 190     .. %i6, so we can park hptr in %i0 and a bogus arg in %i1.  The
 191     fully correct solution would be to subtract 8 from %sp and then
 192     place %i4 and %i5 at [%sp+92] and [%sp+96] respectively.  This
 193     machinery should then work in all cases.  (Or would it?  Perhaps
 194     it would trash parts of the caller's frame.  Dunno).
 195
 196     SUP, 25 Apr 02: Alas, the "fully correct" solution above is only
 197     half correct: "%sp has to be 16-byte aligned at all time", the
 198     almighty ABI spec says...
 199   */
 200     if ((adjustor = stgMallocBytes(4*(8+1), "createAdjustor")) != NULL) {
 201         unsigned long *const adj_code = (unsigned long *)adjustor;
 202
 203         /* mov  %o3, %o5 */
 204         adj_code[0] = (unsigned long)0x9A10000B;
 205         /* mov  %o2, %o4 */
 206         adj_code[1] = (unsigned long)0x9810000A;
 207         /* mov  %o1, %o3 */
 208         adj_code[2] = (unsigned long)0x96100009;
 209         /* mov  %o0, %o2 */
 210         adj_code[3] = (unsigned long)0x94100008;
 211
 212         /* sethi %hi(wptr), %o1 */
 213         adj_code[4] = (unsigned long)0x13000000;
 214         adj_code[4] |= ((unsigned long)wptr) >> 10;
 215
 216         /* sethi %hi(hptr), %o0 */
 217         adj_code[5] = (unsigned long)0x11000000;
 218         adj_code[5] |= ((unsigned long)hptr) >> 10;
 219
 220         /* jmp %o1+%lo(wptr) */
 221         adj_code[6] = (unsigned long)0x81c26000;
 222         adj_code[6] |= ((unsigned long)wptr) & 0x000003ff;
 223
 224         /* or %o0, %lo(hptr), %o0 */
 225         adj_code[7] = (unsigned long)0x90122000;
 226         adj_code[7] |= ((unsigned long)hptr) & 0x000003ff;
 227
 228         adj_code[8] = (StgStablePtr)hptr;
 229
 230         /* flush cache */
 231         asm("flush %0" : : "r" (adj_code    ));
 232         asm("flush %0" : : "r" (adj_code + 2));
 233         asm("flush %0" : : "r" (adj_code + 4));
 234         asm("flush %0" : : "r" (adj_code + 6));
 235
 236         /* max. 5 instructions latency, and we need at >= 1 for returning */
 237         asm("nop");
 238         asm("nop");
 239         asm("nop");
 240         asm("nop");
 241     }
 242 #elif defined(alpha_TARGET_ARCH)
 243   /* Magic constant computed by inspecting the code length of
 244      the following assembly language snippet
 245      (offset and machine code prefixed; note that the machine code
 246      shown is longwords stored in little-endian order):
 247
 248   <00>: 46520414        mov     a2, a4
 249   <04>: 46100412        mov     a0, a2
 250   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 251   <0c>: 46730415        mov     a3, a5
 252   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 253   <14>: 46310413        mov     a1, a3
 254   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 255   <1c>: 00000000                                # padding for alignment
 256   <20>: [8 bytes for hptr quadword]
 257   <28>: [8 bytes for wptr quadword]
 258
 259      The "computed" jump at <08> above is really a jump to a fixed
 260      location.  Accordingly, we place an always-correct hint in the
 261      jump instruction, namely the address offset from <0c> to wptr,
 262      divided by 4, taking the lowest 14 bits.
 263
 264      We only support passing 4 or fewer argument words, for the same
 265      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 266      On the Alpha the first 6 integer arguments are in a0 through a5,
 267      and the rest on the stack.  Hence we want to shuffle the original
 268      caller's arguments by two.
 269
 270      On the Alpha the calling convention is so complex and dependent
 271      on the callee's signature -- for example, the stack pointer has
 272      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 273      to handle the general case correctly without changing how the
 274      adjustor is called from C.  For now, our solution of shuffling
 275      registers only and ignoring the stack only works if the original
 276      caller passed 4 or fewer argument words.
 277
 278 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 279       header information (more precisely, if the overhead is no more than
 280       4 bytes), we should move the first three instructions above down by
 281       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 282   */
 283     ASSERT(((StgWord64)wptr & 3) == 0);
 284     if ((adjustor = stgMallocBytes(48, "createAdjustor")) != NULL) {
 285         StgWord64 *const code = (StgWord64 *)adjustor;
 286
 287         code[0] = 0x4610041246520414L;
 288         code[1] = 0x46730415a61b0020L;
 289         code[2] = 0x46310413a77b0028L;
 290         code[3] = 0x000000006bfb0000L
 291                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 292
 293         code[4] = (StgWord64)hptr;
 294         code[5] = (StgWord64)wptr;
 295
 296         /* Ensure that instruction cache is consistent with our new code */
 297         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 298     }
 299 #elif defined(powerpc_TARGET_ARCH)
 300 /*
 301         For PowerPC, the following code is used:
 302
 303         mr r10,r8
 304         mr r9,r7
 305         mr r8,r6
 306         mr r7,r5
 307         mr r6,r4
 308         mr r5,r3
 309         lis r0,0xDEAD ;hi(wptr)
 310         lis r3,0xDEAF ;hi(hptr)
 311         ori r0,r0,0xBEEF ; lo(wptr)
 312         ori r3,r3,0xFACE ; lo(hptr)
 313         mtctr r0
 314         bctr
 315
 316         The arguments (passed in registers r3 - r10) are shuffled along by two to
 317         make room for hptr and a dummy argument. As r9 and r10 are overwritten by
 318         this code, it only works for up to 6 arguments (when floating point arguments
 319         are involved, this may be more or less, depending on the exact situation).
 320 */
 321         if ((adjustor = stgMallocBytes(4*13, "createAdjustor")) != NULL) {
 322                 unsigned long *const adj_code = (unsigned long *)adjustor;
 323
 324                 // make room for extra arguments
 325                 adj_code[0] = 0x7d0a4378;       //mr r10,r8
 326                 adj_code[1] = 0x7ce93b78;       //mr r9,r7
 327                 adj_code[2] = 0x7cc83378;       //mr r8,r6
 328                 adj_code[3] = 0x7ca72b78;       //mr r7,r5
 329                 adj_code[4] = 0x7c862378;       //mr r6,r4
 330                 adj_code[5] = 0x7c651b78;       //mr r5,r3
 331
 332                 adj_code[6] = 0x3c000000;       //lis r0,hi(wptr)
 333                 adj_code[6] |= ((unsigned long)wptr) >> 16;
 334
 335                 adj_code[7] = 0x3c600000;       //lis r3,hi(hptr)
 336                 adj_code[6] |= ((unsigned long)hptr) >> 16;
 337
 338                 adj_code[8] = 0x60000000;       //ori r0,r0,lo(wptr)
 339                 adj_code[8] |= ((unsigned long)wptr) & 0xFFFF;
 340
 341                 adj_code[9] = 0x60630000;       //ori r3,r3,lo(hptr)
 342                 adj_code[9] |= ((unsigned long)hptr) & 0xFFFF;
 343
 344                 adj_code[10] = 0x7c0903a6;      //mtctr r0
 345                 adj_code[11] = 0x4e800420;      //bctr
 346                 adj_code[12] = (unsigned long)hptr;
 347
 348                 // Flush the Instruction cache:
 349                 //      MakeDataExecutable(adjustor,4*13);
 350                         /* This would require us to link with CoreServices.framework */
 351                 {               /* this should do the same: */
 352                         int n = 13;
 353                         unsigned long *p = adj_code;
 354                         while(n--)
 355                         {
 356                                 __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
 357                                                     : : "g" (p));
 358                                 p++;
 359                         }
 360                         __asm__ volatile ("sync\n\tisync");
 361                 }
 362         }
 363 #else
 364 #error Adjustor creation is not supported on this platform.
 365 #endif
 366     break;
 367
 368   default:
 369     ASSERT(0);
 370     break;
 371   }
 372
 373   /* Have fun! */
 374   return adjustor;
 375 }
 376
 377 #endif
 378
 379 void
 380 freeHaskellFunctionPtr(void* ptr)
 381 {
 382 #if defined(i386_TARGET_ARCH)
 383  if ( *(unsigned char*)ptr != 0x68 &&
 384       *(unsigned char*)ptr != 0x58 ) {
 385    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 386    return;
 387  }
 388
 389  /* Free the stable pointer first..*/
 390  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 391     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 392  } else {
 393     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 394  }
 395 #elif defined(sparc_TARGET_ARCH)
 396  if ( *(unsigned long*)ptr != 0x9A10000B ) {
 397    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 398    return;
 399  }
 400
 401  /* Free the stable pointer first..*/
 402  freeStablePtr(*((StgStablePtr*)((unsigned long*)ptr + 8)));
 403 #elif defined(alpha_TARGET_ARCH)
 404  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 405    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 406    return;
 407  }
 408
 409  /* Free the stable pointer first..*/
 410  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 411 #elif defined(powerpc_TARGET_ARCH)
 412  if ( *(StgWord*)ptr != 0x7d0a4378 ) {
 413    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 414    return;
 415  }
 416  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 4*12)));
 417 #else
 418  ASSERT(0);
 419 #endif
 420  *((unsigned char*)ptr) = '\0';
 421
 422  free(ptr);
 423 }
 424