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