working on the FFI

cvs
Slava Pestov 2004-09-19 21:39:28 +00:00
parent bf023df887
commit c889ad3f79
28 changed files with 301 additions and 98 deletions

View File

@ -1,11 +1,11 @@
CC = gcc
# On FreeBSD, to use SDL and other libc_r libs:
CFLAGS = -Os -g -Wall -pthread
CFLAGS = -Os -g -Wall -pthread -export-dynamic
# On PowerPC G5:
# CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3
# On Pentium 4:
# CFLAGS = -march=pentium4 -ffast-math -O3 -fomit-frame-pointer
# CFLAGS = -march=pentium4 -ffast-math -O3 -fomit-frame-pointer -export-dynamic
# Add -fomit-frame-pointer if you don't care about debugging
# CFLAGS = -Os -g -Wall

View File

@ -1,3 +1,6 @@
FFI:
- is signed -vs- unsigned pointers an issue?
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)

View File

@ -45,6 +45,13 @@ DEFER: dlopen
DEFER: dlsym
DEFER: dlsym-self
DEFER: dlclose
DEFER: <alien>
DEFER: alien-cell
DEFER: set-alien-cell
DEFER: alien-4
DEFER: set-alien-4
DEFER: alien-1
DEFER: set-alien-1
IN: compiler
DEFER: set-compiled-byte
@ -347,10 +354,10 @@ IN: image
dump
cwd
cd
set-compiled-byte
set-compiled-cell
compiled-offset
set-compiled-offset
set-compiled-cell
set-compiled-byte
literal-top
set-literal-top
address-of
@ -358,6 +365,13 @@ IN: image
dlsym
dlsym-self
dlclose
<alien>
alien-cell
set-alien-cell
alien-4
set-alien-4
alien-1
set-alien-1
] [
swap succ tuck primitive,
] each drop ;

View File

@ -74,8 +74,12 @@ USE: vectors
[ >fixnum ]
[ >fixnum ]
[ drop 0 ]
[ drop 0 ]
} generic ;
IN: math DEFER: number= ( defined later... )
IN: kernel
: equal? ( obj obj -- ? )
#! Use = instead.
{
@ -95,6 +99,7 @@ USE: vectors
[ number= ]
[ number= ]
[ eq? ]
[ eq? ]
} generic ;
: = ( obj obj -- ? )
@ -113,31 +118,6 @@ USE: vectors
[ drop t ] [ ( return the object ) ]
] cond ;
: type-name ( n -- str )
[
[ 0 | "fixnum" ]
[ 1 | "word" ]
[ 2 | "cons" ]
[ 4 | "ratio" ]
[ 5 | "complex" ]
[ 6 | "f" ]
[ 7 | "t" ]
[ 9 | "vector" ]
[ 10 | "string" ]
[ 11 | "sbuf" ]
[ 12 | "port" ]
[ 13 | "bignum" ]
[ 14 | "float" ]
[ 15 | "dll" ]
! These values are only used by the kernel for error
! reporting.
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc ;
: java? f ;
: native? t ;

View File

@ -106,6 +106,7 @@ USE: words
bignum=
float=
(not-=)
(not-=)
} 2generic ;
: + ( x y -- x+y )
@ -126,6 +127,7 @@ USE: words
bignum+
float+
no-method
no-method
} 2generic ;
: - ( x y -- x-y )
@ -146,6 +148,7 @@ USE: words
bignum-
float-
no-method
no-method
} 2generic ;
: * ( x y -- x*y )
@ -166,6 +169,7 @@ USE: words
bignum*
float*
no-method
no-method
} 2generic ;
: / ( x y -- x/y )
@ -186,6 +190,7 @@ USE: words
ratio
float/f
no-method
no-method
} 2generic ;
: /i ( x y -- x/y )
@ -206,6 +211,7 @@ USE: words
bignum/i
no-method
no-method
no-method
} 2generic ;
: /f ( x y -- x/y )
@ -226,6 +232,7 @@ USE: words
bignum/f
float/f
no-method
no-method
} 2generic ;
: mod ( x y -- x%y )
@ -246,6 +253,7 @@ USE: words
bignum-mod
no-method
no-method
no-method
} 2generic ;
: /mod ( x y -- x/y x%y )
@ -266,6 +274,7 @@ USE: words
bignum/mod
no-method
no-method
no-method
} 2generic ;
: bitand ( x y -- x&y )
@ -286,6 +295,7 @@ USE: words
bignum-bitand
no-method
no-method
no-method
} 2generic ;
: bitor ( x y -- x|y )
@ -306,6 +316,7 @@ USE: words
bignum-bitor
no-method
no-method
no-method
} 2generic ;
: bitxor ( x y -- x^y )
@ -326,6 +337,7 @@ USE: words
bignum-bitxor
no-method
no-method
no-method
} 2generic ;
: bitnot ( x -- ~x )
@ -346,6 +358,7 @@ USE: words
[ bignum-bitnot ]
[ no-method ]
[ no-method ]
[ no-method ]
} generic ;
: shift ( x n -- x<<n )
@ -366,6 +379,7 @@ USE: words
bignum-shift
no-method
no-method
no-method
} 2generic ;
: < ( x y -- ? )
@ -386,6 +400,7 @@ USE: words
bignum<
float<
no-method
no-method
} 2generic ;
: <= ( x y -- ? )
@ -406,6 +421,7 @@ USE: words
bignum<=
float<=
no-method
no-method
} 2generic ;
: > ( x y -- ? )
@ -426,6 +442,7 @@ USE: words
bignum>
float>
no-method
no-method
} 2generic ;
: >= ( x y -- ? )
@ -446,4 +463,5 @@ USE: words
bignum>=
float>=
no-method
no-method
} 2generic ;

