first test of ffi works:
> (import (ikarus system $foreign))
> (((ffi-prep-cif 'void '(uint32))
(dlsym (dlopen #f) "hello_world"))
10)
Hello World
Hello World
Hello World
Hello World
Hello World
Hello World
Hello World
Hello World
Hello World
Hello World
>
This commit is contained in:
Abdulaziz Ghuloum
parent
9f2d7484ab
commit
31f5f88889
9
c64
9
c64
|
|
@ -2,8 +2,15 @@
|
|||
|
||||
./configure --prefix=/Users/ikarus/.opt \
|
||||
--enable-libffi \
|
||||
CFLAGS="-m64 -I/Users/ikarus/.opt64/include" \
|
||||
CFLAGS="-m64 -I/Users/ikarus/.opt64/include -I/Users/ikarus/.opt64/lib/libffi-3.0.6/include" \
|
||||
LDFLAGS="-m64 -L/Users/ikarus/.opt64/lib" \
|
||||
&& make clean \
|
||||
&& make
|
||||
|
||||
# LIBFFI configuration (on darwin):
|
||||
# ./configure
|
||||
# --target=x86_64-darwin
|
||||
# --build=x86_64-darwin
|
||||
# --prefix=/Users/ikarus/.opt64
|
||||
# CFLAGS=-m64
|
||||
# LDFLAGS=-m64
|
||||
|
|
|
|||
|
|
@ -1,5 +1,8 @@
|
|||
/* config.h.in. Generated from configure.ac by autoheader. */
|
||||
|
||||
/* adds support for libffi */
|
||||
#undef ENABLE_LIBFFI
|
||||
|
||||
/* Define to 1 if you have the <assert.h> header file. */
|
||||
#undef HAVE_ASSERT_H
|
||||
|
||||
|
|
@ -15,6 +18,9 @@
|
|||
/* Define to 1 if you have the <fcntl.h> header file. */
|
||||
#undef HAVE_FCNTL_H
|
||||
|
||||
/* Define to 1 if you have the <ffi.h> header file. */
|
||||
#undef HAVE_FFI_H
|
||||
|
||||
/* Define to 1 if you have the `fork' function. */
|
||||
#undef HAVE_FORK
|
||||
|
||||
|
|
@ -33,6 +39,9 @@
|
|||
/* Define to 1 if you have the <inttypes.h> header file. */
|
||||
#undef HAVE_INTTYPES_H
|
||||
|
||||
/* Define to 1 if you have the `ffi' library (-lffi). */
|
||||
#undef HAVE_LIBFFI
|
||||
|
||||
/* Define to 1 if you have the `gmp' library (-lgmp). */
|
||||
#undef HAVE_LIBGMP
|
||||
|
||||
|
|
|
|||
|
|
@ -740,6 +740,7 @@ ac_subst_files=''
|
|||
ac_user_opts='
|
||||
enable_option_checking
|
||||
enable_dependency_tracking
|
||||
enable_libffi
|
||||
'
|
||||
ac_precious_vars='build_alias
|
||||
host_alias
|
||||
|
|
@ -1385,6 +1386,7 @@ Optional Features:
|
|||
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
|
||||
--disable-dependency-tracking speeds up one-time build
|
||||
--enable-dependency-tracking do not reject slow dependency extractors
|
||||
--enable-libffi enable support for libffi.
|
||||
|
||||
Some influential environment variables:
|
||||
CC C compiler command
|
||||
|
|
@ -6645,11 +6647,265 @@ fi
|
|||
ac_cv_lib_gmp=ac_cv_lib_gmp_main
|
||||
|
||||
|
||||
# AC_ARG_ENABLE(libffi,
|
||||
# [ --enable-libffi enable support for libffi.],
|
||||
# AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi]))
|
||||
# AC_CHECK_HEADERS([libffi.h])
|
||||
# AC_HAVE_LIBRARY([ffi])
|
||||
# Check whether --enable-libffi was given.
|
||||
if test "${enable_libffi+set}" = set; then
|
||||
enableval=$enable_libffi;
|
||||
cat >>confdefs.h <<\_ACEOF
|
||||
#define ENABLE_LIBFFI 1
|
||||
_ACEOF
|
||||
|
||||
fi
|
||||
|
||||
|
||||
for ac_header in ffi.h
|
||||
do
|
||||
as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh`
|
||||
if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
|
||||
{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5
|
||||
$as_echo_n "checking for $ac_header... " >&6; }
|
||||
if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
fi
|
||||
ac_res=`eval 'as_val=${'$as_ac_Header'}
|
||||
$as_echo "$as_val"'`
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_res" >&5
|
||||
$as_echo "$ac_res" >&6; }
|
||||
else
|
||||
# Is the header compilable?
|
||||
{ $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5
|
||||
$as_echo_n "checking $ac_header usability... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
$ac_includes_default
|
||||
#include <$ac_header>
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext
|
||||
if { (ac_try="$ac_compile"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_compile") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest.$ac_objext; then
|
||||
ac_header_compiler=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_compiler=no
|
||||
fi
|
||||
|
||||
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5
|
||||
$as_echo "$ac_header_compiler" >&6; }
|
||||
|
||||
# Is the header present?
|
||||
{ $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5
|
||||
$as_echo_n "checking $ac_header presence... " >&6; }
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
#include <$ac_header>
|
||||
_ACEOF
|
||||
if { (ac_try="$ac_cpp conftest.$ac_ext"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } >/dev/null && {
|
||||
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
}; then
|
||||
ac_header_preproc=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_header_preproc=no
|
||||
fi
|
||||
|
||||
rm -f conftest.err conftest.$ac_ext
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5
|
||||
$as_echo "$ac_header_preproc" >&6; }
|
||||
|
||||
# So? What about this header?
|
||||
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in
|
||||
yes:no: )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;}
|
||||
ac_header_preproc=yes
|
||||
;;
|
||||
no:yes:* )
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;}
|
||||
{ $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5
|
||||
$as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;}
|
||||
( cat <<\_ASBOX
|
||||
## -------------------------------------- ##
|
||||
## Report this to aghuloum@cs.indiana.edu ##
|
||||
## -------------------------------------- ##
|
||||
_ASBOX
|
||||
) | sed "s/^/$as_me: WARNING: /" >&2
|
||||
;;
|
||||
esac
|
||||
{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5
|
||||
$as_echo_n "checking for $ac_header... " >&6; }
|
||||
if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
eval "$as_ac_Header=\$ac_header_preproc"
|
||||
fi
|
||||
ac_res=`eval 'as_val=${'$as_ac_Header'}
|
||||
$as_echo "$as_val"'`
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_res" >&5
|
||||
$as_echo "$ac_res" >&6; }
|
||||
|
||||
fi
|
||||
as_val=`eval 'as_val=${'$as_ac_Header'}
|
||||
$as_echo "$as_val"'`
|
||||
if test "x$as_val" = x""yes; then
|
||||
cat >>confdefs.h <<_ACEOF
|
||||
#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1
|
||||
_ACEOF
|
||||
|
||||
else
|
||||
if test "$enable_libffi" = "yes"; then
|
||||
{ { $as_echo "$as_me:$LINENO: error: ffi.h cannot be found.
|
||||
Please specify the location of the header file using
|
||||
./configure CFLAGS=-I<path/to/ffi.h> <other-options ...>
|
||||
" >&5
|
||||
$as_echo "$as_me: error: ffi.h cannot be found.
|
||||
Please specify the location of the header file using
|
||||
./configure CFLAGS=-I<path/to/ffi.h> <other-options ...>
|
||||
" >&2;}
|
||||
{ (exit 1); exit 1; }; }
|
||||
fi
|
||||
fi
|
||||
|
||||
done
|
||||
|
||||
|
||||
{ $as_echo "$as_me:$LINENO: checking for ffi_call in -lffi" >&5
|
||||
$as_echo_n "checking for ffi_call in -lffi... " >&6; }
|
||||
if test "${ac_cv_lib_ffi_ffi_call+set}" = set; then
|
||||
$as_echo_n "(cached) " >&6
|
||||
else
|
||||
ac_check_lib_save_LIBS=$LIBS
|
||||
LIBS="-lffi $LIBS"
|
||||
cat >conftest.$ac_ext <<_ACEOF
|
||||
/* confdefs.h. */
|
||||
_ACEOF
|
||||
cat confdefs.h >>conftest.$ac_ext
|
||||
cat >>conftest.$ac_ext <<_ACEOF
|
||||
/* end confdefs.h. */
|
||||
|
||||
/* Override any GCC internal prototype to avoid an error.
|
||||
Use char because int might match the return type of a GCC
|
||||
builtin and then its argument prototype would still apply. */
|
||||
#ifdef __cplusplus
|
||||
extern "C"
|
||||
#endif
|
||||
char ffi_call ();
|
||||
int
|
||||
main ()
|
||||
{
|
||||
return ffi_call ();
|
||||
;
|
||||
return 0;
|
||||
}
|
||||
_ACEOF
|
||||
rm -f conftest.$ac_objext conftest$ac_exeext
|
||||
if { (ac_try="$ac_link"
|
||||
case "(($ac_try" in
|
||||
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
|
||||
*) ac_try_echo=$ac_try;;
|
||||
esac
|
||||
eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\""
|
||||
$as_echo "$ac_try_echo") >&5
|
||||
(eval "$ac_link") 2>conftest.er1
|
||||
ac_status=$?
|
||||
grep -v '^ *+' conftest.er1 >conftest.err
|
||||
rm -f conftest.er1
|
||||
cat conftest.err >&5
|
||||
$as_echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && {
|
||||
test -z "$ac_c_werror_flag" ||
|
||||
test ! -s conftest.err
|
||||
} && test -s conftest$ac_exeext && {
|
||||
test "$cross_compiling" = yes ||
|
||||
$as_test_x conftest$ac_exeext
|
||||
}; then
|
||||
ac_cv_lib_ffi_ffi_call=yes
|
||||
else
|
||||
$as_echo "$as_me: failed program was:" >&5
|
||||
sed 's/^/| /' conftest.$ac_ext >&5
|
||||
|
||||
ac_cv_lib_ffi_ffi_call=no
|
||||
fi
|
||||
|
||||
rm -rf conftest.dSYM
|
||||
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
|
||||
conftest$ac_exeext conftest.$ac_ext
|
||||
LIBS=$ac_check_lib_save_LIBS
|
||||
fi
|
||||
{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_ffi_ffi_call" >&5
|
||||
$as_echo "$ac_cv_lib_ffi_ffi_call" >&6; }
|
||||
if test "x$ac_cv_lib_ffi_ffi_call" = x""yes; then
|
||||
cat >>confdefs.h <<_ACEOF
|
||||
#define HAVE_LIBFFI 1
|
||||
_ACEOF
|
||||
|
||||
LIBS="-lffi $LIBS"
|
||||
|
||||
else
|
||||
if test "$enable_libffi" = "yes"; then
|
||||
{ { $as_echo "$as_me:$LINENO: error: libffi cannot be found.
|
||||
Please specify the location of the library file using
|
||||
./configure LDFLAGS=-L<path/to/libffi.ld|dylib|so|etc.> <other-options ...>
|
||||
" >&5
|
||||
$as_echo "$as_me: error: libffi cannot be found.
|
||||
Please specify the location of the library file using
|
||||
./configure LDFLAGS=-L<path/to/libffi.ld|dylib|so|etc.> <other-options ...>
|
||||
" >&2;}
|
||||
{ (exit 1); exit 1; }; }
|
||||
fi
|
||||
fi
|
||||
|
||||
|
||||
# Checks for typedefs, structures, and compiler characteristics.
|
||||
{ $as_echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5
|
||||
|
|
|
|||
22
configure.ac
22
configure.ac
|
|
@ -63,11 +63,23 @@ ERROR: the gmp.h header file), and LDFLAGS=-L</path/to/lib> (containing
|
|||
ERROR: libgmp.so) if libgmp is installed in a non-standard location.
|
||||
ERROR: libgmp can be obtained from <http://gmplib.org>. ])])
|
||||
|
||||
# AC_ARG_ENABLE(libffi,
|
||||
# [ --enable-libffi enable support for libffi.],
|
||||
# AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi]))
|
||||
# AC_CHECK_HEADERS([libffi.h])
|
||||
# AC_HAVE_LIBRARY([ffi])
|
||||
AC_ARG_ENABLE(libffi,
|
||||
[ --enable-libffi enable support for libffi.],
|
||||
AC_DEFINE(ENABLE_LIBFFI, 1, [adds support for libffi]))
|
||||
AC_CHECK_HEADERS([ffi.h],,
|
||||
if test "$enable_libffi" = "yes"; then
|
||||
AC_MSG_ERROR([ffi.h cannot be found.
|
||||
Please specify the location of the header file using
|
||||
./configure CFLAGS=-I<path/to/ffi.h> <other-options ...>
|
||||
])
|
||||
fi)
|
||||
AC_CHECK_LIB(ffi,ffi_call,,
|
||||
if test "$enable_libffi" = "yes"; then
|
||||
AC_MSG_ERROR([libffi cannot be found.
|
||||
Please specify the location of the library file using
|
||||
./configure LDFLAGS=-L<path/to/libffi.ld|dylib|so|etc.> <other-options ...>
|
||||
])
|
||||
fi)
|
||||
|
||||
# Checks for typedefs, structures, and compiler characteristics.
|
||||
AC_C_CONST
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
dlopen dlerror dlclose dlsym malloc free
|
||||
pointer-ref-char pointer-ref-short pointer-ref-int pointer-ref-long
|
||||
pointer-ref-uchar pointer-ref-ushort pointer-ref-uint pointer-ref-ulong
|
||||
pointer-set-char pointer-set-short pointer-set-int pointer-set-long)
|
||||
pointer-set-char pointer-set-short pointer-set-int pointer-set-long
|
||||
ffi-prep-cif)
|
||||
(import
|
||||
(except (ikarus)
|
||||
pointer?
|
||||
|
|
@ -118,6 +119,42 @@
|
|||
(define-setter pointer-set-int "ikrt_set_int")
|
||||
(define-setter pointer-set-long "ikrt_set_long")
|
||||
|
||||
;;; libffi interface
|
||||
|
||||
(define (ffi-prep-cif rtype argtypes)
|
||||
(define who 'ffi-prep-cif)
|
||||
(define (convert x)
|
||||
(case x
|
||||
[(void) 1]
|
||||
[(uint8) 2]
|
||||
[(sint8) 3]
|
||||
[(uint16) 4]
|
||||
[(sint16) 5]
|
||||
[(uint32) 6]
|
||||
[(sint32) 7]
|
||||
[(uint64) 8]
|
||||
[(sint64) 9]
|
||||
[(float) 10]
|
||||
[(double) 11]
|
||||
[(pointer) 12]
|
||||
[else (die who "invalid type" x)]))
|
||||
(unless (list? argtypes)
|
||||
(die who "arg types is not a list" argtypes))
|
||||
(let ([argtypes-n (vector-map convert (list->vector argtypes))]
|
||||
[rtype-n (convert rtype)])
|
||||
(let ([cif (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n)
|
||||
(die who "failed to initialize" rtype argtypes))])
|
||||
(lambda (cfun)
|
||||
(define data (vector cif cfun argtypes-n rtype-n))
|
||||
(unless (pointer? cfun)
|
||||
(die 'ffi "not a pointer" cfun))
|
||||
(lambda args
|
||||
(let ([argsvec (list->vector args)])
|
||||
(unless (= (vector-length argsvec)
|
||||
(vector-length argtypes-n))
|
||||
(error 'ffi "args mismatch" argtypes args))
|
||||
(foreign-call "ikrt_ffi_call" data argsvec)))))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1598
|
||||
1599
|
||||
|
|
|
|||
|
|
@ -1476,6 +1476,7 @@
|
|||
[pointer-set-short $for]
|
||||
[pointer-set-int $for]
|
||||
[pointer-set-long $for]
|
||||
[ffi-prep-cif $for]
|
||||
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
|
|||
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
|
||||
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
|
||||
ikarus-errno.c ikarus-main.h ikarus-pointers.c
|
||||
ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus-ffi.c
|
||||
|
||||
ikarus_SOURCES = $(SRCS) ikarus.c
|
||||
scheme_script_SOURCES = $(SRCS) scheme-script.c
|
||||
|
|
|
|||
|
|
@ -55,7 +55,8 @@ am__objects_1 = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \
|
|||
ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \
|
||||
cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \
|
||||
ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \
|
||||
ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT)
|
||||
ikarus-errno.$(OBJEXT) ikarus-pointers.$(OBJEXT) \
|
||||
ikarus-ffi.$(OBJEXT)
|
||||
am_ikarus_OBJECTS = $(am__objects_1) ikarus.$(OBJEXT)
|
||||
nodist_ikarus_OBJECTS =
|
||||
ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS)
|
||||
|
|
@ -185,7 +186,7 @@ SRCS = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
|
|||
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
|
||||
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
|
||||
ikarus-errno.c ikarus-main.h ikarus-pointers.c
|
||||
ikarus-errno.c ikarus-main.h ikarus-pointers.c ikarus-ffi.c
|
||||
|
||||
ikarus_SOURCES = $(SRCS) ikarus.c
|
||||
scheme_script_SOURCES = $(SRCS) scheme-script.c
|
||||
|
|
@ -268,6 +269,7 @@ distclean-compile:
|
|||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-errno.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-exec.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-fasl.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-ffi.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-flonums.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-getaddrinfo.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-io.Po@am__quote@
|
||||
|
|
|
|||
|
|
@ -0,0 +1,172 @@
|
|||
|
||||
#include "ikarus-data.h"
|
||||
#include "config.h"
|
||||
|
||||
#if ENABLE_LIBFFI
|
||||
#include <ffi.h>
|
||||
#include <stdlib.h>
|
||||
#include <strings.h>
|
||||
|
||||
static void*
|
||||
alloc(size_t n, int m) {
|
||||
void* x = calloc(n, m);
|
||||
if (x == NULL) {
|
||||
fprintf(stderr, "ERROR (ikarus): calloc failed!\n");
|
||||
exit(-1);
|
||||
}
|
||||
return x;
|
||||
}
|
||||
|
||||
static ffi_type*
|
||||
scheme_to_ffi_type_cast(int n){
|
||||
switch (n & 0xF) {
|
||||
case 1: return &ffi_type_void;
|
||||
case 2: return &ffi_type_uint8;
|
||||
case 3: return &ffi_type_sint8;
|
||||
case 4: return &ffi_type_uint16;
|
||||
case 5: return &ffi_type_sint16;
|
||||
case 6: return &ffi_type_uint32;
|
||||
case 7: return &ffi_type_sint32;
|
||||
case 8: return &ffi_type_uint64;
|
||||
case 9: return &ffi_type_sint64;
|
||||
case 10: return &ffi_type_float;
|
||||
case 11: return &ffi_type_double;
|
||||
case 12: return &ffi_type_pointer;
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %d", n);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
static void*
|
||||
alloc_room_for_type(int n){
|
||||
ffi_type* t = scheme_to_ffi_type_cast(n);
|
||||
return alloc(t->size, 1);
|
||||
}
|
||||
|
||||
extern long extract_num(ikptr x);
|
||||
|
||||
static void*
|
||||
scheme_to_ffi_value_cast(int n, ikptr p) {
|
||||
void* r = alloc_room_for_type(n);
|
||||
switch (n & 0xF) {
|
||||
case 1: { free(r); return NULL; }
|
||||
case 2: // ffi_type_uint8;
|
||||
case 3:
|
||||
{ *((char*)r) = extract_num(p); return r; }
|
||||
case 4: // ffi_type_uint16;
|
||||
case 5:
|
||||
{ *((short*)r) = extract_num(p); return r; }
|
||||
case 6: // ffi_type_uint32;
|
||||
case 7:
|
||||
{ *((int*)r) = extract_num(p); return r; }
|
||||
case 8: // ffi_type_uint64;
|
||||
case 9:
|
||||
{ *((long*)r) = extract_num(p); return r; }
|
||||
case 10: //return &ffi_type_float;
|
||||
{ *((float*)r) = flonum_data(p); return r; }
|
||||
case 11: //return &ffi_type_double;
|
||||
{ *((double*)r) = flonum_data(p); return r; }
|
||||
case 12: //return &ffi_type_pointer;
|
||||
{ *((void**)r) = (void*)ref(p, off_pointer_data); return r; }
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %d", n);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
extern ikptr u_to_number(unsigned long x, ikpcb* pcb);
|
||||
extern ikptr s_to_number(signed long x, ikpcb* pcb);
|
||||
extern ikptr d_to_number(double x, ikpcb* pcb);
|
||||
extern ikptr make_pointer(void* x, ikpcb* pcb);
|
||||
static ikptr
|
||||
ffi_to_scheme_value_cast(int n, void* p, ikpcb* pcb) {
|
||||
switch (n & 0xF) {
|
||||
case 1: return void_object;
|
||||
case 2: return u_to_number(*((unsigned char*)p), pcb);
|
||||
case 3: return s_to_number(*((signed char*)p), pcb);
|
||||
case 4: return u_to_number(*((unsigned short*)p), pcb);
|
||||
case 5: return s_to_number(*((signed short*)p), pcb);
|
||||
case 6: return u_to_number(*((unsigned int*)p), pcb);
|
||||
case 7: return s_to_number(*((signed int*)p), pcb);
|
||||
case 8: return u_to_number(*((unsigned long*)p), pcb);
|
||||
case 9: return s_to_number(*((signed long*)p), pcb);
|
||||
case 10: return d_to_number(*((float*)p), pcb);
|
||||
case 11: return d_to_number(*((double*)p), pcb);
|
||||
case 12: return make_pointer(*((void**)p), pcb);
|
||||
default:
|
||||
fprintf(stderr, "INVALID ARG %d", n);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
|
||||
ffi_cif* cif = alloc(sizeof(ffi_cif), 1);
|
||||
bzero(cif, sizeof(ffi_cif));
|
||||
ffi_abi abi = FFI_DEFAULT_ABI;
|
||||
unsigned int nargs = unfix(ref(argstptr, off_vector_length));
|
||||
ffi_type** argtypes = alloc(sizeof(ffi_type*), nargs);
|
||||
int i;
|
||||
for(i=0; i<nargs; i++){
|
||||
ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
|
||||
argtypes[i] = scheme_to_ffi_type_cast(unfix(argt));
|
||||
}
|
||||
ffi_type* rtype = scheme_to_ffi_type_cast(unfix(rtptr));
|
||||
ffi_status s = ffi_prep_cif(cif, abi, nargs, rtype, argtypes);
|
||||
if (s == FFI_OK) {
|
||||
ikptr r = ik_safe_alloc(pcb, pointer_size);
|
||||
ref(r, 0) = pointer_tag;
|
||||
ref(r, wordsize) = (ikptr)cif;
|
||||
return (r + vector_tag);
|
||||
} else {
|
||||
return false_object;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
ikptr
|
||||
ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
|
||||
ikptr cifptr = ref(data, off_vector_data + 0 * wordsize);
|
||||
ikptr funptr = ref(data, off_vector_data + 1 * wordsize);
|
||||
ikptr typevec = ref(data, off_vector_data + 2 * wordsize);
|
||||
ikptr rtype = ref(data, off_vector_data + 3 * wordsize);
|
||||
ffi_cif* cif = (ffi_cif*) ref(cifptr, off_pointer_data);
|
||||
void* fn = (void*) ref(funptr, off_pointer_data);
|
||||
unsigned int n = unfix(ref(argsvec, off_vector_length));
|
||||
void** avalues = alloc(sizeof(void*), n);
|
||||
int i;
|
||||
for(i=0; i<n; i++){
|
||||
ikptr t = ref(typevec, off_vector_data + i * wordsize);
|
||||
ikptr v = ref(argsvec, off_vector_data + i * wordsize);
|
||||
avalues[i] = scheme_to_ffi_value_cast(unfix(t), v);
|
||||
}
|
||||
void* rvalue = alloc_room_for_type(unfix(rtype));;
|
||||
ffi_call(cif, fn, rvalue, avalues);
|
||||
ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
|
||||
for(i=0; i<n; i++){
|
||||
free(avalues[i]);
|
||||
}
|
||||
free(avalues);
|
||||
free(rvalue);
|
||||
return val;
|
||||
}
|
||||
|
||||
void hello_world(int n) {
|
||||
while(n > 0) {
|
||||
fprintf(stderr, "Hello World\n");
|
||||
n--;
|
||||
}
|
||||
}
|
||||
|
||||
#else
|
||||
ikptr ikrt_ffi_prep_cif() { return false_object; }
|
||||
ikrt_ffi_call() { return false_object; }
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -35,7 +35,7 @@ ikrt_pointer_to_int(ikptr x, ikpcb* pcb) {
|
|||
}
|
||||
}
|
||||
|
||||
static ikptr
|
||||
ikptr
|
||||
make_pointer(long int x, ikpcb* pcb) {
|
||||
ikptr r = ik_safe_alloc(pcb, pointer_size);
|
||||
ref(r, 0) = pointer_tag;
|
||||
|
|
@ -152,7 +152,7 @@ ikrt_ref_ushort(ikptr p, ikptr off /*, ikpcb* pcb*/) {
|
|||
return fix(*((unsigned short*)(((long)ref(p, off_pointer_data)) + unfix(off))));
|
||||
}
|
||||
|
||||
static ikptr
|
||||
ikptr
|
||||
s_to_number(signed long n, ikpcb* pcb) {
|
||||
ikptr fx = fix(n);
|
||||
if (unfix(fx) == n) {
|
||||
|
|
@ -172,7 +172,7 @@ s_to_number(signed long n, ikpcb* pcb) {
|
|||
return bn+vector_tag;
|
||||
}
|
||||
|
||||
static ikptr
|
||||
ikptr
|
||||
u_to_number(unsigned long n, ikpcb* pcb) {
|
||||
unsigned long mxn = ((unsigned long)-1)>>(fx_shift+1);
|
||||
if (n <= mxn) {
|
||||
|
|
@ -184,6 +184,15 @@ u_to_number(unsigned long n, ikpcb* pcb) {
|
|||
return bn+vector_tag;
|
||||
}
|
||||
|
||||
ikptr
|
||||
d_to_number(double n, ikpcb* pcb) {
|
||||
ikptr x = ik_safe_alloc(pcb, flonum_size) + vector_tag;
|
||||
ref(x, -vector_tag) = flonum_tag;
|
||||
flonum_data(x) = n;
|
||||
return x;
|
||||
}
|
||||
|
||||
|
||||
|
||||
ikptr
|
||||
ikrt_ref_int(ikptr p, ikptr off , ikpcb* pcb) {
|
||||
|
|
@ -221,7 +230,7 @@ ikrt_ref_ulong(ikptr p, ikptr off , ikpcb* pcb) {
|
|||
return u_to_number(r, pcb);
|
||||
}
|
||||
|
||||
static long
|
||||
long
|
||||
extract_num(ikptr x) {
|
||||
if (is_fixnum(x)) {
|
||||
return unfix(x);
|
||||
|
|
|
|||
Loading…
Reference in New Issue