Skip to content

GitLab

Commit dee29ec1 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-10-22 15:58:21 by sewardj] 

* Completion of foreign import and foreign export for x86 ccall
  convention.  f-i's and f-x's can pass and return
  Char Int Word Addr StablePtr Float and Double.

* Significant cleanups and infrastructure improvements.
  Characterise functions by (instruction set, calling convention)
  pair where necessary, since that's what counts.

  Moved foreign export code into rts/ForeignCall.c.
  Should now be in a good position to implement x86 stdcall
  convention.
parent c5ea45c3
Hide whitespace changes
Inline Side-by-side
ghc/rts/Evaluator.c
View file @ dee29ec1
......@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
* $Revision: 1.20 $
* $Date: 1999/10/22 09:59:28 $
* $Revision: 1.21 $
* $Date: 1999/10/22 15:58:22 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
......@@ -323,8 +323,6 @@ static inline void PushTaggedInteger ( mpz_ptr );
static inline StgPtr grabHpUpd( nat size );
static inline StgPtr grabHpNonUpd( nat size );
static StgClosure* raiseAnError ( StgClosure* errObj );
static StgAddr createAdjThunkARCH ( StgStablePtr stableptr,
StgAddr typestr );
static int enterCountI = 0;
......@@ -462,7 +460,6 @@ StgThreadReturnCode enter( StgClosure* obj0 )
register StgPtr xSpLim; /* local state -- stack lim pointer */
register StgClosure* obj; /* object currently under evaluation */
char eCount; /* enter counter, for context switching */
StgBCO** bco_SAVED;
#ifdef DEBUG
/* use the t values to check that Su/Sp/SpLim do not change unexpectedly */
......@@ -545,8 +542,6 @@ StgThreadReturnCode enter( StgClosure* obj0 )
register StgBCO* bco = (StgBCO*)obj;
StgWord wantToGC;
bco_SAVED = bco;
/* Don't need to SSS ... LLL around doYouWantToGC */
wantToGC = doYouWantToGC();
if (wantToGC) {
......@@ -1683,7 +1678,7 @@ static inline void PushCatchFrame( StgClosure* handler )
/* ToDo: stack check! */
Sp -= sizeofW(StgCatchFrame);
fp = stgCast(StgCatchFrame*,Sp);
SET_HDR(fp,&catch_frame_info,CCCS);
SET_HDR(fp,(StgInfoTable*)&catch_frame_info,CCCS);
fp->handler = handler;
fp->link = Su;
Su = stgCast(StgUpdateFrame*,fp);
......@@ -1703,7 +1698,7 @@ static inline void PushSeqFrame( void )
/* ToDo: stack check! */
Sp -= sizeofW(StgSeqFrame);
fp = stgCast(StgSeqFrame*,Sp);
SET_HDR(fp,&seq_frame_info,CCCS);
SET_HDR(fp,(StgInfoTable*)&seq_frame_info,CCCS);
fp->link = Su;
Su = stgCast(StgUpdateFrame*,fp);
}
......@@ -2142,7 +2137,7 @@ void SloppifyIntegerEnd ( StgPtr arr0 )
do_renormalise(b);
ASSERT(is_sane(b));
arr->words -= nwunused;
slop = &(arr->payload[arr->words]);
slop = (StgArrWords*)&(arr->payload[arr->words]);
SET_HDR(slop,&ARR_WORDS_info,CCCS);
slop->words = nwunused - sizeofW(StgArrWords);
ASSERT( &(slop->payload[slop->words]) ==
......@@ -2888,7 +2883,7 @@ static void* enterBCO_primop2 ( int primop2code,
{
StgStablePtr stableptr = PopTaggedStablePtr();
StgAddr typestr = PopTaggedAddr();
StgAddr adj_thunk = createAdjThunkARCH(stableptr,typestr);
StgAddr adj_thunk = createAdjThunk(stableptr,typestr);
PushTaggedAddr(adj_thunk);
break;
}
......@@ -3403,158 +3398,4 @@ void B__decodeFloat (B* man, I_* exp, StgFloat flt)
#endif /* STANDALONE_INTEGER */
/* -----------------------------------------------------------------------------
* Support for foreign export dynamic.
* ---------------------------------------------------------------------------*/
static
int unpackArgsAndCallHaskell_x86 ( StgStablePtr stableptr,
char* tydesc, char* args)
{
HaskellObj node;
HaskellObj nodeOut;
SchedulerStatus sstat;
char* resp = tydesc;
char* argp = tydesc;
/*
fprintf ( stderr,
"unpackArgsAndCallHaskell_x86: args=0x%x tydesc=%s stableptr=0x%x\n",
(unsigned int)args, tydesc, stableptr );
*/
node = deRefStablePtr(stableptr);
if (*argp != ':') argp++;
ASSERT( *argp == ':' );
argp++;
while (*argp) {
switch (*argp) {
case CHAR_REP:
node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
/* fprintf(stderr, "char `%c' ", *(char*)args ); */
args += 4;
break;
case INT_REP:
node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
/* fprintf(stderr, "int %d ", *(int*)args ); */
args += 4;
break;
case FLOAT_REP:
node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
/* fprintf(stderr, "float %f ", *(float*)args ); */
args += 4;
break;
case DOUBLE_REP:
node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
/* fprintf(stderr, "double %f ", *(double*)args ); */
args += 8;
break;
case WORD_REP:
case ADDR_REP:
default:
internal(
"unpackArgsAndCallHaskell_x86: unexpected arg type rep");
}
argp++;
}
fprintf ( stderr, "\n" );
node = rts_apply (
asmClosureOfObject(getHugs_AsmObject_for("primRunST")),
node );
sstat = rts_eval ( node, &nodeOut );
if (sstat != Success)
internal ("unpackArgsAndCallHaskell_x86: evalIO failed");
switch (*resp) {
case ':': return 0;
case CHAR_REP: return rts_getChar(nodeOut);
case INT_REP: return rts_getInt(nodeOut);
//case FLOAT_REP: return rts_getFloat(nodeOut);
//case DOUBLE_REP: return rts_getDouble(nodeOut);
case WORD_REP:
case ADDR_REP:
default:
internal(
"unpackArgsAndCallHaskell_x86: unexpected res type rep");
}
}
static
StgAddr createAdjThunk_x86 ( StgStablePtr stableptr,
StgAddr typestr )
{
unsigned char* codeblock;
unsigned char* cp;
unsigned int ts = (unsigned int)typestr;
unsigned int sp = (unsigned int)stableptr;
unsigned int ch = (unsigned int)&unpackArgsAndCallHaskell_x86;
/* fprintf ( stderr, "createAdjThunk_x86: %s 0x%x\n", (char*)typestr, sp ); */
codeblock = malloc ( 1 + 0x22 );
if (!codeblock) {
fprintf ( stderr,
"createAdjThunk_x86 (foreign export dynamic):\n"
"\tfatal: can't alloc mem\n" );
exit(1);
}
cp = codeblock;
/* Generate the following:
9 0000 53 pushl %ebx
10 0001 51 pushl %ecx
11 0002 56 pushl %esi
12 0003 57 pushl %edi
13 0004 55 pushl %ebp
14 0005 89E0 movl %esp,%eax # sp -> eax
15 0007 83C018 addl $24,%eax # move eax back over 5 saved regs + retaddr
16 000a 50 pushl %eax # push arg-block addr
17 000b 6844332211 pushl $0x11223344 # push addr of type descr string
18 0010 6877665544 pushl $0x44556677 # push stableptr to closure
19 0015 E8BBAA9988 call 0x8899aabb # SEE COMMENT BELOW
20 001a 83C40C addl $12,%esp # pop 3 args
21 001d 5D popl %ebp
22 001e 5F popl %edi
23 001f 5E popl %esi
24 0020 59 popl %ecx
25 0021 5B popl %ebx
26 0022 C3 ret
*/
*cp++ = 0x53;
*cp++ = 0x51;
*cp++ = 0x56;
*cp++ = 0x57;
*cp++ = 0x55;
*cp++ = 0x89; *cp++ = 0xE0;
*cp++ = 0x83; *cp++ = 0xC0; *cp++ = 0x18;
*cp++ = 0x50;
*cp++ = 0x68; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;ts>>=8; *cp++=ts;
*cp++ = 0x68; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;sp>>=8; *cp++=sp;
/* call address needs to be: displacement relative to next insn */
ch = ch - ( ((unsigned int)cp) + 5);
*cp++ = 0xE8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;ch>>=8; *cp++=ch;
*cp++ = 0x83; *cp++ = 0xC4; *cp++ = 0x0C;
*cp++ = 0x5D;
*cp++ = 0x5F;
*cp++ = 0x5E;
*cp++ = 0x59;
*cp++ = 0x5B;
*cp++ = 0xC3;
return codeblock;
}
static
StgAddr createAdjThunkARCH ( StgStablePtr stableptr,
StgAddr typestr )
{
return createAdjThunk_x86 ( stableptr, typestr );
}
#endif /* INTERPRETER */
ghc/rts/Evaluator.h
View file @ dee29ec1
/* -----------------------------------------------------------------------------
* $Id: Evaluator.h,v 1.4 1999/02/05 16:02:40 simonm Exp $
* $Id: Evaluator.h,v 1.5 1999/10/22 15:58:25 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -32,3 +32,22 @@ extern nat marshall ( char arg_ty, void* arg );
extern nat unmarshall ( char res_ty, void* res );
extern nat argSize ( const char* ks );
extern StgInt PopTaggedInt ( void ) ;
extern StgWord PopTaggedWord ( void ) ;
extern StgAddr PopTaggedAddr ( void ) ;
extern StgStablePtr PopTaggedStablePtr ( void ) ;
extern StgChar PopTaggedChar ( void ) ;
extern StgFloat PopTaggedFloat ( void ) ;
extern StgDouble PopTaggedDouble ( void ) ;
extern void PushTaggedInt ( StgInt );
extern void PushTaggedWord ( StgWord );
extern void PushTaggedAddr ( StgAddr );
extern void PushTaggedStablePtr ( StgStablePtr );
extern void PushTaggedChar ( StgChar );
extern void PushTaggedFloat ( StgFloat );
extern void PushTaggedDouble ( StgDouble );
extern void PushPtr ( StgPtr );
extern StgPtr PopPtr ( void );
ghc/rts/ForeignCall.c
View file @ dee29ec1
/* -----------------------------------------------------------------------------
* $Id: ForeignCall.c,v 1.8 1999/10/22 09:59:34 sewardj Exp $
* $Id: ForeignCall.c,v 1.9 1999/10/22 15:58:21 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
* Foreign Function calls
*
* Implementation of foreign import and foreign export.
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#ifdef INTERPRETER
#include "Assembler.h" /* for CFun stuff */
#include "RtsUtils.h" /* barf :-) */
#include "Assembler.h" /* for CFun stuff */
#include "Evaluator.h"
#include "ForeignCall.h"
/* Exports of this file:
mkDescriptor
ccall
createAdjThunk
Everything else is local, I think.
*/
/* ----------------------------------------------------------------------
* Some misc-ery to begin with.
* --------------------------------------------------------------------*/
CFunDescriptor* mkDescriptor( char* as, char* rs )
{
/* ToDo: don't use malloc */
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;
}
/* ----------------------------------------------------------------------
* Part the first: CALLING OUT -- foreign import
* --------------------------------------------------------------------*/
/* SOME NOTES ABOUT PARAMETERISATION.
These pertain equally to foreign import and foreign export.
Implementations for calling in and out are very architecture
dependent. After some consideration, it appears that the two
important factors are the instruction set, and the calling
convention used. Factors like the OS and compiler are not
directly relevant.
So: routines which are architecture dependent are have
_instructionsetname_callingconventionname attached to the
the base name. For example, code specific to the ccall
convention on x86 would be suffixed _x86_ccall.
A third possible dimension of parameterisation relates to the
split between callee and caller saves registers. For example,
x86_ccall code needs to assume a split, and different splits
using ccall on x86 need different code. However, that does not
yet seem an issue, so it is ignored here.
*/
/* --------------------------------------------------------------------------
/* ------------------------------------------------------------------
* Calling out to C: a simple, universal calling API
* ------------------------------------------------------------------------*/
* ----------------------------------------------------------------*/
/* The universal call-C API supplies a single function:
......@@ -93,41 +143,29 @@
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 StgWord PopTaggedWord ( void ) ;
extern StgAddr PopTaggedAddr ( void ) ;
extern StgStablePtr PopTaggedStablePtr ( void ) ;
extern StgChar PopTaggedChar ( void ) ;
extern StgFloat PopTaggedFloat ( void ) ;
extern StgDouble PopTaggedDouble ( void ) ;
These architecture-dependent assembly routines are in
rts/universal_call_c.S.
*/
extern void PushTaggedInt ( StgInt );
extern void PushTaggedWord ( StgWord );
extern void PushTaggedAddr ( StgAddr );
extern void PushTaggedStablePtr ( StgStablePtr );
extern void PushTaggedChar ( StgChar );
extern void PushTaggedFloat ( StgFloat );
extern void PushTaggedDouble ( StgDouble );
extern void PushPtr ( StgPtr );
extern StgPtr PopPtr ( void );
/* ----------------------------------------------------------------*
* External refs for the assembly routines.
* ----------------------------------------------------------------*/
extern void universal_call_c_x86_ccall ( int, void*, char*, void* );
static void universal_call_c_generic ( int, void*, char*, void* );
extern void universal_call_c_x86_linux ( int, void*, char*, void* );
void universal_call_c_generic ( int, void*, char*, void* );
/* --------------------------------------------------------------------------
/* ----------------------------------------------------------------*
* This is a generic version of universal call that
* only works for specific argument patterns.
*
* It allows ports to work on the Hugs Prelude immeduately,
* even if univeral_call_c_<os/specific> is not ported.
* ------------------------------------------------------------------------*/
* It allows ports to work on the Hugs Prelude immediately,
* even if univeral_call_c_arch_callingconvention is not available.
* ----------------------------------------------------------------*/
void universal_call_c_generic
static void universal_call_c_generic
( int n_args,
void* args,
char* argstr,
......@@ -165,10 +203,13 @@ void universal_call_c_generic
printf("' [%d arg(s)]\n",n_args);
assert(0);
}
#undef CALL
#undef CMP
#undef ARG
}
/* --------------------------------------------------------------------------
/* ----------------------------------------------------------------*
* 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
......@@ -177,7 +218,8 @@ void universal_call_c_generic
* Assumes an LP64 programming model for 64 bit:
* sizeof(long)==sizeof(void*)==64 on a 64 bit platform
* sizeof(int)==32 on a 64 bit platform
* ------------------------------------------------------------------------*/
* This code attempts to be architecture neutral (viz, generic).
* ----------------------------------------------------------------*/
int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
{
......@@ -195,9 +237,6 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
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]) {
......@@ -267,11 +306,8 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
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 );
#if 1
universal_call_c_x86_linux (
universal_call_c_x86_ccall (
d->num_args, (void*)arg_vec, argd_vec, fun );
#else
universal_call_c_generic (
......@@ -320,17 +356,244 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
CFunDescriptor* mkDescriptor( char* as, char* rs )
{
/* ToDo: don't use malloc */
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;
/* ----------------------------------------------------------------------
* Part the second: CALLING IN -- foreign export {dynamic}
* --------------------------------------------------------------------*/
/* Make it possible for the evaluator to get hold of bytecode
for a given function by name. Useful but a hack. Sigh.
*/
extern void* getHugs_AsmObject_for ( char* s );
/* ----------------------------------------------------------------*
* The implementation for x86_ccall.
* ----------------------------------------------------------------*/
static
HaskellObj
unpackArgsAndCallHaskell_x86_ccall_wrk ( StgStablePtr stableptr,
char* tydesc, char* args)
{
/* Copy args out of the C stack frame in an architecture
dependent fashion, under the direction of the type description
string tydesc. Dereference the stable pointer, giving the
Haskell function to call. Build an application of this to
the arguments, and finally wrap primRunST round the whole
thing, since we know it returns an IO type. Then evaluate
the whole, which leaves nodeOut as the evaluated 'a', where
the type of the function called is .... -> IO a.
We can't immediately unpack the results and return, since
int results need to return in a different register (%eax and
possibly %edx) from float things (%st(0)). So return nodeOut
to the relevant wrapper function, which knows enough about
the return type to do the Right Thing.
There's no getting round it: this is most heinous hack.
*/
HaskellObj node;
HaskellObj nodeOut;
SchedulerStatus sstat;
char* resp = tydesc;
char* argp = tydesc;
node = (HaskellObj)deRefStablePtr(stableptr);
if (*argp != ':') argp++;
ASSERT( *argp == ':' );
argp++;
while (*argp) {
switch (*argp) {
case CHAR_REP:
node = rts_apply ( node, rts_mkChar ( *(char*)args ) );
args += 4;
break;
case INT_REP:
node = rts_apply ( node, rts_mkInt ( *(int*)args ) );
args += 4;
break;
case WORD_REP:
node = rts_apply ( node, rts_mkWord ( *(unsigned int*)args ) );
args += 4;
break;
case ADDR_REP:
node = rts_apply ( node, rts_mkAddr ( *(void**)args ) );
args += 4;
break;
case STABLE_REP:
node = rts_apply ( node, rts_mkStablePtr ( *(int*)args ) );
args += 4;
break;
case FLOAT_REP:
node = rts_apply ( node, rts_mkFloat ( *(float*)args ) );
args += 4;
break;
case DOUBLE_REP:
node = rts_apply ( node, rts_mkDouble ( *(double*)args ) );
args += 8;
break;
default:
barf(
"unpackArgsAndCallHaskell_x86_ccall: unexpected arg type rep");
}
argp++;
}
node = rts_apply (
asmClosureOfObject(getHugs_AsmObject_for("primRunST")),
node );
sstat = rts_eval ( node, &nodeOut );
if (sstat != Success)
barf ("unpackArgsAndCallHaskell_x86_ccall: eval failed");
return nodeOut;
}
static
double
unpackArgsAndCallHaskell_x86_ccall_DOUBLE ( StgStablePtr stableptr,
char* tydesc, char* args)
{
HaskellObj nodeOut
= unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
/* Return a double. This return will go into %st(0), which
is unmodified by the adjustor thunk.
*/
ASSERT(tydesc[0] == DOUBLE_REP);
return rts_getDouble(nodeOut);
}
static
float
unpackArgsAndCallHaskell_x86_ccall_FLOAT ( StgStablePtr stableptr,
char* tydesc, char* args)
{
HaskellObj nodeOut
= unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
/* Probably could be merged with the double case, since %st(0) is
still the return register.
*/
ASSERT(tydesc[0] == FLOAT_REP);
return rts_getFloat(nodeOut);
}
static
unsigned long
unpackArgsAndCallHaskell_x86_ccall_INTISH ( StgStablePtr stableptr,
char* tydesc, char* args)
{
HaskellObj nodeOut
= unpackArgsAndCallHaskell_x86_ccall_wrk ( stableptr, tydesc, args );
/* A complete hack. We know that all these returns will be
put into %eax (and %edx, if it is a 64-bit return), and
the adjustor thunk will then itself return to the original
(C-world) caller without modifying %eax or %edx, so the
original caller will be a Happy Bunny.
*/
switch (*tydesc) {
case ':': return 0;
case CHAR_REP: return (unsigned long)rts_getChar(nodeOut);
case INT_REP: return (unsigned long)rts_getInt(nodeOut);
case WORD_REP: return (unsigned long)rts_getWord(nodeOut);
case ADDR_REP: return (unsigned long)rts_getAddr(nodeOut);
case STABLE_REP: return (unsigned long)rts_getStablePtr(nodeOut);
default:
barf(
"unpackArgsAndCallHaskell_x86_ccall: unexpected res type rep");
}
}
static
StgAddr createAdjThunk_x86_ccall ( StgStablePtr stableptr,
StgAddr typestr )
{
unsigned char* codeblock;
unsigned char* cp;
unsigned int ts = (unsigned int)typestr;
unsigned int sp = (unsigned int)stableptr;
unsigned int ch;
if (((char*)typestr)[0] == DOUBLE_REP)
ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_DOUBLE;
else if (((char*)typestr)[0] == FLOAT_REP)
ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_FLOAT;
else
ch = (unsigned int)&unpackArgsAndCallHaskell_x86_ccall_INTISH;