View File

@ -212,10 +212,10 @@ USE: words
[ dump | " obj -- " ]
[ cwd | " -- dir " ]
[ cd | " dir -- " ]
[ set-compiled-byte | " n ptr -- " ]
[ set-compiled-cell | " n ptr -- " ]
[ compiled-offset | " -- ptr " ]
[ set-compiled-offset | " ptr -- " ]
[ set-compiled-cell | " n ptr -- " ]
[ set-compiled-byte | " n ptr -- " ]
[ literal-top | " -- ptr " ]
[ set-literal-top | " ptr -- " ]
[ address-of | " obj -- ptr " ]
@ -223,6 +223,13 @@ USE: words
[ dlsym | " name dll -- ptr " ]
[ dlsym-self | " name -- ptr " ]
[ dlclose | " dll -- " ]
[ <alien> | " ptr len -- alien " ]
[ alien-cell | " alien off -- n " ]
[ set-alien-cell | " n alien off -- " ]
[ alien-4 | " alien off -- n " ]
[ set-alien-4 | " n alien off -- " ]
[ alien-1 | " alien off -- n " ]
[ set-alien-1 | " n alien off -- " ]
] [
unswons "stack-effect" swap set-word-property
] each

View File

@ -39,3 +39,32 @@ IN: io-internals : port? ( obj -- ? ) type-of 12 eq? ;
IN: math : bignum? ( obj -- ? ) type-of 13 eq? ;
IN: math : float? ( obj -- ? ) type-of 14 eq? ;
IN: alien : dll? ( obj -- ? ) type-of 15 eq? ;
IN: alien : alien? ( obj -- ? ) type-of 16 eq? ;
IN: kernel
: type-name ( n -- str )
[
[ 0 | "fixnum" ]
[ 1 | "word" ]
[ 2 | "cons" ]
[ 4 | "ratio" ]
[ 5 | "complex" ]
[ 6 | "f" ]
[ 7 | "t" ]
[ 9 | "vector" ]
[ 10 | "string" ]
[ 11 | "sbuf" ]
[ 12 | "port" ]
[ 13 | "bignum" ]
[ 14 | "float" ]
[ 15 | "dll" ]
[ 16 | "alien" ]
! These values are only used by the kernel for error
! reporting.
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc ;

View File

@ -1,36 +1,5 @@
#include "factor.h"
CELL tag_integer(FIXNUM x)
{
if(x < FIXNUM_MIN || x > FIXNUM_MAX)
return tag_object(s48_long_to_bignum(x));
else
return tag_fixnum(x);
}
CELL tag_cell(CELL x)
{
if(x > FIXNUM_MAX)
return tag_object(s48_ulong_to_bignum(x));
else
return tag_fixnum(x);
}
CELL to_cell(CELL x)
{
switch(type_of(x))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(x);
case BIGNUM_TYPE:
/* really need bignum_to_ulong! */
return s48_bignum_to_long(untag_bignum(x));
default:
type_error(INTEGER_TYPE,x);
return 0;
}
}
void primitive_arithmetic_type(void)
{
CELL type2 = type_of(dpop());
@ -52,6 +21,7 @@ void primitive_arithmetic_type(void)
type = type2;
break;
}
break;
case RATIO_TYPE:
switch(type2)
{
@ -63,6 +33,7 @@ void primitive_arithmetic_type(void)
type = type2;
break;
}
break;
case FLOAT_TYPE:
switch(type2)
{
@ -75,6 +46,7 @@ void primitive_arithmetic_type(void)
type = type2;
break;
}
break;
case COMPLEX_TYPE:
switch(type2)
{
@ -88,6 +60,7 @@ void primitive_arithmetic_type(void)
type = type2;
break;
}
break;
default:
type = type1;
break;

