From 0600f5d1cf4882ba6292ea5382e695270b1a6ba1 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Tue, 19 Oct 1999 11:03:39 +0000
Subject: [PATCH] [project @ 1999-10-19 11:01:24 by sewardj] Reimplement
back-end for foreign import (calling out).
Return to a cleaned-up version of Alastair's callfun.S,
wherein an architecture and calling-convention specific
piece of assembly code is used to construct arguments and
then call the specified function, under the direction of
a type descriptor string.
Defined an interface to this function (universal_call_c)
which I hope will work regardless of 32-or-64 bitness,
endianness and calling convention.
Current implementation is for x86-linux only.
---
ghc/interpreter/translate.c | 9 +-
ghc/rts/Evaluator.c | 21 +-
ghc/rts/ForeignCall.c | 400 +++++++++++++++++++-----------------
ghc/rts/ForeignCall.h | 9 +-
ghc/rts/callfun.S | 162 ---------------
ghc/rts/universal_call_c.S | 137 ++++++++++++
6 files changed, 370 insertions(+), 368 deletions(-)
delete mode 100644 ghc/rts/callfun.S
create mode 100644 ghc/rts/universal_call_c.S
diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 23cad388d33c..72dd4325485a 100644
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 21:41:00 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/19 11:01:24 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -852,6 +852,11 @@ Void implementForeignImport ( Name n )
mapOver(foreignInboundTy,resultTys); /* doesn't */
descriptor = mkDescriptor(charListToString(argTys),
charListToString(resultTys));
+ if (!descriptor) {
+ ERRMSG(0) "Can't allocate memory for call descriptor"
+ EEND;
+ }
+
name(n).primop = addState ? &ccall_IO : &ccall_Id;
{
Pair extName = name(n).defn;
diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index 172ccb54d645..b72ec980c657 100644
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.18 $
- * $Date: 1999/10/15 11:03:01 $
+ * $Revision: 1.19 $
+ * $Date: 1999/10/19 11:01:26 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
@@ -1551,11 +1551,11 @@ static inline void PushTaggedWord ( StgWord x )
{ Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
inline void PushTaggedAddr ( StgAddr x )
{ Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
-static inline void PushTaggedChar ( StgChar x )
+ inline void PushTaggedChar ( StgChar x )
{ Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
-static inline void PushTaggedFloat ( StgFloat x )
+ inline void PushTaggedFloat ( StgFloat x )
{ Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
-static inline void PushTaggedDouble ( StgDouble x )
+ inline void PushTaggedDouble ( StgDouble x )
{ Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
static inline void PushTaggedStablePtr ( StgStablePtr x )
{ Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
@@ -3044,10 +3044,17 @@ off the stack.
case i_ccall_Id:
case i_ccall_IO:
{
+ int r;
CFunDescriptor* descriptor = PopTaggedAddr();
void (*funPtr)(void) = PopTaggedAddr();
- ccall(descriptor,funPtr,bco);
- break;
+ r = ccall(descriptor,funPtr,bco);
+ if (r == 0) break;
+ if (r == 1)
+ return makeErrorCall(
+ "unhandled type or too many args/results in ccall");
+ if (r == 2)
+ barf("ccall not configured correctly for this platform");
+ barf("unknown return code from ccall");
}
default:
barf("Unrecognised primop2");
diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index e8d0c97da4ca..32946efdebfd 100644
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
/* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.5 1999/10/15 11:03:06 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.6 1999/10/19 11:01:26 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
@@ -16,225 +16,239 @@
#include "Evaluator.h"
#include "ForeignCall.h"
-/* the assymetry here seem to come from the caller-allocates
- * calling convention. But does the caller really allocate
- * result??
- */
-void hcall( HFunDescriptor* d, StablePtr fun, void* as, void* rs)
-{
-#if 0
- /* out of date - ADR */
- marshall(d->arg_tys,as);
- prim_hcall(fun);
- unmarshall(d->result_tys,rs);
-#else
- assert(0);
-#endif
-}
+/* --------------------------------------------------------------------------
+ * Calling out to C: a simple, universal calling API
+ * ------------------------------------------------------------------------*/
-#if 0
-/* By experiment on an x86 box, we found that gcc's
- * __builtin_apply(fun,as,size) expects *as to look like this:
- * as[0] = &first arg = &as[1]
- * as[1] = arg1
- * as[2] = arg2
- * ...
- *
- * on an x86, it returns a pointer to a struct containing an
- * int/int64/ptr in its first 4-8 bytes and a float/double in the next
- * 8 bytes.
- *
- * On a sparc:
- * as[0] = &first arg = &as[2]
- * as[1] = where structures should be returned
- * as[2] = arg1
- * as[3] = arg2
- * ...
- *
- * This is something of a hack - but seems to be more portable than
- * hacking it up in assembly language which is how I did it before - ADR
- */
-void ccall( CFunDescriptor* d, void (*fun)(void) )
-{
- void *rs;
- char* tys = d->arg_tys;
- /* ToDo: the use of ARG_SIZE is based on the assumption that Hugs
- * obeys the same alignment restrictions as C.
- * But this is almost certainly wrong!
- * We could use gcc's __va_rounded_size macro (see varargs.h) to do a
- * better job.
- */
-#if i386_TARGET_ARCH
- void *as=alloca(4 + d->arg_size);
- StgWord* args = (StgWord*) as;
- *(void**)(args++) = 4 + (char*)as; /* incoming args ptr */
- for(; *tys; ++tys) {
- args += unmarshall(*tys,args);
- }
- rs = __builtin_apply(fun,as,(char*)args-(char*)as-4);
-#elif sparc_TARGET_ARCH
- void *as=alloca(8 + d->arg_size);
- StgWord* args = (StgWord*) as;
- int argcount;
- *(void**)(args++) = (char*)as; /* incoming args ptr */
- *(void**)(args++) = 0; /* structure value address - I think this is the address of a block of memory where structures are returned - in which case we should initialise with rs or something like that*/
- for(; *tys; ++tys) {
- args += unmarshall(*tys,args);
- }
- argcount = ((void*)args - as);
- ASSERT(8 + d->arg_size == argcount);
- if (argcount <= 8) {
- argcount = 0;
- } else {
- argcount -= 4;
- }
- rs = __builtin_apply(fun,as,argcount);
-#else
-#error Cant do ccall for this architecture
-#endif
-
- /* ToDo: can't handle multiple return values at the moment
- * - it's hard enough to get single return values working
- */
- if (*(d->result_tys)) {
- char ty = *(d->result_tys);
- ASSERT(d->result_tys[1] == '\0');
- switch (ty) {
- case 'F':
- case 'D':
- /* ToDo: is this right? */
- marshall(ty,(char*)rs+8);
- return;
- default:
- marshall(ty,rs);
- return;
- }
- }
-}
-#endif
+/* The universal call-C API supplies a single function:
+
+ void universal_call_c ( int n_args,
+ void* args,
+ char* argstr,
+ void* fun )
+
+ PRECONDITIONS
+
+ args points to the start of a block of memory containing the
+ arguments. This block is an array of 8-byte entities,
+ containing (n_args+1) slots. The zeroth slot is where the
+ return result goes. Slots [1 .. n_args] contain the arguments,
+ presented left-to-right.
+
+ Arguments are stored in the host's byte ordering inside
+ the slots. Only 4 or 8 byte entities are allowed.
+ 4-byte entities are stored in the half-slot with lower
+ addresses.
+
+ For example, a 32-bit value 0xAABBCCDD would be stored, on
+ a little-endian, as
+
+ DD CC BB AA 0 0 0 0
+
+ whereas on a big-endian would expect
+
+ AA BB CC DD 0 0 0 0
+
+ Clients do not need to fill in the zero bytes; they are there
+ only for illustration.
+
+ argstr is a simplified argument descriptor string. argstr
+ has one character for each (notional) argument slot of
+ args. That means the first byte of argstr describes the
+ return type. args should be allocated by the caller to hold
+ as many slots as implied by argstr.
+
+ argstr always specifies a return type. If the function to
+ be called returns no result, you must specify a bogus
+ return type in argstr[0]; a 32-bit int seems like a good bet.
+ Characters in argstr specify the result and argument types:
+ i 32-bit integral
+ I 64-bit integral
+ f 32-bit floating
+ F 64-bit floating
+ Pointers should travel as integral entities. At the moment
+ there are no descriptors for entities smaller than 32 bits
+ since AFAIK all calling conventions expand smaller entities
+ to 32 bits anyway. Users of this routine need to handle
+ packing/unpacking of 16 and 8 bit quantities themselves.
-#if 1
-/* HACK alert (red alert) */
+ If the preconditions are not met, behaviour of
+ universal_call_c is entirely undefined.
+
+
+ POSTCONDITION
+
+ The function specified by fun is called with arguments
+ in args as specified by argstr. The result of the call
+ is placed in the first 8 bytes of args, again as specified
+ by the first byte of argstr. Calling and returning is to
+ be done using the correct calling convention for the
+ architecture.
+
+ It's clear that implementations of universal_call_c will
+ have to be handwritten assembly. The above design is intended
+ to make that assembly as simple as possible, at the expense
+ of a small amount of complication for the API's user.
+*/
+
+/* ToDo: move these to the Right Place */
extern StgInt PopTaggedInt ( void ) ;
extern StgDouble PopTaggedDouble ( void ) ;
extern StgFloat PopTaggedFloat ( void ) ;
extern StgChar PopTaggedChar ( void ) ;
extern StgAddr PopTaggedAddr ( void ) ;
-extern void PushTaggedInt ( StgInt );
-extern void PushTaggedAddr ( StgAddr );
+extern void PushTaggedInt ( StgInt );
+extern void PushTaggedDouble ( StgDouble );
+extern void PushTaggedFloat ( StgFloat );
+extern void PushTaggedChar ( StgChar );
+extern void PushTaggedAddr ( StgAddr );
+
extern void PushPtr ( StgPtr );
extern StgPtr PopPtr ( void );
-int seqNr = 0;
-#define IF(sss) if (strcmp(sss,cdesc)==0)
-#define STS PushPtr((StgPtr)(*bco));SaveThreadState()
-#define LTS LoadThreadState();*bco=(StgBCO*)PopPtr();
-#define LTS_RET LoadThreadState();*bco=(StgBCO*)PopPtr(); return
-#define RET return
-void ccall( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
+/* --------------------------------------------------------------------------
+ * Move args/results between STG stack and the above API's arg block
+ * Returns 0 on success
+ * 1 if too many args/results or non-handled type
+ * 2 if config error on this platform
+ * Tries to automatically handle 32-vs-64 bit differences.
+ * ------------------------------------------------------------------------*/
+
+int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
{
- int i;
- char cdesc[100];
- strcpy(cdesc, d->result_tys);
- strcat(cdesc, ":");
- strcat(cdesc, d->arg_tys);
- for (i = 0; cdesc[i] != 0; i++) {
- switch (cdesc[i]) {
- case 'x': cdesc[i] = 'A'; break;
- default: break;
+ double arg_vec [31];
+ char argd_vec[31];
+ unsigned int* p;
+ int i;
+
+ if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
+ || (sizeof(void*) != 4 && sizeof(void*) != 8))
+ return 2;
+
+ if (d->num_args > 30 || d->num_results > 1)
+ return 1; /* unlikely, but ... */
+
+ //fprintf ( stderr, "ccall: `%s' %d -> `%s' %d\n",
+ // d-> arg_tys, d->num_args, d->result_tys, d->num_results );
+
+ p = (unsigned int*) &arg_vec[1];
+ for (i = 0; i < d->num_args; i++) {
+ switch (d->arg_tys[i]) {
+ case CHAR_REP: {
+ int j = (int)PopTaggedChar();
+ *p++ = j; *p++ = 0;
+ argd_vec[i+1] = 'i';
+ break;
+ }
+ case INT_REP: {
+ int j = PopTaggedInt();
+ *p++ = j; *p++ = 0;
+ argd_vec[i+1] = 'i';
+ break;
+ }
+ case ADDR_REP: {
+ void* a = PopTaggedAddr();
+ if (sizeof(void*) == 4) {
+ *(void**)p = a; p++; *p++ = 0;
+ argd_vec[i+1] = 'i';
+ } else {
+ *(void**)p = a;
+ p += 2;
+ argd_vec[i+1] = 'I';
+ }
+ break;
+ }
+ case FLOAT_REP: {
+ float f = PopTaggedFloat();
+ *(float*)p = f; p++; *p++ = 0;
+ argd_vec[i+1] = 'f';
+ break;
+ }
+ case DOUBLE_REP: {
+ double d = PopTaggedDouble();
+ *(double*)p = d; p+=2;
+ argd_vec[i+1] = 'F';
+ break;
+ }
+ default:
+ return 1;
}
}
- //fprintf(stderr, "ccall: %d cdesc = `%s'\n", seqNr++, cdesc);
-
- IF(":") { STS; ((void(*)(void))(fun))(); LTS_RET; };
-
- IF(":I") { int a1=PopTaggedInt();
- STS; ((void(*)(int))(fun))(a1); LTS_RET; };
- IF(":A") { void* a1=PopTaggedAddr();
- STS; ((void(*)(void*))(fun))(a1); LTS_RET; };
-
- IF("I:") { int r;
- STS; r= ((int(*)(void))(fun))(); LTS;
- PushTaggedInt(r); RET ;};
-
- IF(":II") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
- STS; ((void(*)(int,int))(fun))(a1,a2); LTS_RET; };
- IF(":AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt();
- STS; ((void(*)(void*,int))(fun))(a1,a2); LTS_RET; };
-
- IF("I:I") { int a1=PopTaggedInt(); int r;
- STS; r=((int(*)(int))(fun))(a1); LTS;
- PushTaggedInt(r); RET; };
- IF("A:I") { int a1=PopTaggedInt(); void* r;
- STS; r=((void*(*)(int))(fun))(a1); LTS;
- PushTaggedAddr(r); RET; };
- IF("A:A") { void* a1=PopTaggedAddr(); void* r;
- STS; r=((void*(*)(void*))(fun))(a1); LTS;
- PushTaggedAddr(r); RET; };
-
- IF("I:II") { int a1=PopTaggedInt(); int a2=PopTaggedInt(); int r;
- STS; r=((int(*)(int,int))(fun))(a1,a2); LTS;
- PushTaggedInt(r); RET; };
- IF("I:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); int r;
- STS; r=((int(*)(void*,int))(fun))(a1,a2); LTS;
- PushTaggedInt(r); RET; };
- IF("A:AI") { void* a1=PopTaggedAddr(); int a2=PopTaggedInt(); void* r;
- STS; r=((void*(*)(void*,int))(fun))(a1,a2); LTS;
- PushTaggedAddr(r); RET; };
-
- IF("I:III") { int a1=PopTaggedInt(); int a2=PopTaggedInt();
- int a3=PopTaggedInt(); int r;
- STS; r=((int(*)(int,int,int))(fun))(a1,a2,a3); LTS;
- PushTaggedInt(r); RET; };
-
- IF(":AIDCF") { void* a1 = PopTaggedAddr();
- int a2 = PopTaggedInt();
- double a3 = PopTaggedDouble();
- char a4 = PopTaggedChar();
- float a5 = PopTaggedFloat();
- STS;
- ((void(*)(void*,int,double,char,float))(fun))(a1,a2,a3,a4,a5);
- LTS_RET; };
-
-
-fprintf(stderr,"panic: ccall cdesc `%s' not implemented\n", cdesc );
- exit(1);
-
-
-fprintf(stderr,
- "ccall: arg_tys %s arg_size %d result_tys %s result_size %d\n",
- d->arg_tys, d->arg_size, d->result_tys, d->result_size );
-}
-
-#undef IF
-#undef STS
-#undef LTS
-#undef LTS_RET
-#undef RET
-
-#endif
-
-
+ if (d->num_results == 0) {
+ argd_vec[0] = 'i';
+ } else {
+ switch (d->result_tys[0]) {
+ case CHAR_REP: case INT_REP:
+ argd_vec[0] = 'i'; break;
+ case ADDR_REP:
+ argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
+ case FLOAT_REP:
+ argd_vec[0] = 'f'; break;
+ case DOUBLE_REP:
+ argd_vec[0] = 'F'; break;
+ default:
+ return 1;
+ }
+ }
+
+ PushPtr((StgPtr)(*bco));
+ SaveThreadState();
+
+ //fprintf(stderr, " argc=%d arg_vec=%p argd_vec=%p `%s' fun=%p\n",
+ // d->num_args, arg_vec, argd_vec, argd_vec, fun );
+
+ universal_call_c_x86_linux (
+ d->num_args, (void*)arg_vec, argd_vec, fun );
+ LoadThreadState();
+ *bco=(StgBCO*)PopPtr();
+
+ if (d->num_results > 0) {
+ p = (unsigned int*) &arg_vec[0];
+ switch (d->result_tys[0]) {
+ case CHAR_REP:
+ PushTaggedChar ( (StgChar) p[0]);
+ break;
+ case INT_REP:
+ PushTaggedInt ( ((StgInt*)p) [0] );
+ break;
+ case ADDR_REP:
+ if (sizeof(void*) == 4)
+ PushTaggedAddr ( ((StgAddr*)p) [0] );
+ else
+ PushTaggedAddr ( ((StgAddr*)p) [0] );
+ break;
+ case FLOAT_REP:
+ PushTaggedFloat ( ((StgFloat*)p) [0] );
+ break;
+ case DOUBLE_REP:
+ PushTaggedDouble ( ((StgDouble*)p) [0] );
+ break;
+ default:
+ return 1;
+ }
+ }
+ return 0;
+}
CFunDescriptor* mkDescriptor( char* as, char* rs )
{
/* ToDo: don't use malloc */
- CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
- assert(d);
- d->arg_tys = as;
- d->arg_size = argSize(as);
- d->result_tys = rs;
- d->result_size = argSize(rs);
+ CFunDescriptor *d = malloc(sizeof(CFunDescriptor));
+ if (d == NULL) return d;
+ d->arg_tys = as;
+ d->result_tys = rs;
+ d->num_args = strlen(as);
+ d->num_results = strlen(rs);
return d;
}
diff --git a/ghc/rts/ForeignCall.h b/ghc/rts/ForeignCall.h
index a36c0ca781b6..edbad251ac44 100644
--- a/ghc/rts/ForeignCall.h
+++ b/ghc/rts/ForeignCall.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: ForeignCall.h,v 1.4 1999/10/15 11:03:10 sewardj Exp $
+ * $Id: ForeignCall.h,v 1.5 1999/10/19 11:01:28 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -9,7 +9,8 @@
typedef int StablePtr;
-extern void ccall ( CFunDescriptor* descriptor, void (*fun)(void), StgBCO** bco );
-extern void hcall ( HFunDescriptor* descriptor, StablePtr fun, void* as, void* rs );
-
+extern int ccall ( CFunDescriptor* descriptor,
+ void (*fun)(void),
+ StgBCO** bco
+ );
diff --git a/ghc/rts/callfun.S b/ghc/rts/callfun.S
deleted file mode 100644
index 926015d8dad0..000000000000
--- a/ghc/rts/callfun.S
+++ /dev/null
@@ -1,162 +0,0 @@
-/* --------------------------------------------------------------------------
- * Assembly code to call C and Haskell functions
- *
- * Copyright (c) 1994-1998.
- *
- * $RCSfile: callfun.S,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/15 13:08:03 $
- * ------------------------------------------------------------------------*/
-
-#include "config.h"
-#include "options.h"
-
-#ifdef INTERPRETER
- .file "callfun.S"
-
-/* No longer needed - I finally figured out how to use __builtin_apply */
-#if 0 && i386_TARGET_ARCH
-
-#if 0
- void ccall( CFunDescriptor* d, void* fun )
- {
- void *rs=alloca(d->result_size);
- void *as=alloca(d->arg_size);
- unmarshall(d->arg_tys,as);
- rs = fun(as) ;
- marshall(d->result_tys,rs);
- }
-
- On entry, we have:
- ret = 0(%esp)
- d = 4(%esp)
- fun = 8(%esp)
-
- We assume that %ebp is a callee saves register
- and that %ecx is not used to return the result.
- If %ecx is a callee saves register (I think it is), the code
- can be optimised slightly - but I doubt its worth it.
-#endif
-.globl ccall
-ccall:
- pushl %ebp /* Save stack frame pointer */
- pushl %ecx /* Save callee-saves register */
-
- leal 8(%esp), %ebp /* ebp = frame pointer */
- movl 4(%ebp), %ecx /* ecx = d; */
- subl 12(%ecx), %esp /* rs = alloca(d->result_size); */
- subl 4(%ecx), %esp /* as = alloca(d->arg_size); */
-
- /* Marshall arguments off STG stack */
- pushl %esp
- pushl 0(%ecx)
- call unmarshall
- addl $8,%esp /* unmarshall(d->arg_tys,as); */
-
- /* Call function */
- movl 8(%ebp), %ecx
- call *%ecx /* rs = fun(as); */
-
- movl 4(%ebp), %ecx /* ecx = d; */
- addl 4(%ecx), %esp /* free(as) */
-
-
- /* Save result in rs - assume one or zero results for now */
- movl 8(%ecx), %ecx /* ecx = d->result_tys */
-
- cmpl $0,(%ecx) /* '\0' = no result */
- je .args_saved
-
- cmpl $70,(%ecx) /* 'F' = float result */
- jne .not_float
- flds (%esp) /* *rs = (float)f1 */
- jmp .args_saved
-
-.not_float:
- cmpl $68,(%ecx) /* 'D' = double result */
- jne .not_double
- fldl (%esp) /* *rs = (double)f1 */
- jmp .args_saved
-
-.not_double:
- movl %eax,(%esp) /* *rs = eax */
- /* fall through to .args_saved */
-
- /* Marshall results back onto STG stack */
-.args_saved:
- pushl %esp
- movl 4(%ebp), %ecx /* ecx = d; */
- pushl 8(%ecx)
- call marshall
- addl $8,%esp /* marshall(d->result_tys,rs); */
-
-
- movl 4(%ebp), %ecx /* ecx = d; */
- addl 12(%ecx), %esp /* free(rs) */
-
- popl %ecx /* Restore callee-saves register */
- popl %ebp /* restore stack frame pointer */
- ret
-
-#if 0
-/* When we call a Fun, we push the arguments on the stack, push a return
- * address and execute the instruction "call callFun_entry" which brings us
- * here with a return address on top of the stack, a pointer to
- * the FunDescriptor under that and the arguments under that.
- * We swap the top arguments so that when we jmp to callFunDesc, the stack
- * will look as though we executed "callFunDesc(fDescriptor,arg1,arg2,...)"
- */
-
- /* function call/return - standard entry point
- * we'll have one of these for each calling convention
- * all of which jump to callFunDesc when done
- */
- .globl callFun_entry
- .type callFun_entry,@function
-callFun_entry:
- popl %eax /* FunDescriptor */
- popl %edx /* Return address */
- pushl %eax
- pushl %edx
- jmp callFunDesc
-
- /* generic function call/return */
-callFunDesc:
- subl $8,%esp /* int/double res1; */
- pushl %esp /* &res1 */
- leal 20(%esp),%ecx /* &arg1 */
- pushl %ecx
- pushl 20(%esp) /* fun */
- call call_H /* returns result type in %eax */
- addl $20,%esp
-
- testl %eax,%eax /* '\0' = no result */
- jne .L1
- ret
-.L1:
- cmpl $70,%eax /* 'F' = float result */
- jne .L2
- flds -8(%esp)
- ret
-.L2:
- cmpl $68,%eax /* 'D' = double result */
- jne .L3
- fldl -8(%esp)
- ret
-.L3:
- movl -8(%esp),%eax /* return r */
- ret
-
-
-/* Some useful instructions - for later use:
- * fstpl (%ebx) store a double
- * fstps (%ebx) store a float
- *
- * fldl (%esi) load a double (ready for return)
- * flds (%esi) load a float (ready for return)
- */
-#endif /* 0 */
-
-#endif /* i386_TARGET_ARCH */
-
-#endif /* INTERPRETER */
\ No newline at end of file
diff --git a/ghc/rts/universal_call_c.S b/ghc/rts/universal_call_c.S
new file mode 100644
index 000000000000..19e425c3de46
--- /dev/null
+++ b/ghc/rts/universal_call_c.S
@@ -0,0 +1,137 @@
+
+/* --------------------------------------------------------------------------
+ * Assembly code to call C and Haskell functions
+ *
+ * Copyright (c) 1994-1999.
+ *
+ * $RCSfile: universal_call_c.S,v $
+ * $Revision: 1.1 $
+ * $Date: 1999/10/19 11:03:39 $
+ * ------------------------------------------------------------------------*/
+
+#include "config.h"
+#include "options.h"
+
+#ifdef INTERPRETER
+ .file "callfun.S"
+
+#if 0
+ Implement this. See comment in rts/ForeignCall.c for details.
+
+ void universal_call_c_ARCHNAME
+ ( int n_args,
+ void* args,
+ char* argstr,
+ void* fun )
+
+ You can get a crude approximation to the assembly you need by
+ compiling the following:
+
+ extern void pingi64 ( unsigned long long int );
+ extern void pingi32 ( unsigned int );
+ extern void pingf32 ( float f );
+ extern void pingf64 ( double d );
+
+ void universal_call_c_ARCHNAME ( int n_args,
+ void* args,
+ char* argstr,
+ void* fun )
+ {
+ int i;
+ for (i = 1; i <= n_args; i++) {
+ if (argstr[i] == 'i') {
+ unsigned int u1 = ((unsigned int*)args)[2*i];
+ pingi32(u1);
+ } else
+ if (argstr[i] == 'I') {
+ unsigned long long int uu1 = ((unsigned long long int*)args)[i];
+ pingi64(uu1);
+ } else
+ if (argstr[i] == 'f') {
+ float u1 = ((float*)args)[2*i];
+ pingf32(u1);
+ } else
+ if (argstr[i] == 'F') {
+ double u1 = ((double*)args)[i];
+ pingf64(u1);
+ }
+ }
+
+ if (argstr[0] == 'f' || argstr[0] == 'F') {
+ pingi32(987654321);
+ } else {
+ pingi32(123456789);
+ }
+ }
+#endif
+
+#if i386_TARGET_ARCH
+.globl universal_call_c_x86_linux
+universal_call_c_x86_linux:
+ pushl %ebp
+ movl %esp,%ebp
+ pushl %edi
+ pushl %esi
+ pushl %ebx
+ movl 12(%ebp),%esi
+ movl 16(%ebp),%edi
+ movl 8(%ebp),%ebx
+ testl %ebx,%ebx
+ jle docall
+
+looptop:
+ cmpb $105,(%ebx,%edi) # 'i'
+ jne .L6
+ pushl (%esi,%ebx,8)
+ jmp looptest
+.L6:
+ cmpb $73,(%ebx,%edi) # 'I'
+ jne .L8
+ pushl 4(%esi,%ebx,8)
+ pushl (%esi,%ebx,8)
+ jmp looptest
+.L8:
+ cmpb $102,(%ebx,%edi) # 'f'
+ jne .L10
+ movl (%esi,%ebx,8),%eax
+ pushl %eax
+ jmp looptest
+.L10:
+ cmpb $70,(%ebx,%edi) # 'F'
+ jne looptest
+ movl 4(%esi,%ebx,8),%eax
+ movl (%esi,%ebx,8),%edx
+ pushl %eax
+ pushl %edx
+looptest:
+ decl %ebx
+ testl %ebx,%ebx
+ jg looptop
+
+docall:
+ call *20(%ebp)
+
+ cmpb $102,(%edi) # 'f'
+ je float32
+ cmpb $70,(%edi) # 'F'
+ je float64
+iorI:
+ movl %eax,0(%esi)
+ movl %edx,4(%esi)
+ jmp bye
+float32:
+ fstps 0(%esi)
+ jmp bye
+float64:
+ fstpl 0(%esi)
+ jmp bye
+bye:
+ leal -12(%ebp),%esp
+ popl %ebx
+ popl %esi
+ popl %edi
+ leave
+ ret
+#endif /* i386_TARGET_ARCH */
+
+#endif /* INTERPRETER */
\ No newline at end of file
--
GitLab