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     if ((adjustor = stgMallocBytes(4*(8+1), "createAdjustor")) != NULL) {
 197         unsigned long *const adj_code = (unsigned long *)adjustor;
 198
 199         /* mov  %o3, %o5 */
 200         adj_code[0] = (unsigned long)0x9A10000B;
 201         /* mov  %o2, %o4 */
 202         adj_code[1] = (unsigned long)0x9810000A;
 203         /* mov  %o1, %o3 */
 204         adj_code[2] = (unsigned long)0x96100009;
 205         /* mov  %o0, %o2 */
 206         adj_code[3] = (unsigned long)0x94100008;
 207
 208         /* sethi %hi(wptr), %o1 */
 209         adj_code[4] = (unsigned long)0x13000000;
 210         adj_code[4] |= ((unsigned long)wptr) >> 10;
 211
 212         /* sethi %hi(hptr), %o0 */
 213         adj_code[5] = (unsigned long)0x11000000;
 214         adj_code[5] |= ((unsigned long)hptr) >> 10;
 215
 216         /* jmp %o1+%lo(wptr) */
 217         adj_code[6] = (unsigned long)0x81c26000;
 218         adj_code[6] |= ((unsigned long)wptr) & 0x000003ff;
 219
 220         /* or %o0, %lo(hptr), %o0 */
 221         adj_code[7] = (unsigned long)0x90122000;
 222         adj_code[7] |= ((unsigned long)hptr) & 0x000003ff;
 223
 224         adj_code[8] = (StgStablePtr)hptr;
 225     }
 226 #elif defined(alpha_TARGET_ARCH)
 227   /* Magic constant computed by inspecting the code length of
 228      the following assembly language snippet
 229      (offset and machine code prefixed; note that the machine code
 230      shown is longwords stored in little-endian order):
 231
 232   <00>: 46520414        mov     a2, a4
 233   <04>: 46100412        mov     a0, a2
 234   <08>: a61b0020        ldq     a0, 0x20(pv)    # load up hptr
 235   <0c>: 46730415        mov     a3, a5
 236   <10>: a77b0028        ldq     pv, 0x28(pv)    # load up wptr
 237   <14>: 46310413        mov     a1, a3
 238   <18>: 6bfb----        jmp     (pv), <hint>    # jump to wptr (with hint)
 239   <1c>: 00000000                                # padding for alignment
 240   <20>: [8 bytes for hptr quadword]
 241   <28>: [8 bytes for wptr quadword]
 242
 243      The "computed" jump at <08> above is really a jump to a fixed
 244      location.  Accordingly, we place an always-correct hint in the
 245      jump instruction, namely the address offset from <0c> to wptr,
 246      divided by 4, taking the lowest 14 bits.
 247
 248      We only support passing 4 or fewer argument words, for the same
 249      reason described under sparc_TARGET_ARCH above by JRS, 21 Aug 01.
 250      On the Alpha the first 6 integer arguments are in a0 through a5,
 251      and the rest on the stack.  Hence we want to shuffle the original
 252      caller's arguments by two.
 253
 254      On the Alpha the calling convention is so complex and dependent
 255      on the callee's signature -- for example, the stack pointer has
 256      to be a multiple of 16 -- that it seems impossible to me [ccshan]
 257      to handle the general case correctly without changing how the
 258      adjustor is called from C.  For now, our solution of shuffling
 259      registers only and ignoring the stack only works if the original
 260      caller passed 4 or fewer argument words.
 261
 262 TODO: Depending on how much allocation overhead stgMallocBytes uses for
 263       header information (more precisely, if the overhead is no more than
 264       4 bytes), we should move the first three instructions above down by
 265       4 bytes (getting rid of the nop), hence saving memory. [ccshan]
 266   */
 267     ASSERT(((StgWord64)wptr & 3) == 0);
 268     if ((adjustor = stgMallocBytes(48, "createAdjustor")) != NULL) {
 269         StgWord64 *const code = (StgWord64 *)adjustor;
 270
 271         code[0] = 0x4610041246520414L;
 272         code[1] = 0x46730415a61b0020L;
 273         code[2] = 0x46310413a77b0028L;
 274         code[3] = 0x000000006bfb0000L
 275                 | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff);
 276
 277         code[4] = (StgWord64)hptr;
 278         code[5] = (StgWord64)wptr;
 279
 280         /* Ensure that instruction cache is consistent with our new code */
 281         __asm__ volatile("call_pal %0" : : "i" (PAL_imb));
 282     }
 283 #elif defined(powerpc_TARGET_ARCH)
 284 /*
 285         For PowerPC, the following code is used:
 286
 287         mr r10,r8
 288         mr r9,r7
 289         mr r8,r6
 290         mr r7,r5
 291         mr r6,r4
 292         mr r5,r3
 293         lis r0,0xDEAD ;hi(wptr)
 294         lis r3,0xDEAF ;hi(hptr)
 295         ori r0,r0,0xBEEF ; lo(wptr)
 296         ori r3,r3,0xFACE ; lo(hptr)
 297         mtctr r0
 298         bctr
 299
 300         The arguments (passed in registers r3 - r10) are shuffled along by two to
 301         make room for hptr and a dummy argument. As r9 and r10 are overwritten by
 302         this code, it only works for up to 6 arguments (when floating point arguments
 303         are involved, this may be more or less, depending on the exact situation).
 304 */
 305         if ((adjustor = stgMallocBytes(4*13, "createAdjustor")) != NULL) {
 306                 unsigned long *const adj_code = (unsigned long *)adjustor;
 307
 308                 // make room for extra arguments
 309                 adj_code[0] = 0x7d0a4378;       //mr r10,r8
 310                 adj_code[1] = 0x7ce93b78;       //mr r9,r7
 311                 adj_code[2] = 0x7cc83378;       //mr r8,r6
 312                 adj_code[3] = 0x7ca72b78;       //mr r7,r5
 313                 adj_code[4] = 0x7c862378;       //mr r6,r4
 314                 adj_code[5] = 0x7c651b78;       //mr r5,r3
 315
 316                 adj_code[6] = 0x3c000000;       //lis r0,hi(wptr)
 317                 adj_code[6] |= ((unsigned long)wptr) >> 16;
 318
 319                 adj_code[7] = 0x3c600000;       //lis r3,hi(hptr)
 320                 adj_code[6] |= ((unsigned long)hptr) >> 16;
 321
 322                 adj_code[8] = 0x60000000;       //ori r0,r0,lo(wptr)
 323                 adj_code[8] |= ((unsigned long)wptr) & 0xFFFF;
 324
 325                 adj_code[9] = 0x60630000;       //ori r3,r3,lo(hptr)
 326                 adj_code[9] |= ((unsigned long)hptr) & 0xFFFF;
 327
 328                 adj_code[10] = 0x7c0903a6;      //mtctr r0
 329                 adj_code[11] = 0x4e800420;      //bctr
 330                 adj_code[12] = (unsigned long)hptr;
 331
 332                 //MakeDataExecutable(adjustor,4*13);    // don't know if it is _really_ necessary
 333         }
 334 #else
 335 #error Adjustor creation is not supported on this platform.
 336 #endif
 337     break;
 338
 339   default:
 340     ASSERT(0);
 341     break;
 342   }
 343
 344   /* Have fun! */
 345   return adjustor;
 346 }
 347
 348 #endif
 349
 350 void
 351 freeHaskellFunctionPtr(void* ptr)
 352 {
 353 #if defined(i386_TARGET_ARCH)
 354  if ( *(unsigned char*)ptr != 0x68 &&
 355       *(unsigned char*)ptr != 0x58 ) {
 356    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 357    return;
 358  }
 359
 360  /* Free the stable pointer first..*/
 361  if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
 362     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
 363  } else {
 364     freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
 365  }
 366 #elif defined(sparc_TARGET_ARCH)
 367  if ( *(unsigned char*)ptr != 0x13 ) {
 368    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 369    return;
 370  }
 371
 372  /* Free the stable pointer first..*/
 373  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 374 #elif defined(alpha_TARGET_ARCH)
 375  if ( *(StgWord64*)ptr != 0xa77b0018a61b0010L ) {
 376    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 377    return;
 378  }
 379
 380  /* Free the stable pointer first..*/
 381  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
 382 #elif defined(powerpc_TARGET_ARCH)
 383  if ( *(StgWord*)ptr != 0x7d0a4378 ) {
 384    fprintf(stderr, "freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
 385    return;
 386  }
 387  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 4*12)));
 388 #else
 389  ASSERT(0);
 390 #endif
 391  *((unsigned char*)ptr) = '\0';
 392
 393  free(ptr);
 394 }
 395