View File

@ -2,10 +2,6 @@
void primitive_arithmetic_type(void);
CELL tag_integer(FIXNUM x);
CELL tag_cell(CELL x);
CELL to_cell(CELL x);
bool realp(CELL tagged);
void primitive_numberp(void);

View File

@ -1,5 +1,31 @@
#include "factor.h"
FIXNUM to_integer(CELL x)
{
switch(type_of(x))
{
case FIXNUM_TYPE:
return untag_fixnum_fast(x);
case BIGNUM_TYPE:
return s48_bignum_to_long(untag_bignum(x));
default:
type_error(INTEGER_TYPE,x);
return 0;
}
}
/* FFI calls this */
void box_integer(FIXNUM integer)
{
dpush(tag_integer(integer));
}
/* FFI calls this */
FIXNUM unbox_integer(void)
{
return to_integer(dpop());
}
ARRAY* to_bignum(CELL tagged)
{
RATIO* r;

View File

@ -8,6 +8,9 @@ INLINE ARRAY* untag_bignum(CELL tagged)
return (ARRAY*)UNTAG(tagged);
}
FIXNUM to_integer(CELL x);
void box_integer(FIXNUM integer);
FIXNUM unbox_integer(void);
ARRAY* to_bignum(CELL tagged);
void primitive_to_bignum(void);
void primitive_bignum_eq(void);
@ -28,3 +31,19 @@ void primitive_bignum_greater(void);
void primitive_bignum_greatereq(void);
void primitive_bignum_not(void);
void copy_bignum_constants(void);
INLINE CELL tag_integer(FIXNUM x)
{
if(x < FIXNUM_MIN || x > FIXNUM_MAX)
return tag_object(s48_long_to_bignum(x));
else
return tag_fixnum(x);
}
INLINE CELL tag_cell(CELL x)
{
if(x > FIXNUM_MAX)
return tag_object(s48_ulong_to_bignum(x));
else
return tag_fixnum(x);
}

View File

