Commit 81d1ac85 authored by sewardj's avatar sewardj
Browse files

[project @ 1999-10-22 09:59:28 by sewardj]

Cleanup of the foreign import code.  Also allow StablePtrs
to be passed back and forth.
parent e92dc7a1
......@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
* $Revision: 1.19 $
* $Date: 1999/10/19 11:01:26 $
* $Revision: 1.20 $
* $Date: 1999/10/22 09:59:28 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
......@@ -1547,7 +1547,7 @@ static inline void PushTaggedRealWorld( void )
{ PushTag(REALWORLD_TAG); }
inline void PushTaggedInt ( StgInt x )
{ Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
static inline void PushTaggedWord ( StgWord x )
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); }
......@@ -1557,7 +1557,7 @@ static inline void PushTaggedWord ( StgWord x )
{ Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
inline void PushTaggedDouble ( StgDouble x )
{ Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
static inline void PushTaggedStablePtr ( StgStablePtr x )
inline void PushTaggedStablePtr ( StgStablePtr x )
{ Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
static inline void PushTaggedBool ( int x )
{ PushTaggedInt(x); }
......@@ -1569,7 +1569,7 @@ static inline void PopTaggedRealWorld ( void )
inline StgInt PopTaggedInt ( void )
{ StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp);
Sp += sizeofW(StgInt); return r;}
static inline StgWord PopTaggedWord ( void )
inline StgWord PopTaggedWord ( void )
{ StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp);
Sp += sizeofW(StgWord); return r;}
inline StgAddr PopTaggedAddr ( void )
......@@ -1584,7 +1584,7 @@ static inline StgWord PopTaggedWord ( void )
inline StgDouble PopTaggedDouble ( void )
{ StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp);
Sp += sizeofW(StgDouble); return r;}
static inline StgStablePtr PopTaggedStablePtr ( void )
inline StgStablePtr PopTaggedStablePtr ( void )
{ StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp);
Sp += sizeofW(StgStablePtr); return r;}
......
/* -----------------------------------------------------------------------------
* $Id: ForeignCall.c,v 1.7 1999/10/19 23:52:02 andy Exp $
* $Id: ForeignCall.c,v 1.8 1999/10/22 09:59:34 sewardj Exp $
*
* (c) The GHC Team 1994-1999.
*
......@@ -96,22 +96,29 @@
*/
/* 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 PushTaggedDouble ( StgDouble );
extern void PushTaggedFloat ( StgFloat );
extern void PushTaggedChar ( StgChar );
extern void PushTaggedAddr ( StgAddr );
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 );
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.
......@@ -120,13 +127,13 @@ extern StgPtr PopPtr ( void );
* even if univeral_call_c_<os/specific> is not ported.
* ------------------------------------------------------------------------*/
void universal_call_c_x86_generic
void universal_call_c_generic
( int n_args,
void* args,
char* argstr,
void* fun )
{
unsigned int *p = (unsigned int*) args;
unsigned int *p = (unsigned int*) args;
#define ARG(n) (p[n*2])
#define CMP(str) ((n_args + 1 == strlen(str)) && \
......@@ -167,6 +174,9 @@ void universal_call_c_x86_generic
* 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.
* 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
* ------------------------------------------------------------------------*/
int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
......@@ -175,9 +185,11 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
char argd_vec[31];
unsigned int* p;
int i;
unsigned long ul;
if (sizeof(int) != 4 || sizeof(double) != 8 || sizeof(float) != 4
|| (sizeof(void*) != 4 && sizeof(void*) != 8))
|| (sizeof(void*) != 4 && sizeof(void*) != 8)
|| (sizeof(unsigned long) != sizeof(void*)))
return 2;
if (d->num_args > 30 || d->num_results > 1)
......@@ -189,29 +201,34 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
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();
case INT_REP:
ul = (unsigned long)PopTaggedInt();
goto common_int32_or_64;
case WORD_REP:
ul = (unsigned long)PopTaggedWord();
goto common_int32_or_64;
case ADDR_REP:
ul = (unsigned long)(PopTaggedAddr());
goto common_int32_or_64;
case STABLE_REP:
ul = (unsigned long)PopTaggedStablePtr();
common_int32_or_64:
if (sizeof(void*) == 4) {
*(void**)p = a; p++; *p++ = 0;
*(unsigned long *)p = ul; p++; *p++ = 0;
argd_vec[i+1] = 'i';
} else {
*(void**)p = a;
*(unsigned long *)p = ul;
p += 2;
argd_vec[i+1] = 'I';
}
break;
case CHAR_REP: {
int j = (int)PopTaggedChar();
*p++ = j; *p++ = 0;
argd_vec[i+1] = 'i';
break;
}
case FLOAT_REP: {
float f = PopTaggedFloat();
......@@ -234,10 +251,10 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
argd_vec[0] = 'i';
} else {
switch (d->result_tys[0]) {
case CHAR_REP: case INT_REP:
argd_vec[0] = 'i'; break;
case ADDR_REP:
case INT_REP: case WORD_REP: case ADDR_REP: case STABLE_REP:
argd_vec[0] = (sizeof(void*)==4) ? 'i' : 'I'; break;
case CHAR_REP:
argd_vec[0] = 'i'; break;
case FLOAT_REP:
argd_vec[0] = 'f'; break;
case DOUBLE_REP:
......@@ -257,26 +274,34 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
universal_call_c_x86_linux (
d->num_args, (void*)arg_vec, argd_vec, fun );
#else
universal_call_c_x86_generic (
universal_call_c_generic (
d->num_args, (void*)arg_vec, argd_vec, fun );
#endif
LoadThreadState();
*bco=(StgBCO*)PopPtr();
/* INT, WORD, ADDR, STABLE don't need to do a word-size check
since the result is in the bytes starting at p regardless. */
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 WORD_REP:
PushTaggedWord ( ((StgWord*)p) [0] );
break;
case ADDR_REP:
if (sizeof(void*) == 4)
PushTaggedAddr ( ((StgAddr*)p) [0] );
else
PushTaggedAddr ( ((StgAddr*)p) [0] );
PushTaggedAddr ( ((StgAddr*)p) [0] );
break;
case STABLE_REP:
PushTaggedStablePtr ( ((StgStablePtr*)p) [0] );
break;
case CHAR_REP:
PushTaggedChar ( (StgChar) p[0]);
break;
case FLOAT_REP:
PushTaggedFloat ( ((StgFloat*)p) [0] );
......@@ -284,6 +309,7 @@ int ccall ( CFunDescriptor* d, void (*fun)(void), StgBCO** bco )
case DOUBLE_REP:
PushTaggedDouble ( ((StgDouble*)p) [0] );
break;
default:
return 1;
}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment