[project @ 2005-01-10 18:44:38 by wolfgang]

Handle foreign import wrapper properly for MacOS X, powerpc64-linux and AIX.
Only Mac OS X tested so far.
Pass information about argument types from DsForeign to createAdjustor encoded
as a string ('i' for integers, 'f' for floats, 'd' for doubles and 'l' for
long [64bit] integers).

ghc/compiler/deSugar/DsForeign.lhs

@@ -23,11 +23,11 @@ import DataCon		( splitProductType_maybe )
 import DataCon		( dataConSourceArity )
 import Type		( isUnLiftedType )
 #endif
-import MachOp		( machRepByteWidth )
+import MachOp		( machRepByteWidth, MachRep(..) )
 import SMRep		( argMachRep, primRepToCgRep )
 import CoreUtils	( exprType, mkInlineMe )
 import Id		( Id, idType, idName, mkSysLocal, setInlinePragma )
-import Literal		( Literal(..) )
+import Literal		( Literal(..), mkStringLit )
 import Module		( moduleString )
 import Name		( getOccString, NamedThing(..) )
 import OccName		( encodeFS )
@@ -389,11 +389,20 @@ dsFExportDynamic id cconv
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
 		      , Var stbl_value
 		      , mkLit (MachLabel fe_nm mb_sz_args)
+                      , mkLit (mkStringLit arg_type_info)
 		      ]
         -- name of external entry point providing these services.
 	-- (probably in the RTS.) 
       adjustor	 = FSLIT("createAdjustor")
       
+      arg_type_info = drop 2 $ map (repCharCode.argMachRep
+                                   .primRepToCgRep.typePrimRep)
+                                   stub_args
+      repCharCode F32 = 'f'
+      repCharCode F64 = 'd'
+      repCharCode I64 = 'l'
+      repCharCode _   = 'i'
+
 	-- Determine the number of bytes of arguments to the stub function,
 	-- so that we can attach the '@N' suffix to its label if it is a
 	-- stdcall on Windows.

ghc/includes/RtsExternal.h

 /* -----------------------------------------------------------------------------
- * $Id: RtsExternal.h,v 1.6 2004/10/15 07:48:29 simonmar Exp $
+ * $Id: RtsExternal.h,v 1.7 2005/01/10 18:44:40 wolfgang Exp $
  *
  * (c) The GHC Team, 1998-2004
  *
@@ -59,7 +59,8 @@ extern StgInt        suspendThread ( StgRegTable * );
 extern StgRegTable * resumeThread  ( StgInt );
 
 /* Creating and destroying an adjustor thunk */
-extern void*  createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr);
+extern void*  createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr,
+                             char *typeString);
 extern void   freeHaskellFunctionPtr(void* ptr);
 
 /* -----------------------------------------------------------------------------

ghc/rts/Adjustor.c

@@ -134,33 +134,52 @@ stgAllocStable(size_t size_in_bytes, StgStablePtr *stable)
 }
 #endif
 
-#if defined(powerpc64_TARGET_ARCH)
-// We don't need to generate dynamic code on powerpc64-[linux|AIX],
-// but we do need a piece of (static) inline assembly code:
+#if defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
+#if !(defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS))
+
+/* !!! !!! WARNING: !!! !!!
+ * This structure is accessed from AdjustorAsm.s
+ * Any changes here have to be mirrored in the offsets there.
+ */
+
+typedef struct AdjustorStub {
+#if defined(powerpc_TARGET_ARCH) && defined(darwin_TARGET_OS)
+    unsigned        lis;
+    unsigned        ori;
+    unsigned        lwz;
+    unsigned        mtctr;
+    unsigned        bctr;
+    StgFunPtr       code;
+#elif defined(powerpc64_TARGET_ARCH) && defined(darwin_TARGET_OS)
+        /* powerpc64-darwin: just guessing that it won't use fundescs. */
+    unsigned        lis;
+    unsigned        ori;
+    unsigned        rldimi;
+    unsigned        oris;
+    unsigned        ori2;
+    unsigned        lwz;
+    unsigned        mtctr;
+    unsigned        bctr;
+    StgFunPtr       code;
+#else
+        /* fundesc-based ABIs */
+#define         FUNDESCS
+    StgFunPtr       code;
+    struct AdjustorStub
+                    *toc;
+    void            *env;
+#endif
+    StgStablePtr    hptr;
+    StgFunPtr       wptr;
+    StgInt          negative_framesize;
+    StgInt          extrawords_plus_one;
+} AdjustorStub;
 
-static void
-adjustorCodeWrittenInAsm()
-{
-	__asm__ volatile (
-		"adjustorCode:\n\t"
-		"mr 10,8\n\t"
-		"mr 9,7\n\t"
-		"mr 8,6\n\t"
-		"mr 7,5\n\t"
-		"mr 6,4\n\t"
-		"mr 5,3\n\t"
-		"mr 3,11\n\t"
-		"ld 0,0(2)\n\t"
-		"ld 11,16(2)\n\t"
-		"mtctr 0\n\t"
-		"ld 2,8(2)\n\t"
-		"bctr"
-		: : );
-}
+#endif
 #endif
 
 void*
-createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr)
+createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr, char *typeString)
 {
   void *adjustor = NULL;
 
@@ -364,9 +383,9 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
 	/* Ensure that instruction cache is consistent with our new code */
 	__asm__ volatile("call_pal %0" : : "i" (PAL_imb));
     }
-#elif defined(powerpc_TARGET_ARCH)
+#elif defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
 /*
-	For PowerPC, the following code is used:
+	For PowerPC Linux, the following code is used:
 
 	mr r10,r8
 	mr r9,r7
@@ -429,27 +448,102 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
 			__asm__ volatile ("sync\n\tisync");
 		}
 	}
-#elif defined(powerpc64_TARGET_ARCH)
-	// This is for powerpc64 linux and powerpc64 AIX.
-	// It probably won't apply to powerpc64-darwin.
-	
-	{
-		typedef struct {
-			StgFunPtr		code;
-			void*			toc;
-			void*			env;
-		} FunDesc;
-		
-		FunDesc *desc = malloc(sizeof(FunDesc));
-		extern void *adjustorCode;
-		
-		desc->code = (void*) &adjustorCode;
-		desc->toc = (void*) wptr;
-		desc->env = (void*) hptr;
+
+#elif defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
+        
+#define OP_LO(op,lo)  ((((unsigned)(op)) << 16) | (((unsigned)(lo)) & 0xFFFF))
+#define OP_HI(op,hi)  ((((unsigned)(op)) << 16) | (((unsigned)(hi)) >> 16))
+        {
+            AdjustorStub *adjustorStub;
+            int sz = 0, extra_sz, total_sz;
+
+                  // from AdjustorAsm.s
+                  // not declared as a function so that AIX-style
+                  // fundescs can never get in the way.
+            extern void *adjustorCode;
+            
+#ifdef FUNDESCS
+            adjustorStub = stgMallocBytes(sizeof(AdjustorStub), "createAdjustor");
+#else
+            adjustorStub = mallocBytesRWX(sizeof(AdjustorStub));
+#endif
+            adjustor = adjustorStub;
 		
-		adjustor = (void*) desc;
-	}
-	break;
+	    adjustorStub->code = (void*) &adjustorCode;
+
+#ifdef FUNDESCS
+                // function descriptors are a cool idea.
+                // We don't need to generate any code at runtime.
+            adjustorStub->toc = adjustorStub;
+#else
+
+                // no function descriptors :-(
+                // We need to do things "by hand".
+#if defined(powerpc_TARGET_ARCH)
+                // lis  r2, hi(adjustorStub)
+            adjustorStub->lis = OP_HI(0x3c40, adjustorStub);
+                // ori  r2, r2, lo(adjustorStub)
+            adjustorStub->ori = OP_LO(0x6042, adjustorStub);
+                // lwz r0, code(r2)
+            adjustorStub->lwz = OP_LO(0x8002, (char*)(&adjustorStub->code)
+                                            - (char*)adjustorStub);
+                // mtctr r0
+            adjustorStub->mtctr = 0x7c0903a6;
+                // bctr
+            adjustorStub->bctr = 0x4e800420;
+#else
+            barf("adjustor creation not supported on this platform");
+#endif
+
+            // Flush the Instruction cache:
+            {
+                int n = sizeof(AdjustorStub)/sizeof(unsigned);
+                unsigned *p = (unsigned*)adjustor;
+                while(n--)
+                {
+                    __asm__ volatile ("dcbf 0,%0\n\tsync\n\ticbi 0,%0"
+                                        : : "r" (p));
+                    p++;
+                }
+                __asm__ volatile ("sync\n\tisync");
+            }
+#endif
+
+            printf("createAdjustor: %s\n", typeString);
+            while(*typeString)
+            {
+                char t = *typeString++;
+
+                switch(t)
+                {
+#if defined(powerpc64_TARGET_ARCH)
+                    case 'd': sz += 1; break;
+                    case 'l': sz += 1; break;
+#else
+                    case 'd': sz += 2; break;
+                    case 'l': sz += 2; break;
+#endif
+                    case 'f': sz += 1; break;
+                    case 'i': sz += 1; break;
+                }
+            }
+            extra_sz = sz - 8;
+            if(extra_sz < 0)
+                extra_sz = 0;
+            total_sz = (6 /* linkage area */
+                      + 8 /* minimum parameter area */
+                      + 2 /* two extra arguments */
+                      + extra_sz)*sizeof(StgWord);
+           
+                // align to 16 bytes.
+                // AIX only requires 8 bytes, but who cares?
+            total_sz = (total_sz+15) & ~0xF;
+           
+            adjustorStub->hptr = hptr;
+            adjustorStub->wptr = wptr;
+            adjustorStub->negative_framesize = -total_sz;
+            adjustorStub->extrawords_plus_one = extra_sz + 1;
+        }
 
 #elif defined(ia64_TARGET_ARCH)
 /*
@@ -577,12 +671,19 @@ freeHaskellFunctionPtr(void* ptr)
 
  /* Free the stable pointer first..*/
  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x10)));
-#elif defined(powerpc_TARGET_ARCH)
+#elif defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS)
  if ( *(StgWord*)ptr != 0x7d0a4378 ) {
    errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
    return;
  }
  freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 4*12)));
+#elif defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
+ extern void* adjustorCode;
+ if ( ((AdjustorStub*)ptr)->code != (StgFunPtr) &adjustorCode ) {
+   errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr);
+   return;
+ }
+ freeStablePtr(((AdjustorStub*)ptr)->hptr);
 #elif defined(ia64_TARGET_ARCH)
  IA64FunDesc *fdesc = (IA64FunDesc *)ptr;
  StgWord64 *code = (StgWord64 *)(fdesc+1);

ghc/rts/AdjustorAsm.S

+#include "../includes/ghcconfig.h"
+
+#if defined(powerpc_TARGET_ARCH) || defined(powerpc64_TARGET_ARCH)
+#if !(defined(powerpc_TARGET_ARCH) && defined(linux_TARGET_OS))
+    /* The following code applies, with some differences,
+       to all powerpc platforms except for powerpc32-linux,
+       whose calling convention is annoyingly complex.
+    */
+
+
+    /* The code is "almost" the same for
+       32-bit and for 64-bit
+    */
+#if defined(powerpc64_TARGET_ARCH)
+#define WS          8
+#define LOAD        ld
+#define STORE       std
+#else
+#define WS          4
+#define LOAD        lwz
+#define STORE       stw
+#endif
+
+    /* Some info about stack frame layout */
+#define LINK_SLOT           (2*WS)
+#define LINKAGE_AREA_SIZE   (6*WS)
+
+    /* The following defines mirror struct AdjustorStub
+       from Adjustor.c. Make sure to keep these in sync.
+    */
+#if defined(powerpc_TARGET_ARCH) && defined(darwin_TARGET_OS)
+#define HEADER_WORDS   6
+#elif defined(powerpc64_TARGET_ARCH) && defined(darwin_TARGET_OS)
+#else
+#define HEADER_WORDS   3
+#endif
+
+#define HPTR_OFF        ((HEADER_WORDS    )*WS)
+#define WPTR_OFF        ((HEADER_WORDS + 1)*WS)
+#define FRAMESIZE_OFF   ((HEADER_WORDS + 2)*WS)
+#define EXTRA_WORDS_OFF ((HEADER_WORDS + 3)*WS)
+
+    /* Darwin insists on register names, everyone else prefers
+       to use numbers. */
+#if !defined(darwin_TARGET_OS)
+#define r0 0
+#define r1 1
+#define r2 2
+#define r3 3
+#define r4 4
+#define r5 5
+#define r6 6
+#define r7 7
+#define r8 8
+#define r9 9
+#define r10 10
+#define r11 11
+#define r12 12
+
+#define r30 30
+#define r31 31
+#endif
+
+
+.text
+#if LEADING_UNDERSCORE
+    .globl _adjustorCode
+_adjustorCode:
+#else
+    .globl adjustorCode
+        /* Note that we don't build a function descriptor
+           for AIX-derived ABIs here. This will happen at runtime
+           in createAdjustor().
+        */
+adjustorCode:
+#endif
+    /* On entry, r2 will point to the AdjustorStub data structure. */
+
+        /* save the link */
+    mflr    r0
+    STORE   r0, LINK_SLOT(r1)
+    
+        /* set up stack frame */
+    LOAD    r12, FRAMESIZE_OFF(r2)
+#ifdef powerpc64_TARGET_ARCH
+    stdux   r1, r1, r12
+#else   
+    stwux   r1, r1, r12
+#endif
+
+        /* Save some regs so that we can use them.
+           Note that we use the "Red Zone" below the stack pointer.
+        */
+    STORE   r31, -WS(r1)
+    STORE   r30, -2*WS(r1)
+
+    mr      r31, r1
+    subf    r30, r12, r31
+
+    LOAD    r12, EXTRA_WORDS_OFF(r2)
+    mtctr   r12
+    b       2f
+1:
+    LOAD    r0, LINKAGE_AREA_SIZE +  8*WS(r30)
+    STORE   r0, LINKAGE_AREA_SIZE + 10*WS(r31)
+    addi    r30, r30, WS
+    addi    r31, r31, WS
+2:
+    bdnz    1b
+
+        /* Restore r30 and r31 now.
+        */
+    LOAD    r31, -WS(r1)
+    LOAD    r30, -2*WS(r1)
+
+    STORE   r10, LINKAGE_AREA_SIZE + 9*WS(r1)
+    STORE   r9,  LINKAGE_AREA_SIZE + 8*WS(r1)
+    mr      r10, r8
+    mr      r9, r7
+    mr      r8, r6
+    mr      r7, r5
+    mr      r6, r4
+    mr      r5, r3
+
+    LOAD    r3, HPTR_OFF(r2)
+
+    LOAD    r0, WPTR_OFF(r2)
+    mtctr   r0
+    bctrl
+
+    LOAD    r1, 0(r1)
+    LOAD    r0, LINK_SLOT(r1)
+    mtlr    r0
+    blr
+#endif
+#endif
+