@ -14,7 +14,7 @@ void check_compiled_offset(CELL offset)
void primitive_set_compiled_byte(void)
{
CELL offset = to_cell(dpop());
CELL offset = unbox_integer();
BYTE b = to_fixnum(dpop());
check_compiled_offset(offset);
bput(offset,b);
@ -22,7 +22,7 @@ void primitive_set_compiled_byte(void)
void primitive_set_compiled_cell(void)
{
CELL offset = to_cell(dpop());
CELL offset = unbox_integer();
CELL c = to_fixnum(dpop());
check_compiled_offset(offset);
put(offset,c);
@ -30,24 +30,24 @@ void primitive_set_compiled_cell(void)
void primitive_compiled_offset(void)
{
dpush(tag_integer(compiling.here));
box_integer(compiling.here);
}
void primitive_set_compiled_offset(void)
{
CELL offset = to_cell(dpop());
CELL offset = unbox_integer();
check_compiled_offset(offset);
compiling.here = offset;
}
void primitive_literal_top(void)
{
dpush(tag_integer(literal_top));
box_integer(literal_top);
}
void primitive_set_literal_top(void)
{
CELL offset = to_cell(dpop());
CELL offset = unbox_integer();
check_compiled_offset(offset);
literal_top = offset;
}

View File

@ -3,8 +3,8 @@
void primitive_dlopen(void)
{
#ifdef FFI
char* path = to_c_string(untag_string(dpop()));
void* dllptr = dlopen(path,RTLD_NOW);
char* path = unbox_c_string();
void* dllptr = dlopen(path,RTLD_LAZY);
DLL* dll;
if(dllptr == NULL)
@ -25,7 +25,7 @@ void primitive_dlsym(void)
{
#ifdef FFI
DLL* dll = untag_dll(dpop());
void* sym = dlsym(dll->dll,to_c_string(untag_string(dpop())));
void* sym = dlsym(dll->dll,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
@ -40,7 +40,7 @@ void primitive_dlsym(void)
void primitive_dlsym_self(void)
{
#ifdef FFI
void* sym = dlsym(NULL,to_c_string(untag_string(dpop())));
void* sym = dlsym(NULL,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
@ -66,3 +66,91 @@ void primitive_dlclose(void)
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_alien(void)
{
#ifdef FFI
CELL length = unbox_integer();
CELL ptr = unbox_integer();
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
alien->ptr = ptr;
alien->length = length;
dpush(tag_object(alien));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
INLINE CELL alien_pointer(void)
{
FIXNUM offset = unbox_integer();
ALIEN* alien = untag_alien(dpop());
if(offset < 0 || offset >= alien->length)
{
range_error(tag_object(alien),offset,alien->length);
return 0; /* can't happen */
}
else
return alien->ptr + offset;
}
void primitive_alien_cell(void)
{
#ifdef FFI
box_integer(get(alien_pointer()));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_set_alien_cell(void)
{
#ifdef FFI
CELL ptr = alien_pointer();
CELL value = unbox_integer();
put(ptr,value);
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_alien_4(void)
{
#ifdef FFI
CELL ptr = alien_pointer();
box_integer(*(int*)ptr);
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_set_alien_4(void)
{
#ifdef FFI
CELL ptr = alien_pointer();
CELL value = unbox_integer();
*(int*)ptr = value;
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_alien_1(void)
{
#ifdef FFI
box_integer(bget(alien_pointer()));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_set_alien_1(void)
{
#ifdef FFI
CELL ptr = alien_pointer();
BYTE value = value = unbox_integer();
bput(ptr,value);
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}

View File

@ -9,7 +9,26 @@ INLINE DLL* untag_dll(CELL tagged)
return (DLL*)UNTAG(tagged);
}
typedef struct {
CELL header;
CELL ptr;
CELL length;
} ALIEN;
INLINE ALIEN* untag_alien(CELL tagged)
{
type_check(ALIEN_TYPE,tagged);
return (ALIEN*)UNTAG(tagged);
}
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlsym_self(void);
void primitive_dlclose(void);
void primitive_alien(void);
void primitive_alien_cell(void);
void primitive_set_alien_cell(void);
void primitive_alien_4(void);
void primitive_set_alien_4(void);
void primitive_alien_1(void);
void primitive_set_alien_1(void);

View File

@ -4,7 +4,7 @@ void primitive_open_file(void)
{
bool write = untag_boolean(dpop());
bool read = untag_boolean(dpop());
char* path = to_c_string(untag_string(dpop()));
char* path = unbox_c_string();
int mode;
int fd;
@ -75,10 +75,10 @@ void primitive_cwd(void)
char wd[MAXPATHLEN];
if(getcwd(wd,MAXPATHLEN) < 0)
io_error(__FUNCTION__);
dpush(tag_object(from_c_string(wd)));
box_c_string(wd);
}
void primitive_cd(void)
{
chdir(to_c_string(untag_string(dpop())));
chdir(unbox_c_string());
}

View File

@ -43,14 +43,14 @@ void primitive_fixnum_add(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
dpush(tag_integer(x + y));
box_integer(x + y);
}
void primitive_fixnum_subtract(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
dpush(tag_integer(x - y));
box_integer(x - y);
}
/**
@ -69,7 +69,7 @@ void primitive_fixnum_multiply(void)
FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
dpush(tag_integer(prod));
box_integer(prod);
else
{
dpush(tag_object(
@ -84,7 +84,7 @@ void primitive_fixnum_divint(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
dpush(tag_integer(x / y));
box_integer(x / y);
}
void primitive_fixnum_divfloat(void)
@ -98,8 +98,8 @@ void primitive_fixnum_divmod(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
dpush(tag_integer(x / y));
dpush(tag_integer(x % y));
box_integer(x / y);
box_integer(x % y);
}
void primitive_fixnum_mod(void)

View File

@ -44,9 +44,9 @@ void primitive_str_to_float(void)
void primitive_float_to_str(void)
{
char tmp[33];
snprintf(tmp,32,"%.16g",to_float(dpeek()));
snprintf(tmp,32,"%.16g",to_float(dpop()));
tmp[32] = '\0';
drepl(tag_object(from_c_string(tmp)));
box_c_string(tmp);
}
void primitive_float_to_bits(void)

View File

@ -93,8 +93,8 @@ bool in_zone(ZONE* z, CELL pointer)
void primitive_room(void)
{
/* push: free total */
dpush(tag_integer(active.limit - active.here));
dpush(tag_integer(active.limit - active.base));
box_integer(active.limit - active.here);
box_integer(active.limit - active.base);
}
void primitive_allot_profiling(void)

View File

@ -70,3 +70,9 @@ bool in_zone(ZONE* z, CELL pointer);
void primitive_room(void);
void primitive_allot_profiling(void);
void primitive_address(void);
void primitive_memory_cell(void);
void primitive_memory_4(void);
void primitive_memory_1(void);
void primitive_set_memory_cell(void);
void primitive_set_memory_4(void);
void primitive_set_memory_1(void);

View File

@ -7,12 +7,12 @@ void primitive_exit(void)
void primitive_os_env(void)
{
char* name = to_c_string(untag_string(dpeek()));
char* name = unbox_c_string();
char* value = getenv(name);
if(value == NULL)
drepl(F);
dpush(F);
else
drepl(tag_object(from_c_string(getenv(name))));
box_c_string(getenv(name));
}
void primitive_eq(void)

View File

@ -171,17 +171,24 @@ XT primitives[] = {
primitive_dump,
primitive_cwd,
primitive_cd,
primitive_set_compiled_byte,
primitive_set_compiled_cell,
primitive_compiled_offset,
primitive_set_compiled_offset,
primitive_set_compiled_cell,
primitive_set_compiled_byte,
primitive_literal_top,
primitive_set_literal_top,
primitive_address,
primitive_dlopen,
primitive_dlsym,
primitive_dlsym_self,
primitive_dlclose
primitive_dlclose,
primitive_alien,
primitive_alien_cell,
primitive_set_alien_cell,
primitive_alien_4,
primitive_set_alien_4,
primitive_alien_1,
primitive_set_alien_1
};
CELL primitive_to_xt(CELL primitive)

View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 181
#define PRIMITIVE_COUNT 188
CELL primitive_to_xt(CELL primitive);

View File

@ -45,7 +45,7 @@ int make_client_socket(const char* hostname, uint16_t port)
void primitive_client_socket(void)
{
uint16_t p = (uint16_t)to_fixnum(dpop());
char* host = to_c_string(untag_string(dpop()));
char* host = unbox_c_string();
int sock = make_client_socket(host,p);
dpush(tag_object(port(PORT_RECV,sock)));
dpush(tag_object(port(PORT_WRITE,sock)));

View File

@ -71,6 +71,12 @@ STRING* from_c_string(const BYTE* c_string)
return s;
}
/* FFI calls this */
void box_c_string(const BYTE* c_string)
{
dpush(tag_object(from_c_string(c_string)));
}
/* untagged */
BYTE* to_c_string(STRING* s)
{
@ -92,6 +98,12 @@ BYTE* to_c_string(STRING* s)
return c_str;
}
/* FFI calls this */
BYTE* unbox_c_string(void)
{
return to_c_string(untag_string(dpop()));
}
void primitive_string_length(void)
{
drepl(tag_fixnum(untag_string(dpeek())->capacity));

View File

@ -17,7 +17,9 @@ STRING* string(FIXNUM capacity, CELL fill);
void hash_string(STRING* str);
STRING* grow_string(STRING* string, FIXNUM capacity, CHAR fill);
BYTE* to_c_string(STRING* s);
void box_c_string(const BYTE* c_string);
STRING* from_c_string(const BYTE* c_string);
BYTE* unbox_c_string(void);
#define SREF(string,index) ((CELL)string + sizeof(STRING) + index * CHARS)

View File

@ -100,6 +100,9 @@ CELL untagged_object_size(CELL pointer)
case DLL_TYPE:
size = sizeof(DLL);
break;
case ALIEN_TYPE:
size = sizeof(ALIEN);
break;
default:
critical_error("Cannot determine size",relocating);
size = -1;/* can't happen */

View File

@ -32,6 +32,7 @@ CELL T;
#define BIGNUM_TYPE 13
#define FLOAT_TYPE 14
#define DLL_TYPE 15
#define ALIEN_TYPE 16
/* Pseudo-types. For error reporting only. */
#define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */

View File

@ -45,7 +45,7 @@ void primitive_word_xt(void)
void primitive_set_word_xt(void)
{
WORD* word = untag_word(dpop());
word->xt = to_cell(dpop());
word->xt = unbox_integer();
}
void primitive_word_primitive(void)