From fad32e1a80cdc3e99cfec93af5f6becd9d99ff64 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 14 May 2009 23:31:31 -0700 Subject: [PATCH] Foreign Function Interface, as released 2009-03-18. * doc/Makefile.in: Include ffi in SUBDIRS. Fixed a command that halted `make install` whenever $(DESTDIR)$(infodir)/dir existed. * doc/configure.ac: Include ffi/Makefile. * doc/ffi/Makefile.in: Build the Users' Manual for the FFI. * doc/ffi/ffi.texinfo: The Users' Manual for the FFI. * doc/index.html: Include mit-scheme-ffi/index.html, and an $Id:$ stamp. * src/Makefile.in: Optimistically included ffi in LIARC_BUNDLES. Use --batch-mode more. * src/README.txt: Punted mention of bchscheme. Describe ffi as part of the core. * src/Setup.sh: Include ffi in INSTALLED_SUBDIRS. Create lib/mit-scheme.h and lib/ffi. * src/configure.ac: Include ffi/Makefile. Include ffi in liarc BUNDLEs. * src/etc/compile.scm: Include ffi in list for compile-dir. * src/etc/create-makefiles.sh: Include ffi in BUNDLES. Use --batch-mode. * src/etc/optiondb.scm: Define loadable option 'FFI. * src/ffi/Makefile-fragment: Install the FFI. Show how to build the example. * src/ffi/: cdecls.scm, compile.scm, ctypes.scm, ed-ffi.scm, ffi.pkg, generator.scm, load.scm, syntax.scm: The FFI .cdecl file reader, syntax expanders and trampoline generator. * src/ffi/prhello.cdecl, src/ffi/prhello.scm: The example, Gtk 2.0, primitive "Hello, World!" program. * src/microcode/boot.c: Initialize the C data stack (ffi_obstack) alongside scratch_obstack. Give Interpret() a pop_return_p argument. * src/microcode/configure.ac: Include pruxffi whenever pruxdld is available. * src/microcode/const.h: Declare PRIM_RETURN_TO_C and PRIM_ABORT_TO_C -- two new ways to exit the interpreter that leave it ready for re-entry via Interpret(1). * src/microcode/extern.h: Declare ffi_obstack, find_primitive_cname, and a pop_return_p parameter to Interpret(). * src/microcode/fixobj.h, src/microcode/utabmd.scm: Include a CALLBACK-HANDLER slot in the fixed objects vector. * src/microcode/interp.c: Added a pop_return_p parameter to Interpret(). Implemented the new PRIM_RETURN_TO_C and PRIM_ABORT_TO_C aborts. * src/microcode/makegen/Makefile.in.in: Install mit-scheme.h. * src/microcode/makegen/files-optional.scm: Include pruxffi in the list. * src/microcode/primutl.c: Needed a find_primitive_cname function taking a C string. A similar function, find_primitive, already takes a Scheme string. Modified it into find_primitive_cname, in terms of which find_primitive was easily re-implemented. * src/microcode/pruxdld.c: Failed function is "dlsym", not "dlopen", in dld_lookup. * src/microcode/pruxffi.c, src/microcode/pruxffi.h: The FFI's C/Unix primitives. * src/runtime/ed-ffi.scm, src/runtime/ffi.scm: Runtime support for the FFI: aliens, alien-functions, malloc/free, a callback-handler... * src/runtime/make.scm: Include (runtime ffi) in the package-initialization-sequence. * src/runtime/runtime.pkg: Declare a (runtime ffi) package, with a link to without-preemption in (runtime thread). * src/runtime/thread.scm: Added the without-timer-interrupts procedure for use by the call-alien procedure in (runtime ffi). This halts thread switching during the callout, forcing all chains of callouts interrupted by callbacks who make callouts that are interrupted by callbacks... to run in one thread, preserving the order imposed by one C stack. If two callbacks, "Newer" nested inside "Older" on the C stack, are running in two Scheme threads, Scheme could proceed with Older before Newer, returning a value for Older to a callback trampoline expecting the value of Newer. Blam! --- doc/Makefile.in | 6 +- doc/configure.ac | 1 + doc/ffi/Makefile.in | 12 + doc/ffi/ffi.texinfo | 1225 ++++++++++++++++++++++ doc/index.html | 2 + src/Makefile.in | 6 +- src/README.txt | 6 +- src/Setup.sh | 4 +- src/configure.ac | 3 +- src/etc/compile.scm | 2 +- src/etc/create-makefiles.sh | 8 +- src/etc/optiondb.scm | 3 + src/ffi/Makefile-fragment | 48 + src/ffi/cdecls.scm | 367 +++++++ src/ffi/compile.scm | 30 + src/ffi/ctypes.scm | 294 ++++++ src/ffi/ed-ffi.scm | 12 + src/ffi/ffi.pkg | 38 + src/ffi/generator.scm | 691 ++++++++++++ src/ffi/load.scm | 10 + src/ffi/prhello.cdecl | 86 ++ src/ffi/prhello.scm | 57 + src/ffi/syntax.scm | 510 +++++++++ src/microcode/boot.c | 6 +- src/microcode/configure.ac | 2 +- src/microcode/const.h | 6 +- src/microcode/extern.h | 4 +- src/microcode/fixobj.h | 4 +- src/microcode/interp.c | 19 +- src/microcode/makegen/Makefile.in.in | 1 + src/microcode/makegen/files-optional.scm | 1 + src/microcode/primutl.c | 16 +- src/microcode/pruxdld.c | 2 +- src/microcode/pruxffi.c | 1208 +++++++++++++++++++++ src/microcode/pruxffi.h | 97 ++ src/microcode/utabmd.scm | 1 + src/runtime/ed-ffi.scm | 1 + src/runtime/ffi.scm | 505 +++++++++ src/runtime/make.scm | 3 +- src/runtime/runtime.pkg | 40 + src/runtime/thread.scm | 7 + 41 files changed, 5313 insertions(+), 31 deletions(-) create mode 100644 doc/ffi/Makefile.in create mode 100644 doc/ffi/ffi.texinfo create mode 100644 src/ffi/Makefile-fragment create mode 100644 src/ffi/cdecls.scm create mode 100644 src/ffi/compile.scm create mode 100644 src/ffi/ctypes.scm create mode 100644 src/ffi/ed-ffi.scm create mode 100644 src/ffi/ffi.pkg create mode 100644 src/ffi/generator.scm create mode 100644 src/ffi/load.scm create mode 100644 src/ffi/prhello.cdecl create mode 100644 src/ffi/prhello.scm create mode 100644 src/ffi/syntax.scm create mode 100644 src/microcode/pruxffi.c create mode 100644 src/microcode/pruxffi.h create mode 100644 src/runtime/ffi.scm diff --git a/doc/Makefile.in b/doc/Makefile.in index 4d092f7ba..59e772726 100644 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@ -66,7 +66,7 @@ pdfdir = @pdfdir@ psdir = @psdir@ INST_TARGETS = @INST_TARGETS@ -SUBDIRS = imail ref-manual sos user-manual +SUBDIRS = ffi imail ref-manual sos user-manual DISTCLEAN_FILES = Makefile make-common config.log config.status all: @@ -108,8 +108,8 @@ install: install-info-gz install-man $(INST_TARGETS) install-info-gz install-info: $(mkinstalldirs) $(DESTDIR)$(infodir) - test ! -e $(DESTDIR)$(infodir)/dir \ - && $(INSTALL_DATA) info-dir $(DESTDIR)$(infodir)/dir + if [ ! -e $(DESTDIR)$(infodir)/dir ]; then \ + $(INSTALL_DATA) info-dir $(DESTDIR)$(infodir)/dir; fi @for D in $(SUBDIRS); do \ echo "making $@ in $${D}";\ ( cd $${D} && $(MAKE) $@ ) || exit 1;\ diff --git a/doc/configure.ac b/doc/configure.ac index a68863b6a..908fc513d 100644 --- a/doc/configure.ac +++ b/doc/configure.ac @@ -81,6 +81,7 @@ AC_SUBST([INST_TARGETS]) AC_CONFIG_FILES([ Makefile make-common + ffi/Makefile imail/Makefile ref-manual/Makefile sos/Makefile diff --git a/doc/ffi/Makefile.in b/doc/ffi/Makefile.in new file mode 100644 index 000000000..6b2c6b274 --- /dev/null +++ b/doc/ffi/Makefile.in @@ -0,0 +1,12 @@ +# $Id: $ +# doc/ffi/Makefile.in + +@SET_MAKE@ +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ + +SOURCES = ffi.texinfo ../../src/ffi/prhello.cdecl ../../src/ffi/prhello.scm +TARGET_ROOT = mit-scheme-ffi + +include $(top_srcdir)/make-common diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo new file mode 100644 index 000000000..99ab2c2ff --- /dev/null +++ b/doc/ffi/ffi.texinfo @@ -0,0 +1,1225 @@ +\input texinfo @c -*-Texinfo-*- +@comment $Id: $ +@comment %**start of header +@setfilename mit-scheme-ffi +@set VERSION 0.1 +@settitle FFI @value{VERSION} +@comment %**end of header + +@macro myresult{} +@ifhtml + => +@end ifhtml +@ifnothtml + @result{} +@end ifnothtml +@end macro + +@copying +This manual documents @acronym{FFI} @value{VERSION}. + +Copyright @copyright{} 2006, 2007, 2008, 2009 Matthew Birkholz + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,'' +and with the Back-Cover Texts as in (a) below. A copy of the +license is included in the section entitled ``GNU Free Documentation +License.'' + +(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify +this GNU Manual, like GNU software. Copies published by the Free +Software Foundation raise funds for GNU development.'' +@end quotation +@end copying + +@dircategory Programming Languages +@direntry +* FFI: (mit-scheme-ffi). MIT/GNU Scheme Foreign Functions +@end direntry + +@titlepage +@title The FFI Reference Manual +@subtitle a Foreign Function Interface (@value{VERSION}) +@subtitle for MIT/GNU Scheme version 7.7.90+ +@author by Matt Birkholz +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@ifnottex +@node Top, Introduction, (dir), (dir) +@top FFI + +@insertcopying +@end ifnottex + +@menu +* Introduction:: A synopsis and quick summary. +* C Declarations:: Declare C types and functions. +* Alien Data:: Manipulate C data. +* Alien Functions:: Generate callout trampolines and call them. +* Callbacks:: Generate callback trampolines and get interrupted by them. +* Compiling and Linking:: Build and install the shim. +* Hello World:: A short example. +* GNU Free Documentation License:: +@end menu + + +@node Introduction, C Declarations, Top, Top +@chapter Introduction + +This FFI provides syntax for calling C functions and accessing C data +structures from Scheme. The functions and data structures, as well as +any callback functions, are first declared in a case sensitive +@file{.cdecl} file, which is used by a shim generator to produce +callout and callback trampoline functions. The trampolines are then +compiled and linked to the C toolkit, and may be linked into the +Scheme machine or into a shared object that Scheme can dynamically +load. + +@heading Synopsis + +Examples of the new syntax: + +@example +(C-include "prhello") + +@group +(malloc (C-sizeof "GdkEvent")) +@myresult{} #[alien 42 0x081afc60] +@end group + +@group +(C-> @verb{"#@42"} "GdkEvent any type") +@myresult{} 14 +@end group + +(C->= @verb{"#@42"} "GdkEvent any type" 13) + +@group +(C-enum "GDK_MAP") +@myresult{} 14 +@end group + +@group +(C-enum "GdkEventType" 14) +@myresult{} |GDK_MAP| +@end group + +@group +(C-sizeof "GdkColor") +@myresult{} 12 +@end group + +@group +(C-offset "GdkColor blue") +@myresult{} 8 +@end group + +@group +(C-array-loc @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_NORMAL")) +@myresult{} #[alien 44 0x081afc60] @r{; New alien.} +@end group + +@group +(C-array-loc! @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_PRELIGHT")) +@myresult{} #[alien 43 0x081afc78] @r{; Modified alien.} +@end group + +@group +(C-call "gtk_window_new" retval args @dots{}) +@myresult{} #!unspecific +@end group + +@group +(C-callback "delete_event") +@myresult{} #[alien-function 44 Scm_delete_event] +@end group + +@group +(C-callback (lambda (window event) @dots{})) +@myresult{} 13 @r{; A fixnum registration ID.} +@end group + +@end example +@comment The C-array-loc! example assumes 2 GdkColors are 6 words, #x18bytes. +@comment 0x081afc78 - 0x081afc60 = 0x18 + +@heading Summary + +A Scheme-like declaration of a toolkit's C functions, constants, and +data types is given in a case sensitive @file{.cdecl} file. The C +declarations look like this: + +@smallexample +(extern (* GtkWidget) @r{; gtk+-2.4.0/gtk/gtkwindow.h} + gtk_window_new + (type GtkWindowType)) + +(typedef GtkWindowType @r{; gtk+-2.4.0/gtk/gtkenums.h} + (enum + (GTK_WINDOW_TOPLEVEL) + (GTK_WINDOW_POPUP))) +@end smallexample + +The @strong{@code{c-generate}} procedure reads these declarations and +writes three files: @file{@i{library}-types.bin} (a fasdump of the +parsed declarations), @file{@i{library}-const.c} (a C program that +prints C constants and struct offsets), and @file{@i{library}-shim.c} +(trampoline functions adapting Scheme procedure application to C +function call). The @file{-const.c} program generates a +@file{-const.scm} file, which can be syntaxed to produce a +@file{-const.bin} file. + +@smallexample +(load-option 'FFI) +(c-generate "prhello" "#include ") +@end smallexample + +The @file{-types.bin} and @file{-const.bin} files together provide +the information needed to expand @code{C-...} syntax, and are only +needed at syntax time. The @file{-shim.c} file is used at run time, +linked into the Scheme machine or a shared object. @ref{Compiling and +Linking}, which describes these files in more detail, and shows how +they might be built and installed. + +@smallexample +(C-include "prhello") +@end smallexample + +The @strong{@code{C-include}} syntax loads the @file{-types.bin} and +@file{-const.bin} files @emph{at syntax time}. It should appear +at the top level of any file containing @code{C-...} syntax, or be +evaluated in the syntax environment of such code. + +The @strong{@code{C-call}} syntax arranges to invoke a callout +trampoline. Arguments to the trampoline can be integers, floats, +strings or aliens (non-heap pointers, to C data structures, +@pxref{Alien Data}). + +@smallexample +(let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_window_new" alien type) + (if (alien-null? alien) (error "could not open new window")) + alien) +@end smallexample + +The @strong{@code{C-callback}} syntax is used when registering a +Scheme callback trampoline. The two forms of the syntax provide two +arguments for the registration function: the callback trampoline's +address, and a ``user data'' argument. When the toolkit calls the +trampoline, it must provide the fixnum-sized user data as an argument. + +@smallexample +(C-call "g_signal_connect" window "delete_event" + (C-callback "delete_event") ; @r{@i{e.g. &Scm_delete_event}} + (C-callback ; @r{@i{e.g. 314}} + (lambda (window event) + (C-call "gtk_widget_destroy" window) + 0))) +@end smallexample + +The first use of @code{C-callback} (above) expands into a callback +trampoline address --- an alien function. The second use evaluates to +a fixnum, which is associated with the given Scheme procedure. + +The @strong{@code{C->}} and @strong{@code{C->=}} syntaxes peek and +poke values into alien data structures. They take an alien and a +constant string specifying the alien data type and the member to be +accessed (if any). + +@smallexample +@group +(C-> alien "GdkRectangle y") +@expansion{} +(#[primitive c-peek-int] alien 4) +@end group + +@group +(C->= alien "GdkRectangle width" 0) +@expansion{} +(#[primitive c-poke-int] alien 8 0) +@end group +@end smallexample + +@smallexample +@group +(C-> alien "GdkEvent any type") +@expansion{} +(#[primitive c-peek-int] alien 0) +@end group +@end smallexample + +@smallexample +@group +(C-> alien "gfloat") +@expansion{} +(#[primitive c-peek-float] alien 0) +@end group +@end smallexample + +A three argument form of the syntax provides an alien to receive a +peeked pointer. This avoids consing a new alien. + +@smallexample +(C-> alien "* mumble" alien) +@end smallexample + +The above syntax is understood to say ``The data at this @code{alien} +address is a pointer to @code{mumble}. Load the mumble's address into +@code{alien}, clobbering @code{alien}'s old address.'' Note that the +pointer declaration is in reverse polish ``Scheme style'', with the +\verb|*| operator placed ahead of the target type. + +The @strong{@code{C-enum}}, @strong{@code{C-sizeof}} and +@strong{@code{C-offset}} syntaxes all +transform into integer constants. The last two transform into a padded +byte size and a byte offset respectively. + +@smallexample +@group +(C-enum "GTK_WINDOW_POPUP") +@expansion{} +1 +@end group + +@group +(C-sizeof "GdkColor") +@expansion{} +12 +@end group + +@group +(C-offset "GdkColor blue") +@expansion{} +8 +@end group + +@end smallexample + +The two element form of the @code{C-enum} syntax can be used to find +the name of a constant given its runtime value. It expects the name +of an enum type in a constant string. If the runtime (second) +argument is not one of the constants declared by that type, the +returned value is @code{#f}. + +@smallexample +@group +(C-enum "GdkEventType" (C-> @verb{"#@42"} "GdkEvent any type")) +@myresult{} +|GDK_MAP| +@end group +@end smallexample + +The @strong{@code{c-array-loc}} and @strong{@code{c-array-loc!}} +syntaxes compute the locations of C array elements. They can be used +to advance a scan pointer or locate an element by its index. The +examples in the synopsis might expand as shown here. + +@smallexample +(C-array-loc @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_NORMAL")) +@expansion{} +(alien-byte-increment @verb{"#@43"} (* (C-sizeof "GdkColor") + (C-enum "GTK_STATE_NORMAL"))) +@expansion{} +(alien-byte-increment @verb{"#@43"} 0) +@myresult{} +@verb{"#@44"} + +(C-array-loc! @verb{"#@43"} "GdkColor" (C-enum "GTK_STATE_PRELIGHT")) +@expansion{} +(alien-byte-increment! @verb{"#@43"} (* (C-sizeof "GdkColor") + (C-enum "GTK_STATE_PRELIGHT"))) +@expansion{} +(alien-byte-increment! @verb{"#@43"} 24) +@myresult{} +@verb{"#@43"} +@end smallexample + +A simple scan of characters in the wide string @code{alien} might +look like this. + +@smallexample +(let ((len (C-> alien "toolkit_string_type int_member")) + (scan (C-> alien "toolkit_string_type array_member"))) + (let loop ((n 0)) + (if (< n len) + (let ((wchar (C-> scan "wchar"))) + (process wchar) + (C-array-loc! scan "wchar" 1) + (loop (1+ n)))))) +@end smallexample + +That is a quick look at the facilities. The next section describes +the C declaration language, and the following sections examine the FFI's +syntax and runtime facilities in detail. Final sections provide an +example program and show how its dynamically loaded shim is built. + + +@node C Declarations, Alien Data, Introduction, Top +@chapter C Declarations + +A shim between Scheme and a C toolkit is specified by a case sensitive +@file{.cdecl} file containing Scheme-like declarations of all relevant +toolkit types, constants, and functions. Callback functions to be +passed to the toolkit are also specified here. + +There are some limitations on the C types that can be declared. +Basic, struct, union, enum and pointer types are allowed, but +bit-field members are not supported. C function parameters can be +basic, enum or pointer types. The return type of a C function is the +same plus @code{void}. Basically, no struct or union argument or +return types, at the moment. + +Each top-level form in the C declaration file must look like one of +these: + +@smallexample +(include "filename") +(typedef Name @var{any}) +(struct Name (Member @var{type}) @dots{}) +(union Name (Member @var{type}) @dots{}) +(enum @i{Name} (Member) @dots{}) +(extern @var{return-type} Name (param1 @var{arg-type}) @dots{}) +(callback @var{return-type} Name (param1 @var{arg-type}) @dots{}) +@end smallexample + +An enum's @i{@var{Name}} is optional. + +@var{arg-type} is currently restricted to the following forms. It is +assumed that a lone @var{Name} is defined as a type on this list: + +@smallexample +Name +@var{basics} +(* @var{any}) +(enum Name) +(enum @i{Name} (Member) @dots{}) +@end smallexample + +@var{return-type} can be either @var{arg-type} or the word @code{void}. + +@var{basics} can be any of the words: @code{char}, @code{uchar}, +@code{short}, @code{ushort}, @code{int}, @code{uint}, @code{long}, +@code{ulong}, @code{float}, or @code{double} (all lowercase). + +@var{type} includes structs and unions: + +@smallexample +@var{arg-type} +(struct Name) +(struct @i{Name} (Member @var{type}) @dots{}) +(union Name) +(union @i{Name} (Member @var{type}) @dots{}) +@end smallexample + +@var{any} is any @var{type} @emph{or} @code{void}. + +The @code{include} expression includes another @file{.cdecl} file in +the current @file{.cdecl} file. The string argument is interpreted +relative to the current file's directory. + +While the informal grammar above allows anonymous structs to be +specified for argument or member types, they are of little use outside +top-level, @i{named} struct or union declarations. The peek and poke +(@code{C->} and @code{C->=}) syntax expects a type name (e.g. +@code{"GdkEventAny"} or @code{"struct _GdkEventAny"}) before any +member names. + +@smallexample +(C-include "prhello") +@end smallexample + +The @strong{@code{C-include}} syntax takes a library name and loads +the corresponding @file{-types} and @file{-const} files at syntax +time. This makes the C types and constants available to the other +@code{C-...} syntax expanders. The form binds @code{c-includes} in +the syntax environment @i{unless} it is already defined there. Thus a +@code{(C-includes "library")} form can be placed at the top of every +file with @code{C-...} syntax, @emph{or} loaded into the syntax-time +environment of those files. + + +@node Alien Data, Alien Functions, C Declarations, Top +@chapter Alien Data + +A C data structure is represented by an alien containing the data +structure's memory address. ``Peek'' primitives are available to read +pointers and the basic C types (e.g. ints, floats) at small (fixnum) +offsets from an alien's address. They return to Scheme an alien +address, integer or flonum as appropriate. ``Poke'' primitives +do the reverse, storing pointers, integers or floats at fixnum offsets +from alien addresses. +Other procedures on aliens are @code{alien?}, +@code{alien-null?}, @code{alien-null!}, @code{copy-alien}, @code{alien=?}, +@code{alien-byte-increment}, and @code{c-peek-cstring}. Refer to +@file{ffi.pkg} in The Source for a complete list. + +The @code{C->} and @code{C->=} syntaxes apply the peek and poke +primitives to constant offsets. They expect their first argument +subform to be a constant string --- space-separated words naming a C +type and any member to be accessed. A member within a struct or union +member is specified by appending its name. For example @code{"struct +_GdkEvent any window"} would specify a peek at the @code{window} +member of the @code{any} member of the @code{struct _GdkEvent} data at +some alien address. Note that the final member's type must be a basic +C type, pointer type, or enum type. Otherwise, an error is signaled +at syntax time. + +@smallexample +@group +(C-> alien "struct _GdkEvent any window" window-alien) +@expansion{} +(#[primitive c-peek-pointer] alien 0 window-alien) +@myresult{} +#[alien 44 (* GdkWindow) 0x081afc60] +@end group +@end smallexample + +Note that in the example above, the final member has a pointer type. +In this case an extra alien argument can be provided to receive the +peeked pointer. Otherwise a new alien is created and returned. + +@heading Malloc + +The @code{malloc} procedure returns an alien that will automatically +free the malloced memory when it is garbage collected. +It can also be explicitly freed with the @code{free} procedure. The alien +address can be incremented to scan the malloced memory, then freed +(without returning it to the original, malloced address). A band +restore marks all malloced aliens as though they have been freed. + +@smallexample +(free (malloc '|GdkRectangle|)) +@end smallexample + +In general, if a callout returns a pointer to a toolkit resource that +should be freed, some care is necessary. Typically such a resource is +registered with a weak reference to a Scheme representative. When the +representative disappears (is garbage collected), the resource is +freed. The callout trampoline might cons a fresh alien and return it +to Scheme, to be registered for later freeing, but an interrupt +between the return and the registration may leave the +alien un-registered, never to be freed. + +@smallexample + (let* ((alien (make-alien))) + (c-call "library_function" alien) + ;; An interrupt or non-local exit here can drop the alien resource. + (register-alien-to-free! alien) + ...mumble... + (c-free alien)) +@end smallexample + +To close the hole a null alien can be allocated and registered +@emph{before} the callout. If something interrupts normal execution +before the callout trampoline can write to it, and the continuation is +eventually abandoned, the null alien will be swept up in the next GC, +but not erroneously freed. If the alien is dropped immediately after +the trampoline returns to Scheme, it will still be swept up and, no +longer null, properly freed. + +@smallexample + (let* ((alien (make-alien '|GdkRectangle|))) + (register-alien-to-free! alien) + ;; Prepared to free the resource whether allocated or not. + (c-call "library_function" alien) + ...mumble... + (c-free alien)) +@end smallexample + + +@node Alien Functions, Callbacks, Alien Data, Top +@chapter Alien Functions + +The @code{C-call} syntax produces code that applies @code{call-alien} +to an alien function structure --- a cache for the callout +trampoline's entry address. + +@smallexample +@group +(C-call "gtk_button_new" (make-alien '(* |GtkWidget|))) +@expansion{} +(call-alien '#[alien-function gtk_button_new] (make-alien @dots{})) +@end group +@end smallexample + +The alien function contains all the information needed to load the +callout trampoline on demand (i.e. its name and library). Once the +alien function has cached the entry address, @code{call-alien} can +invoke the trampoline (via @code{#[primitive c-call]}). The +trampoline gets its arguments off the Scheme stack, converts them to C +values, calls the C function, conses a result, and returns it to +Scheme. As a special case a function returning a pointer type +expects an extra first argument. If this argument is @code{#f}, the +return value is discarded. If the argument is an alien, the +function's return value clobbers the alien's address. This makes it +easy to grab pointers to toolkit resources without dropping them, or +avoid unnecessary consing of aliens. + +The @code{alien-function} structures are fasdumpable. The caching +mechanism invalidates the cache when a band is restored, or a +fasdumped object is fasloaded. The alien function will lookup the +trampoline entry point again on demand. + + +@node Callbacks, Compiling and Linking, Alien Functions, Top +@chapter Callbacks + +A callback declaration must include a parameter named ``ID''. The ID +argument will be used to find the Scheme callback procedure. It must +be the same ``user data'' value provided to the toolkit when the +callback was registered. For example, a callback trampoline named +@code{Scm_delete_event} might be declared like this: + +@smallexample +(callback gint + delete_event + (window (* GtkWidget)) + (event (* GdkEventAny)) + (ID gpointer)) +@end smallexample + +The callback might be registered with the toolkit like this: + +@smallexample +(C-call "g_signal_connect" window "delete_event" + (C-callback "delete_event") ; @r{@i{e.g. &Scm_delete_event}} + (C-callback ; @r{@i{e.g. 314}} + (lambda (window event) + (C-call "gtk_widget_destroy" window) + 0))) +@end smallexample + +The toolkit's registration function, @code{g_signal_connect}, would be +declared like this: + +@smallexample +(extern void + g_signal_connect + (object (* GtkObject)) + (name (* gchar)) + (CALLBACK GtkSignalFunc) + (ID gpointer)) +@end smallexample + +This function should have parameters named @code{CALLBACK} and +@code{ID}. The callout trampoline will convert the callback argument +from a Scheme alien function to an entry address. The @code{ID} argument +will be converted to a C integer and then cast to its declared type +(in this example, @code{gpointer}). + +Note that the registered callback procedures are effectively pinned. +They cannot be garbage collected. They are ``on call'' to handle +callbacks from the toolkit until they are explicitly de-registered. A +band restore automatically de-registers all callbacks. + +The callback procedures are executed like an interrupt handler. They +actually interrupt the thread executing the most recent callout, +e.g. to @code{gtk_main}. The thread runs with thread switching +disabled for the duration of the callback, and can callout to the +toolkit, which can callback again. The (nested) callbacks and nested +callouts all run in the same thread, and so will return in LIFO order +as expected by the toolkit. Note that the runtime system will not +balk at a callback procedure that calls @code{yield-thread}, waits for +I/O, sleeps, or otherwise causes a thread switch. Presumably such a +procedure has some other way of enforcing the LIFO ordering. + +The @code{outf-console} procedure is provided for debugging purposes. +It writes one or more argument strings (and @code{write}s any +non-strings) to the console and flushes, atomically, via a machine +primitive, bypassing the runtime's I/O buffering and thread switching. +Thus multiple debugging trace messages arrive on the console intact +and uninterrupted. + + +@node Compiling and Linking, Hello World, Callbacks, Top +@chapter Compiling and Linking + +The @strong{@code{c-generate}} procedure takes a library name and an +optional prefix. It reads the @file{@i{library}.cdecl} file and +writes two @file{.c} files. The prefix is included at the top of +both. It typically contains @code{#include} C pre-processor +directives required by the C library, but could include additional +shim code. Here is a short script that generates a shim for the +example ``Hello, World!'' program. + +@smallexample +(load-option 'FFI) +(c-generate "prhello" "#include ") +@end smallexample + +This script will produce three files: + +@table @file + +@item prhello-shim.c +This file contains the trampoline functions --- one for each declared +C extern or callback. It includes the @file{mit-scheme.h} header +file, found in the @code{AUXDIR} directory --- +e.g. @file{/usr/local/lib/mit-scheme/}. + +@item prhello-const.c +This file contains a C program that creates +@file{prhello-const.scm}. It is compiled and linked +as normal for programs using the toolkit, and does not depend on the +Scheme machine. It does not actually call any +toolkit functions. It just collects information from the compiler +about the declared C types and constants. + +@item prhello-types.bin +This file is a fasdumped @code{c-includes} structure containing all of +the types, constants and functions declared in the @file{.cdecl} file. + +@end table + +The following Makefile rules describe the process of building and +installing a shim for the example ``Hello, World!'' program. + +@example +@comment INCLUDE ../../src/ffi/Makefile-fragment FROM /^install-example:/ TO END +@verbatim +install-example: build-example + $(INSTALL_DATA) prhello-types.bin /usr/local/lib/mit-scheme/lib/. + $(INSTALL_DATA) prhello-const.bin /usr/local/lib/mit-scheme/lib/. + $(INSTALL_DATA) prhello-shim.so /usr/local/lib/mit-scheme/lib/. + +build-example: prhello-shim.so prhello-types.bin prhello-const.bin + +prhello-shim.so: prhello-shim.o + $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-shim.o: prhello-shim.c + $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $< + +prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl + (echo "(load-option 'FFI)"; \ + echo '(C-generate "prhello" "#include ")') \ + | mit-scheme --batch-mode + +prhello-const.bin: prhello-const.scm + echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode + +prhello-const.scm: prhello-const + ./prhello-const + +prhello-const: prhello-const.o + @rm -f $@ + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-const.o: prhello-const.c + $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $< +@end verbatim +@end example + + +@node Hello World, GNU Free Documentation License, Compiling and Linking, Top +@chapter Hello World + +This +@iftex +chapter +@end iftex +@ifnottex +node +@end ifnottex +includes the C declarations and Scheme code required to implement +Havoc Pennington's Hello World example from +@uref{http://developer.gnome.org/doc/GGAD/, GGAD}. For an extra, +Schemely treat, its @code{delete_event} callback is a Scheme procedure +closed over a binding of @code{counter} that is used to implement some +impertinent behavior. +@example +@verbatiminclude ../../src/ffi/prhello.scm +@end example + +Here are the C declarations. +@example +@verbatiminclude ../../src/ffi/prhello.cdecl +@end example + +To run the example, first build and install its shim per the example +Makefile rules in @ref{Compiling and Linking}. Then enter the +following three lines at your Scheme REPL: + +@smallexample +@verbatim + (load-option 'FFI) + (load "prhello.scm") + (hello) +@end verbatim +@end smallexample + +You might also syntax the Scheme code first. The syntactic +transformers of the FFI will again be needed. + +@smallexample +@verbatim + (load-option 'FFI) + (cf "prhello.scm") +@end verbatim +@end smallexample + +The resulting @file{prhello.com} file can be loaded and run with just +your FFI-enhanced runtime. The FFI option is no longer needed. In a +fresh mit-scheme machine, you can enter just these two lines. + +@smallexample +@verbatim + (load "prhello") + (hello) +@end verbatim +@end smallexample + + +@node GNU Free Documentation License, , Hello World, Top +@appendix GNU Free Documentation License + +@center Version 1.2, November 2002 + +@display +Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc. +51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA + +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +@end display + +@enumerate 0 +@item +PREAMBLE + +The purpose of this License is to make a manual, textbook, or other +functional and useful document @dfn{free} in the sense of freedom: to +assure everyone the effective freedom to copy and redistribute it, +with or without modifying it, either commercially or noncommercially. +Secondarily, this License preserves for the author and publisher a way +to get credit for their work, while not being considered responsible +for modifications made by others. + +This License is a kind of ``copyleft'', which means that derivative +works of the document must themselves be free in the same sense. It +complements the GNU General Public License, which is a copyleft +license designed for free software. + +We have designed this License in order to use it for manuals for free +software, because free software needs free documentation: a free +program should come with manuals providing the same freedoms that the +software does. But this License is not limited to software manuals; +it can be used for any textual work, regardless of subject matter or +whether it is published as a printed book. We recommend this License +principally for works whose purpose is instruction or reference. + +@item +APPLICABILITY AND DEFINITIONS + +This License applies to any manual or other work, in any medium, that +contains a notice placed by the copyright holder saying it can be +distributed under the terms of this License. Such a notice grants a +world-wide, royalty-free license, unlimited in duration, to use that +work under the conditions stated herein. The ``Document'', below, +refers to any such manual or work. Any member of the public is a +licensee, and is addressed as ``you''. You accept the license if you +copy, modify or distribute the work in a way requiring permission +under copyright law. + +A ``Modified Version'' of the Document means any work containing the +Document or a portion of it, either copied verbatim, or with +modifications and/or translated into another language. + +A ``Secondary Section'' is a named appendix or a front-matter section +of the Document that deals exclusively with the relationship of the +publishers or authors of the Document to the Document's overall +subject (or to related matters) and contains nothing that could fall +directly within that overall subject. (Thus, if the Document is in +part a textbook of mathematics, a Secondary Section may not explain +any mathematics.) The relationship could be a matter of historical +connection with the subject or with related matters, or of legal, +commercial, philosophical, ethical or political position regarding +them. + +The ``Invariant Sections'' are certain Secondary Sections whose titles +are designated, as being those of Invariant Sections, in the notice +that says that the Document is released under this License. If a +section does not fit the above definition of Secondary then it is not +allowed to be designated as Invariant. The Document may contain zero +Invariant Sections. If the Document does not identify any Invariant +Sections then there are none. + +The ``Cover Texts'' are certain short passages of text that are listed, +as Front-Cover Texts or Back-Cover Texts, in the notice that says that +the Document is released under this License. A Front-Cover Text may +be at most 5 words, and a Back-Cover Text may be at most 25 words. + +A ``Transparent'' copy of the Document means a machine-readable copy, +represented in a format whose specification is available to the +general public, that is suitable for revising the document +straightforwardly with generic text editors or (for images composed of +pixels) generic paint programs or (for drawings) some widely available +drawing editor, and that is suitable for input to text formatters or +for automatic translation to a variety of formats suitable for input +to text formatters. A copy made in an otherwise Transparent file +format whose markup, or absence of markup, has been arranged to thwart +or discourage subsequent modification by readers is not Transparent. +An image format is not Transparent if used for any substantial amount +of text. A copy that is not ``Transparent'' is called ``Opaque''. + +Examples of suitable formats for Transparent copies include plain +@sc{ascii} without markup, Texinfo input format, La@TeX{} input +format, @acronym{SGML} or @acronym{XML} using a publicly available +@acronym{DTD}, and standard-conforming simple @acronym{HTML}, +PostScript or @acronym{PDF} designed for human modification. Examples +of transparent image formats include @acronym{PNG}, @acronym{XCF} and +@acronym{JPG}. Opaque formats include proprietary formats that can be +read and edited only by proprietary word processors, @acronym{SGML} or +@acronym{XML} for which the @acronym{DTD} and/or processing tools are +not generally available, and the machine-generated @acronym{HTML}, +PostScript or @acronym{PDF} produced by some word processors for +output purposes only. + +The ``Title Page'' means, for a printed book, the title page itself, +plus such following pages as are needed to hold, legibly, the material +this License requires to appear in the title page. For works in +formats which do not have any title page as such, ``Title Page'' means +the text near the most prominent appearance of the work's title, +preceding the beginning of the body of the text. + +A section ``Entitled XYZ'' means a named subunit of the Document whose +title either is precisely XYZ or contains XYZ in parentheses following +text that translates XYZ in another language. (Here XYZ stands for a +specific section name mentioned below, such as ``Acknowledgements'', +``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title'' +of such a section when you modify the Document means that it remains a +section ``Entitled XYZ'' according to this definition. + +The Document may include Warranty Disclaimers next to the notice which +states that this License applies to the Document. These Warranty +Disclaimers are considered to be included by reference in this +License, but only as regards disclaiming warranties: any other +implication that these Warranty Disclaimers may have is void and has +no effect on the meaning of this License. + +@item +VERBATIM COPYING + +You may copy and distribute the Document in any medium, either +commercially or noncommercially, provided that this License, the +copyright notices, and the license notice saying this License applies +to the Document are reproduced in all copies, and that you add no other +conditions whatsoever to those of this License. You may not use +technical measures to obstruct or control the reading or further +copying of the copies you make or distribute. However, you may accept +compensation in exchange for copies. If you distribute a large enough +number of copies you must also follow the conditions in section 3. + +You may also lend copies, under the same conditions stated above, and +you may publicly display copies. + +@item +COPYING IN QUANTITY + +If you publish printed copies (or copies in media that commonly have +printed covers) of the Document, numbering more than 100, and the +Document's license notice requires Cover Texts, you must enclose the +copies in covers that carry, clearly and legibly, all these Cover +Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on +the back cover. Both covers must also clearly and legibly identify +you as the publisher of these copies. The front cover must present +the full title with all words of the title equally prominent and +visible. You may add other material on the covers in addition. +Copying with changes limited to the covers, as long as they preserve +the title of the Document and satisfy these conditions, can be treated +as verbatim copying in other respects. + +If the required texts for either cover are too voluminous to fit +legibly, you should put the first ones listed (as many as fit +reasonably) on the actual cover, and continue the rest onto adjacent +pages. + +If you publish or distribute Opaque copies of the Document numbering +more than 100, you must either include a machine-readable Transparent +copy along with each Opaque copy, or state in or with each Opaque copy +a computer-network location from which the general network-using +public has access to download using public-standard network protocols +a complete Transparent copy of the Document, free of added material. +If you use the latter option, you must take reasonably prudent steps, +when you begin distribution of Opaque copies in quantity, to ensure +that this Transparent copy will remain thus accessible at the stated +location until at least one year after the last time you distribute an +Opaque copy (directly or through your agents or retailers) of that +edition to the public. + +It is requested, but not required, that you contact the authors of the +Document well before redistributing any large number of copies, to give +them a chance to provide you with an updated version of the Document. + +@item +MODIFICATIONS + +You may copy and distribute a Modified Version of the Document under +the conditions of sections 2 and 3 above, provided that you release +the Modified Version under precisely this License, with the Modified +Version filling the role of the Document, thus licensing distribution +and modification of the Modified Version to whoever possesses a copy +of it. In addition, you must do these things in the Modified Version: + +@enumerate A +@item +Use in the Title Page (and on the covers, if any) a title distinct +from that of the Document, and from those of previous versions +(which should, if there were any, be listed in the History section +of the Document). You may use the same title as a previous version +if the original publisher of that version gives permission. + +@item +List on the Title Page, as authors, one or more persons or entities +responsible for authorship of the modifications in the Modified +Version, together with at least five of the principal authors of the +Document (all of its principal authors, if it has fewer than five), +unless they release you from this requirement. + +@item +State on the Title page the name of the publisher of the +Modified Version, as the publisher. + +@item +Preserve all the copyright notices of the Document. + +@item +Add an appropriate copyright notice for your modifications +adjacent to the other copyright notices. + +@item +Include, immediately after the copyright notices, a license notice +giving the public permission to use the Modified Version under the +terms of this License, in the form shown in the Addendum below. + +@item +Preserve in that license notice the full lists of Invariant Sections +and required Cover Texts given in the Document's license notice. + +@item +Include an unaltered copy of this License. + +@item +Preserve the section Entitled ``History'', Preserve its Title, and add +to it an item stating at least the title, year, new authors, and +publisher of the Modified Version as given on the Title Page. If +there is no section Entitled ``History'' in the Document, create one +stating the title, year, authors, and publisher of the Document as +given on its Title Page, then add an item describing the Modified +Version as stated in the previous sentence. + +@item +Preserve the network location, if any, given in the Document for +public access to a Transparent copy of the Document, and likewise +the network locations given in the Document for previous versions +it was based on. These may be placed in the ``History'' section. +You may omit a network location for a work that was published at +least four years before the Document itself, or if the original +publisher of the version it refers to gives permission. + +@item +For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve +the Title of the section, and preserve in the section all the +substance and tone of each of the contributor acknowledgements and/or +dedications given therein. + +@item +Preserve all the Invariant Sections of the Document, +unaltered in their text and in their titles. Section numbers +or the equivalent are not considered part of the section titles. + +@item +Delete any section Entitled ``Endorsements''. Such a section +may not be included in the Modified Version. + +@item +Do not retitle any existing section to be Entitled ``Endorsements'' or +to conflict in title with any Invariant Section. + +@item +Preserve any Warranty Disclaimers. +@end enumerate + +If the Modified Version includes new front-matter sections or +appendices that qualify as Secondary Sections and contain no material +copied from the Document, you may at your option designate some or all +of these sections as invariant. To do this, add their titles to the +list of Invariant Sections in the Modified Version's license notice. +These titles must be distinct from any other section titles. + +You may add a section Entitled ``Endorsements'', provided it contains +nothing but endorsements of your Modified Version by various +parties---for example, statements of peer review or that the text has +been approved by an organization as the authoritative definition of a +standard. + +You may add a passage of up to five words as a Front-Cover Text, and a +passage of up to 25 words as a Back-Cover Text, to the end of the list +of Cover Texts in the Modified Version. Only one passage of +Front-Cover Text and one of Back-Cover Text may be added by (or +through arrangements made by) any one entity. If the Document already +includes a cover text for the same cover, previously added by you or +by arrangement made by the same entity you are acting on behalf of, +you may not add another; but you may replace the old one, on explicit +permission from the previous publisher that added the old one. + +The author(s) and publisher(s) of the Document do not by this License +give permission to use their names for publicity for or to assert or +imply endorsement of any Modified Version. + +@item +COMBINING DOCUMENTS + +You may combine the Document with other documents released under this +License, under the terms defined in section 4 above for modified +versions, provided that you include in the combination all of the +Invariant Sections of all of the original documents, unmodified, and +list them all as Invariant Sections of your combined work in its +license notice, and that you preserve all their Warranty Disclaimers. + +The combined work need only contain one copy of this License, and +multiple identical Invariant Sections may be replaced with a single +copy. If there are multiple Invariant Sections with the same name but +different contents, make the title of each such section unique by +adding at the end of it, in parentheses, the name of the original +author or publisher of that section if known, or else a unique number. +Make the same adjustment to the section titles in the list of +Invariant Sections in the license notice of the combined work. + +In the combination, you must combine any sections Entitled ``History'' +in the various original documents, forming one section Entitled +``History''; likewise combine any sections Entitled ``Acknowledgements'', +and any sections Entitled ``Dedications''. You must delete all +sections Entitled ``Endorsements.'' + +@item +COLLECTIONS OF DOCUMENTS + +You may make a collection consisting of the Document and other documents +released under this License, and replace the individual copies of this +License in the various documents with a single copy that is included in +the collection, provided that you follow the rules of this License for +verbatim copying of each of the documents in all other respects. + +You may extract a single document from such a collection, and distribute +it individually under this License, provided you insert a copy of this +License into the extracted document, and follow this License in all +other respects regarding verbatim copying of that document. + +@item +AGGREGATION WITH INDEPENDENT WORKS + +A compilation of the Document or its derivatives with other separate +and independent documents or works, in or on a volume of a storage or +distribution medium, is called an ``aggregate'' if the copyright +resulting from the compilation is not used to limit the legal rights +of the compilation's users beyond what the individual works permit. +When the Document is included an aggregate, this License does not +apply to the other works in the aggregate which are not themselves +derivative works of the Document. + +If the Cover Text requirement of section 3 is applicable to these +copies of the Document, then if the Document is less than one half of +the entire aggregate, the Document's Cover Texts may be placed on +covers that bracket the Document within the aggregate, or the +electronic equivalent of covers if the Document is in electronic form. +Otherwise they must appear on printed covers that bracket the whole +aggregate. + +@item +TRANSLATION + +Translation is considered a kind of modification, so you may +distribute translations of the Document under the terms of section 4. +Replacing Invariant Sections with translations requires special +permission from their copyright holders, but you may include +translations of some or all Invariant Sections in addition to the +original versions of these Invariant Sections. You may include a +translation of this License, and all the license notices in the +Document, and any Warrany Disclaimers, provided that you also include +the original English version of this License and the original versions +of those notices and disclaimers. In case of a disagreement between +the translation and the original version of this License or a notice +or disclaimer, the original version will prevail. + +If a section in the Document is Entitled ``Acknowledgements'', +``Dedications'', or ``History'', the requirement (section 4) to Preserve +its Title (section 1) will typically require changing the actual +title. + +@item +TERMINATION + +You may not copy, modify, sublicense, or distribute the Document except +as expressly provided for under this License. Any other attempt to +copy, modify, sublicense or distribute the Document is void, and will +automatically terminate your rights under this License. However, +parties who have received copies, or rights, from you under this +License will not have their licenses terminated so long as such +parties remain in full compliance. + +@item +FUTURE REVISIONS OF THIS LICENSE + +The Free Software Foundation may publish new, revised versions +of the GNU Free Documentation License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. See +@uref{http://www.gnu.org/copyleft/}. + +Each version of the License is given a distinguishing version number. +If the Document specifies that a particular numbered version of this +License ``or any later version'' applies to it, you have the option of +following the terms and conditions either of that specified version or +of any later version that has been published (not as a draft) by the +Free Software Foundation. If the Document does not specify a version +number of this License, you may choose any version ever published (not +as a draft) by the Free Software Foundation. +@end enumerate + +@page +@appendixsec ADDENDUM: How to use this License for your documents + +To use this License in a document you have written, include a copy of +the License in the document and put the following copyright and +license notices just after the title page: + +@smallexample +@group + Copyright (C) @var{year} @var{your name}. + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. + A copy of the license is included in the section entitled ``GNU + Free Documentation License''. +@end group +@end smallexample + +If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, +replace the ``with...Texts.'' line with this: + +@smallexample +@group + with the Invariant Sections being @var{list their titles}, with + the Front-Cover Texts being @var{list}, and with the Back-Cover Texts + being @var{list}. +@end group +@end smallexample + +If you have Invariant Sections without Cover Texts, or some other +combination of the three, merge those two alternatives to suit the +situation. + +If your document contains nontrivial examples of program code, we +recommend releasing these examples in parallel under your choice of +free software license, such as the GNU General Public License, +to permit their use in free software. + +@bye diff --git a/doc/index.html b/doc/index.html index 1b8c19d24..0310a055e 100644 --- a/doc/index.html +++ b/doc/index.html @@ -1,4 +1,5 @@ + MIT/GNU Scheme Documentation @@ -15,6 +16,7 @@ The following MIT/GNU Scheme manuals are available here:
  • MIT/GNU Scheme User's Manual
  • SOS Reference Manual
  • IMAIL User's Manual
    • +
  • FFI User's Manual
    • diff --git a/src/Makefile.in b/src/Makefile.in index f28b959b4..561c0c2e8 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -62,7 +62,7 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs # **** END BOILERPLATE **** LIARC_BOOT_BUNDLES = compiler cref sf star-parser -LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin imail sos ssp xml +LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES) @@ -73,11 +73,11 @@ EDDIR = $(AUXDIR)/edwin all: @ALL_TARGET@ all-native: compile-microcode - @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler + @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler --batch-mode $(MAKE) build-bands all-liarc: - @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler + @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler --batch-mode $(MAKE) compile-liarc-bundles build-bands compile-microcode: diff --git a/src/README.txt b/src/README.txt index 1373f4ada..9858d9eee 100644 --- a/src/README.txt +++ b/src/README.txt @@ -12,7 +12,7 @@ functional subsystems. The core subsystem consists of these directories: * "microcode" contains the C code that is used to build the executable - programs "scheme" and "bchscheme". + program "scheme". * "runtime" contains the bulk of the run-time library, including almost everything documented in the reference manual. @@ -33,6 +33,9 @@ The core subsystem consists of these directories: * "xml" contains support for XML and XHTML I/O. +* "ffi" provides syntax for calling foreign (C) functions and + manipulating alien (C) data. + The compiler subsystem consists of these three directories: * "sf" contains a program that translates Scheme source code to an @@ -725,7 +728,6 @@ That being said, ... tar xzf mit-scheme-7.7.1-ix86-gnu-linux.tar.gz # If not already cp -fp scheme-7.7.1/src/microcode/scheme bin/. - cp -fp scheme-7.7.1/src/microcode/bchscheme bin/. Clobbering/replacing the copies of the binary release microcode file(s) shouldn't disturb you since, presumably, the main reason diff --git a/src/Setup.sh b/src/Setup.sh index 5479ecde4..83a6f68ca 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -35,7 +35,7 @@ fi . etc/functions.sh -INSTALLED_SUBDIRS="cref edwin imail sf sos ssp star-parser xml" +INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml" OTHER_SUBDIRS="6001 compiler runtime win32 xdoc microcode" # lib @@ -46,6 +46,8 @@ maybe_link lib/include ../microcode maybe_link lib/optiondb.scm ../etc/optiondb.scm maybe_link lib/runtime ../runtime maybe_link lib/utabmd.bin ../microcode/utabmd.bin +maybe_link lib/mit-scheme.h ../microcode/pruxffi.h +maybe_link lib/ffi ../ffi for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do echo "setting up ${SUBDIR}" diff --git a/src/configure.ac b/src/configure.ac index d50e5f9e3..92887611a 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -70,6 +70,7 @@ Makefile compiler/Makefile cref/Makefile edwin/Makefile +ffi/Makefile imail/Makefile runtime/Makefile sf/Makefile @@ -90,7 +91,7 @@ if test x${enable_native_code} = xc; then for BN in star-parser; do (cd lib; rm -f ${BN}; ${LN_S} ../${BN} .) done - for BUNDLE in 6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml; do + for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml; do SO=${BUNDLE}.so (cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .) done diff --git a/src/etc/compile.scm b/src/etc/compile.scm index 25cfb4d9a..2ef741f46 100644 --- a/src/etc/compile.scm +++ b/src/etc/compile.scm @@ -39,7 +39,7 @@ USA. (with-working-directory-pathname "sos" (lambda () (load "load"))) - (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp"))) + (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi"))) (define (compile-boot-dirs compile-dir) (compile-cref compile-dir) diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 0a86e177a..20f8e2dc5 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -48,11 +48,11 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg run_cmd ln -s machines/"${MDIR}" compiler/machine run_cmd ln -s machine/compiler.pkg compiler/. -BUNDLES="6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml" +BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml" : ${MIT_SCHEME_EXE='mit-scheme'} -run_cmd ${MIT_SCHEME_EXE} --heap 4000 < ${SUBDIR}/Makefile.in - cat ${SUBDIR}/Makefile-fragment >> ${SUBDIR}/Makefile.in + cat etc/std-makefile-prefix ${SUBDIR}/Makefile-fragment \ + > ${SUBDIR}/Makefile.in if test -f ${SUBDIR}/Makefile-bundle; then cat ${SUBDIR}/Makefile-bundle >> ${SUBDIR}/Makefile.in rm -f ${SUBDIR}/Makefile-bundle diff --git a/src/etc/optiondb.scm b/src/etc/optiondb.scm index 990c7c128..40af3d62f 100644 --- a/src/etc/optiondb.scm +++ b/src/etc/optiondb.scm @@ -94,6 +94,9 @@ USA. (define-load-option 'CREF (guarded-system-loader '(cross-reference) "cref")) +(define-load-option 'FFI + (guarded-system-loader '(ffi) "ffi")) + (define-load-option 'IMAIL (guarded-system-loader '(edwin imail) "imail")) diff --git a/src/ffi/Makefile-fragment b/src/ffi/Makefile-fragment new file mode 100644 index 000000000..4390b5777 --- /dev/null +++ b/src/ffi/Makefile-fragment @@ -0,0 +1,48 @@ +#-*-Makefile-*- +# $Id: $ +# ffi/Makefile-fragment + +TARGET_DIR = $(AUXDIR)/ffi + +install: + rm -rf $(DESTDIR)$(TARGET_DIR) + $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR) + $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) ffi-*.pkd $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) load.scm $(DESTDIR)$(TARGET_DIR)/. + +clean-example: + rm -rf prhello-shim.* prhello-types.bin + rm -rf prhello-const prhello-const.* + +install-example: build-example + $(INSTALL_DATA) prhello-types.bin /usr/local/lib/mit-scheme/lib/. + $(INSTALL_DATA) prhello-const.bin /usr/local/lib/mit-scheme/lib/. + $(INSTALL_DATA) prhello-shim.so /usr/local/lib/mit-scheme/lib/. + +build-example: prhello-shim.so prhello-types.bin prhello-const.bin + +prhello-shim.so: prhello-shim.o + $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-shim.o: prhello-shim.c + $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $< + +prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl + (echo "(load-option 'FFI)"; \ + echo '(C-generate "prhello" "#include ")') \ + | mit-scheme --batch-mode + +prhello-const.bin: prhello-const.scm + echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode + +prhello-const.scm: prhello-const + ./prhello-const + +prhello-const: prhello-const.o + @rm -f $@ + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-const.o: prhello-const.c + $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $< diff --git a/src/ffi/cdecls.scm b/src/ffi/cdecls.scm new file mode 100644 index 000000000..fd23c56a4 --- /dev/null +++ b/src/ffi/cdecls.scm @@ -0,0 +1,367 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C Declarations +;;; package: (ffi syntax) + + +(define-structure (c-includes (conc-name c-includes/) + (constructor make-c-includes (library)) + ;; To be fasdump/loadable. + (type vector) (named 'c-includes)) + library ; String naming the DLL of trampolines (the shim). + (files '()) ;; Included file names and their modtimes when read. + (type-names '()) ;; E.g. ((gpointer (* mumble) . "prhello.cdecl")...) + (structs '()) ;; E.g. ((|_GdkColor| (struct ...) . "gdkcolor.cdecl")...) + (unions '()) ;; E.g. ((|_GdkEvent| (union ...) . "gdkevents.cdecl")...) + (enums '()) ;; E.g. ((|_cairo_status| (enum ...) . "cairo.cdecl")...) + (enum-constants'()) ;;E.g. ((|CAIRO_STATUS_SUCCESS| . "prhello.cdecl")...) + (callouts '()) ;; E.g. ((|gdk_window_new| . #)...) + (callbacks '()) ;; E.g. ((|delete_event| . #)...) + (enum-values '()) ;; E.g. ((|CAIRO_STATUS_SUCCESS| . 0)...) from groveler. + (struct-values'()) ;; List of struct info from the groveler: + ;; (((sizeof |GdkColor|) . 12) + ;; ((offset |GdkColor| pixel) . (0 . int)) + ;; ((offset |GdkColor| red) . (4 . short)) + ;; ((offset |GdkColor| green) . (6 . short)) + ;; ((offset |GdkColor| blue) . (8 . short)) + ;; ((sizeof (struct |_GdkColor|)) . 12) + ;; ((offset (struct |_GdkColor|) pixel) . (0 . int)) + ;; ((offset (struct |_GdkColor|) red) . (4 . short)) + ;; ((offset (struct |_GdkColor|) green) . (6 . short)) + ;; ((offset (struct |_GdkColor|) blue) . (8 . short))...) + ) + +(define (include-cdecls library) + ;; Toplevel entry point for the generator. + ;; Returns a new C-INCLUDES structure. + (let ((includes (make-c-includes library)) + (cwd (if load/loading? + (directory-pathname (current-load-pathname)) + (working-directory-pathname)))) + (include-cdecl-file library cwd cwd includes) + includes)) + +(define c-include-noisily? #t) +(define current-filename) + +(define (include-cdecl-file filename cwd twd includes) + ;; Adds the C declarations in FILENAME to INCLUDES. Interprets + ;; FILENAME relative to CWD (current working directory). + ;; Abbreviates namestrings under TWD (topmost working, build directory). + + (let* ((pathname (merge-pathnames + (pathname-default-type filename "cdecl") cwd)) + (new-cwd (directory-pathname pathname)) + (namestring (enough-namestring pathname twd)) + (modtime (file-modification-time-indirect namestring)) + (files (c-includes/files includes))) + (if (not (assoc namestring files)) + (fluid-let ((current-filename namestring)) + (set-c-includes/files! includes + (cons (cons namestring modtime) files)) + + (define (kernel) + (call-with-input-file namestring + (lambda (inport) + (let loop () + (let ((form (parse-object inport read-environment))) + (if (not (eof-object? form)) + (begin + (include-cdecl form new-cwd twd includes) + (loop)))))))) + + (if c-include-noisily? + (with-notification (lambda (port) + (write-string "Including " port) + (write-string namestring port)) + kernel) + (kernel)))))) + +(define read-environment + (make-top-level-environment '(*PARSER-CANONICALIZE-SYMBOLS?*) '(#f))) + +(define (include-cdecl form cwd twd includes) + ;; Add a top-level C declaration to INCLUDES. If it is an + ;; include, interprete the included filenames relative to CWD + ;; (current working directory). + (if (not (and (pair? form) (symbol? (car form)) (pair? (cdr form)))) + (cerror form "malformed top level C declaration")) + (let ((keyword (car form)) + (name (cadr form)) + (rest (cddr form))) + (case keyword + ((|include|) + (for-each (lambda (file) (include-cdecl-file file cwd twd includes)) + (cdr form))) + ((|typedef|) (include-typedef form name rest includes)) + ((|struct|) (include-struct form name rest includes)) + ((|union|) (include-union form name rest includes)) + ((|enum|) (include-enum form name rest includes)) + ((|extern|) (include-function form name rest includes)) + ((|callback|) (include-function form name rest includes)) + (else (cerror form "unknown top level keyword")))) + unspecific) + +(define (include-typedef form name rest includes) + ;; Add a top-level (typedef NAME . REST) C declaration to INCLUDES. + (if (not (and (symbol? name) + (pair? rest) (null? (cdr rest)))) + (cerror form "malformed typedef declaration")) + (let* ((ctypes (c-includes/type-names includes)) + (entry (assq name ctypes))) + (if entry (cerror form "already defined in " (cddr entry))) + (let* ((ctype (valid-ctype (car rest) includes)) + (new (cons name (cons ctype current-filename)))) + (set-c-includes/type-names! includes (cons new ctypes)) + unspecific))) + +(define (include-struct form name members includes) + ;; Add a top-level (struct NAME . MEMBERS) C declaration to INCLUDES. + (if (not (and (symbol? name) (pair? members) (list? members))) + (cerror form "malformed named struct declaration")) + (let* ((structs (c-includes/structs includes)) + (entry (assq name structs))) + (if entry (cerror form "already defined in " (cddr entry))) + (let* ((anon (cons 'STRUCT + (map (lambda (member) + (valid-struct-member member includes)) + members))) + (info (cons anon current-filename))) + (set-c-includes/structs! + includes (cons (cons name info) structs)) + unspecific))) + +(define (valid-struct-member form includes) + ;; Returns (NAME . CTYPE) given a MEMBER C declaration. + ;; Adds any internal named struct/union/enum types to INCLUDES. + (if (not (and (pair? form) (symbol? (car form)) + (pair? (cdr form)) (null? (cddr form)))) + (cerror form "malformed struct member")) + (let ((name (car form)) + (ctype (valid-ctype (cadr form) includes))) + (cons name ctype))) + +(define (include-union form name members includes) + ;; Add a top-level (union NAME . MEMBERS) C declaration to INCLUDES. + (if (not (and (symbol? name) (pair? members) (list? members))) + (cerror form "malformed named union declaration")) + (let* ((unions (c-includes/unions includes)) + (entry (assq name unions))) + (if entry (cerror form "already defined in " (cddr entry))) + (let* ((anon (cons 'UNION + (map (lambda (member) + (valid-union-member member includes)) + members))) + (info (cons anon current-filename))) + (set-c-includes/unions! + includes (cons (cons name info) unions)) + unspecific))) + +(define (valid-union-member form includes) + ;; Returns (NAME . CTYPE) given a MEMBER C declaration. + ;; Adds any internal named struct/union/enum types to INCLUDES. + (if (not (and (pair? form) (symbol? (car form)) + (pair? (cdr form)) (null? (cddr form)))) + (cerror form "malformed union member")) + (let ((name (car form)) + (ctype (valid-ctype (cadr form) includes))) + (cons name ctype))) + +(define (include-enum form name constants includes) + ;; Add a top-level (enum NAME . CONSTANTS) C declaration to INCLUDES. + ;; Also accepts an unnamed (enum . CONSTANTS) C declaration. + (if (not (list? constants)) + (cerror form "malformed named enum declaration")) + (if (symbol? name) + (let* ((enums (c-includes/enums includes)) + (entry (assq name enums))) + (if entry (cerror form "already defined in " (cddr entry))) + (let* ((anon (cons 'ENUM + (valid-enum-constants constants includes))) + (info (cons anon current-filename))) + (set-c-includes/enums! + includes (cons (cons name info) enums)))) + (valid-enum-constants (cdr form) includes))) + +(define (valid-enum-constants forms includes) + ;; Returns a list of (NAME) pairs for each enum constant declaration + ;; in FORMS. Also adds enum constants to INCLUDES. + (let loop ((forms forms)) + (if (null? forms) '() + (let ((name (valid-enum-constant (car forms) includes))) + (cons name (loop (cdr forms))))))) + +(define (valid-enum-constant form includes) + ;; Returns (NAME), the name of the validated enum constant declared + ;; by FORM. Immediately adds the constant to the list in INCLUDES, + ;; checking that it is not already there. + (if (not (and (pair? form) (symbol? (car form)) + ;; 1 or 2 args + (or (null? (cdr form)) + (and (pair? (cdr form)) (null? (cddr form)))))) + (cerror form "malformed enum constant declaration")) + (if (pair? (cdr form)) + (cwarn (cadr form) "ignored enum value")) + (let* ((name (car form)) + (constants (c-includes/enum-constants includes)) + (entry (assq name constants))) + (if entry (cerror form "already defined in " (cdr entry))) + (set-c-includes/enum-constants! + includes (cons (cons name current-filename) constants)) + (list name))) + +(define (include-function form rettype rest includes) + ;; Callouts/backs have much in common here, thus this shared + ;; procedure, which uses the keyword still at the head of FORM to + ;; munge the correct alist in INCLUDES. + (if (not (and (pair? rest) (symbol? (car rest)) + (list? (cdr rest)))) + (cerror form "malformed "(symbol-name (car form))" declaration")) + (let* ((name (car rest)) + (params (cdr rest)) + (others (if (eq? 'EXTERN (car form)) + (c-includes/callouts includes) + (c-includes/callbacks includes))) + (entry (assq name others))) + (if entry (cerror form "already defined in " + (alien-function/filename (cdr entry)))) + (let ((new (cons name + (make-alien-function + (symbol-name name) + (c-includes/library includes) + (valid-ctype rettype includes) + (valid-params params includes) + current-filename)))) + (if (eq? 'EXTERN (car form)) + (set-c-includes/callouts! includes (cons new others)) + (set-c-includes/callbacks! includes (cons new others))) + unspecific))) + +(define (valid-params forms includes) + ;; Returns a list -- (NAME CTYPE) for each parameter declaration + ;; form in FORMS. + (if (null? forms) '() + (cons (valid-param (car forms) includes) + (valid-params (cdr forms) includes)))) + +(define (valid-param form includes) + ;; Returns (NAME CTYPE) after validating FORM. + (if (not (and (pair? form) (symbol? (car form)) + (pair? (cdr form)) + (null? (cddr form)))) + (cerror form "malformed parameter declaration")) + (let ((name (car form)) + (ctype (valid-ctype (cadr form) includes))) + (list name ctype))) + +(define (valid-ctype form includes) + ;; Returns a valid ctype expression, a copy of FORM. Modifies + ;; INCLUDES with any internal struct/union/enum declarations. + (cond ((symbol? form) form) + ((ctype/pointer? form) form) + ((ctype/const? form) + (list 'CONST (valid-ctype (cadr form) includes))) + + ((ctype/struct-name? form) form) + ((ctype/struct-anon? form) + (cons 'STRUCT (map (lambda (member) + (valid-struct-member member includes)) + (cdr form)))) + ((ctype/struct-named? form) + (include-struct form (cadr form) (cddr form) includes) + (list 'STRUCT (cadr form))) + + ((ctype/union-name? form) form) + ((ctype/union-anon? form) + (cons 'UNION (map (lambda (member) + (valid-union-member member includes)) + (cdr form)))) + ((ctype/union-named? form) + (include-union form (cadr form) (cddr form)) + (list 'UNION (cadr form))) + + ((ctype/enum-name? form) form) + ((ctype/enum-anon? form) + (cons 'ENUM (valid-enum-constants (cdr form) includes))) + ((ctype/enum-named? form) + (include-enum form (cadr form) (cddr form) includes) + (list 'ENUM (cadr form))) + + ((ctype/array? form) + (list 'ARRAY + (valid-ctype (ctype-array/element-type form) includes) + (ctype-array/size form))) + + (else (cerror form "bogus C type declaration")))) + +(define condition-type:cerror + (make-condition-type + 'ffi-cdecl-error + condition-type:error + '(FORM FILENAME MESSAGE) + (lambda (condition port) + (write-string "Error: " port) + (write-string (access-condition condition 'MESSAGE) port) + (write-string ":" port) + (write-string (access-condition condition 'FILENAME) port) + (write-string ": " port) + (write (access-condition condition 'FORM) port)))) + +(define cerror + (let ((signaller (condition-signaller condition-type:cerror + '(FORM FILENAME MESSAGE) + standard-error-handler))) + (named-lambda (cerror form message . args) + (signaller form current-filename + (apply string-append + (map (lambda (obj) + (if (string? obj) obj (write-to-string obj))) + (cons message args))))))) + +(define condition-type:cwarn + (make-condition-type + 'ffi-cdecl-warning + condition-type:warning + '(FORM FILENAME MESSAGE) + (lambda (condition port) + (write-string (access-condition condition 'MESSAGE) port) + (write-string ":" port) + (write-string (access-condition condition 'FILENAME) port) + (write-string ": " port) + (write (access-condition condition 'FORM) port)))) + +(define cwarn + (let ((signaller (condition-signaller condition-type:cwarn + '(FORM FILENAME MESSAGE) + standard-warning-handler))) + (named-lambda (cwarn form message . args) + (with-simple-restart 'MUFFLE-WARNING "Ignore warning." + (lambda () + (signaller form current-filename + (apply string-append + (map (lambda (obj) + (if (string? obj) obj (write-to-string obj))) + (cons message args))))))))) \ No newline at end of file diff --git a/src/ffi/compile.scm b/src/ffi/compile.scm new file mode 100644 index 000000000..1bbc2b140 --- /dev/null +++ b/src/ffi/compile.scm @@ -0,0 +1,30 @@ +#| -*-Scheme-*- + +$Id: $ + +Compile the FFI system. |# + +(load-option 'CREF) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (let ((ffi-files '("ctypes" "cdecls" "syntax" "generator"))) + + ;; Build an empty package for use at syntax-time. + ;; The imports should bind ucode-primitive (ffi). + (if (not (name->package '(FFI))) + (let ((package-set (package-set-pathname "ffi"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "ffi")) + (construct-packages-from-file (fasload package-set)))) + + ;; Syntax in (ffi). + (fluid-let ((sf/default-syntax-table (->environment '(ffi))) + (sf/default-declarations + (cons '(usual-integrations) sf/default-declarations))) + (for-each (lambda (f) (sf-conditionally f #t)) ffi-files)) + + ;; Cross-check. + (cref/generate-constructors "ffi" 'ALL) + + ;; Compile. + (for-each compile-file ffi-files)))) \ No newline at end of file diff --git a/src/ffi/ctypes.scm b/src/ffi/ctypes.scm new file mode 100644 index 000000000..53eb4d46c --- /dev/null +++ b/src/ffi/ctypes.scm @@ -0,0 +1,294 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C Types and C Type Simplification +;;; package: (ffi syntax) + + +;;; C Types + +(define (ctype/basic? ctype) + ;; Returns #t iff CTYPE is a basic C type, e.g. char, int or double. + (and (symbol? ctype) + (not (eq? ctype '*)) + (assq ctype peek-poke-primitives))) + +(define (ctype/pointer? ctype) + ;; Returns #t iff CTYPE is a pointer type, e.g. (* GtkWidget). + (or (eq? ctype '*) + (and (pair? ctype) (eq? '* (car ctype)) + (pair? (cdr ctype)) (null? (cddr ctype))))) + +(define ctype-pointer/target-type cadr) + +(define (ctype/void? ctype) + (eq? ctype 'VOID)) + +(define (ctype/const? ctype) + (and (pair? ctype) (eq? 'CONST (car ctype)) + (pair? (cdr ctype)) (null? (cddr ctype)))) + +(define ctype-const/qualified-type cadr) + +(define (ctype/struct-name? ctype) + ;; Returns #t iff CTYPE is a struct name, e.g. (struct _GValue). + (and (pair? ctype) (eq? 'STRUCT (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (null? (cddr ctype)))) + +(define (ctype/struct-anon? ctype) + ;; Returns #t iff CTYPE is an anonymous struct + ;; -- (struct (MEMBER . TYPE)...). + (and (pair? ctype) (eq? 'STRUCT (car ctype)) + (pair? (cdr ctype)) (pair? (cadr ctype)))) + +(define (ctype/struct-named? ctype) + ;; Returns #t iff CTYPE is a named struct + ;; -- (struct NAME (MEMBER VALUE)...). + (and (pair? ctype) (eq? 'STRUCT (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (pair? (cddr ctype)) (pair? (caddr ctype)))) + +(define (ctype/struct-defn? ctype) + (or (ctype/struct-anon? ctype) + (ctype/struct-named? ctype))) + +(define (ctype-struct-defn/members ctype) + (cond ((ctype/struct-anon? ctype) (cdr ctype)) + ((ctype/struct-named? ctype) (cddr ctype)) + (else (error "Bogus C struct type:" ctype)))) + +(define (ctype/struct? ctype) + (or (ctype/struct-name? ctype) (ctype/struct-defn? ctype))) + +(define (ctype-struct/name ctype) + ;; This works on a struct name as well as definitions. + (and (or (and (eq? 'STRUCT (car ctype)) + (pair? (cdr ctype))) + (error:wrong-type-argument ctype "C struct type" 'ctype-struct/name)) + (symbol? (cadr ctype)) + (cadr ctype))) + +(define (make-ctype-struct name members) + (if name + (cons* 'STRUCT name members) + (cons 'STRUCT members))) + +(define (ctype/union-name? ctype) + ;; Returns #t iff CTYPE is a union name, e.g. (union _GdkEvent). + (and (pair? ctype) (eq? 'UNION (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (null? (cddr ctype)))) + +(define (ctype/union-anon? ctype) + ;; Returns #t iff CTYPE is an anonymous union + ;; -- (union (MEMBER . TYPE)...). + (and (pair? ctype) (eq? 'UNION (car ctype)) + (pair? (cdr ctype)) (pair? (cadr ctype)))) + +(define (ctype/union-named? ctype) + ;; Returns #t iff CTYPE is a named union + ;; -- (union NAME (MEMBER TYPE)...). + (and (pair? ctype) (eq? 'UNION (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (pair? (cddr ctype)) (pair? (caddr ctype)))) + +(define (ctype/union-defn? ctype) + (or (ctype/union-anon? ctype) + (ctype/union-named? ctype))) + +(define (ctype-union-defn/members ctype) + (cond ((ctype/union-named? ctype) (cddr ctype)) + ((ctype/union-anon? ctype) (cdr ctype)) + (else (error "Bogus C union type:" ctype)))) + +(define (ctype/union? ctype) + (or (ctype/union-name? ctype) (ctype/union-defn? ctype))) + +(define (ctype-union/name ctype) + ;; This works on union names as well as definitions. + (and (or (and (eq? 'UNION (car ctype)) + (pair? (cdr ctype))) + (error:wrong-type-argument ctype "C union type" 'ctype-union/name)) + (symbol? (cadr ctype)) + (cadr ctype))) + +(define (make-ctype-union name members) + (if name + (cons* 'UNION name members) + (cons 'UNION members))) + +(define (ctype/enum-name? ctype) + ;; Returns #t iff CTYPE is an enum name, e.g. (enum GdkEventType). + (and (pair? ctype) (eq? 'ENUM (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (null? (cddr ctype)))) + +(define (ctype/enum-anon? ctype) + ;; Returns #t iff CTYPE is an anonymous enum + ;; -- (enum (CONSTANT . VALUE)...). + (and (pair? ctype) (eq? 'ENUM (car ctype)) + (pair? (cdr ctype)) (pair? (cadr ctype)))) + +(define (ctype/enum-named? ctype) + ;; Returns #t iff CTYPE is a named enum + ;; -- (enum NAME (CONSTANT . VALUE)...). + (and (pair? ctype) (eq? 'ENUM (car ctype)) + (pair? (cdr ctype)) (symbol? (cadr ctype)) + (pair? (cddr ctype)) (pair? (caddr ctype)))) + +(define (ctype/enum-defn? ctype) + (or (ctype/enum-anon? ctype) + (ctype/enum-named? ctype))) + +(define (ctype-enum-defn/constants ctype) + (cond ((ctype/enum-named? ctype) (cddr ctype)) + ((ctype/enum-anon? ctype) (cdr ctype)) + (else (error "Bogus C enum type:" ctype)))) + +(define (ctype/enum? ctype) + (or (ctype/enum-name? ctype) (ctype/enum-defn? ctype))) + +(define (ctype-enum/name ctype) + ;; This works on enum names as well as definitions. + (and (or (and (eq? 'ENUM (car ctype)) + (pair? (cdr ctype))) + (error:wrong-type-argument ctype "C enum type" 'ctype-enum/name)) + (symbol? (cadr ctype)) + (cadr ctype))) + +(define (make-ctype-enum name constants) + (if name + (cons* 'ENUM name constants) + (cons 'ENUM constants))) + +(define (ctype/array? ctype) + ;; Returns #t iff CTYPE is an array type, e.g. (ARRAY (* GtkWidget) 5). + (and (pair? ctype) (eq? 'ARRAY (car ctype)) + (pair? (cdr ctype)) + (or (null? (cddr ctype)) + (and (pair? (cddr ctype)) (null? (cdddr ctype)))))) + +(define ctype-array/element-type cadr) + +(define (ctype-array/size ctype) + (and (pair? (cddr ctype)) (caddr ctype))) + +(define (make-ctype-array ctype size) + (list 'ARRAY ctype size)) + +(define (ctype/primitive-accessor ctype) + ;; Returns the primitive to use when reading from CTYPE, a basic ctype. + (let ((entry (assq ctype peek-poke-primitives))) + (and entry + (car (cdr entry))))) + +(define (ctype/primitive-modifier ctype) + ;; Returns the primitive to use when writing to CTYPE, a basic ctype. + (let ((entry (assq ctype peek-poke-primitives))) + (and entry + (cadr (cdr entry))))) + +(define peek-poke-primitives + ;; Alist: basic type names x (prim-access prim-modify). + ;; + ;; A couple type converters in generator.scm depend on handling + ;; ALL of this list. + `((char ,(ucode-primitive c-peek-char 2) ,(ucode-primitive c-poke-char 3)) + (uchar ,(ucode-primitive c-peek-uchar 2) ,(ucode-primitive c-poke-uchar 3)) + (short ,(ucode-primitive c-peek-short 2) ,(ucode-primitive c-poke-short 3)) + (ushort ,(ucode-primitive c-peek-ushort 2) ,(ucode-primitive c-poke-ushort 3)) + (int ,(ucode-primitive c-peek-int 2) ,(ucode-primitive c-poke-int 3)) + (uint ,(ucode-primitive c-peek-uint 2) ,(ucode-primitive c-poke-uint 3)) + (long ,(ucode-primitive c-peek-long 2) ,(ucode-primitive c-poke-long 3)) + (ulong ,(ucode-primitive c-peek-ulong 2) ,(ucode-primitive c-poke-ulong 3)) + (float ,(ucode-primitive c-peek-float 2) ,(ucode-primitive c-poke-float 3)) + (double ,(ucode-primitive c-peek-double 2) ,(ucode-primitive c-poke-double 3)) + (* ,(ucode-primitive c-peek-pointer 3),(ucode-primitive c-poke-pointer 3)) + )) + + +;;; C Type Lookup + +(define (definite-ctype ctype includes) + ;; Returns a definite C type equivalent to CTYPE. If CTYPE is a + ;; name, e.g. + ;; + ;; |GdkColor|, (struct |_GdkColor|), (union |_GdkEvent|) + ;; + ;; returns the definite C type of its definition per INCLUDES. A + ;; definite C type is a basic type name, array or pointer type, or + ;; struct, union or enum names or definitions. + + (let loop ((stack '()) + (ctype ctype)) + (cond ((or (ctype/basic? ctype) + (ctype/void? ctype) + (eq? 'ENUM ctype) + (eq? '* ctype)) ctype) + ((symbol? ctype) + (if (memq ctype stack) + (error "Circular definition of C type:" (car (last-pair stack)))) + (let ((entry (assq ctype (c-includes/type-names includes)))) + (if (not entry) + (error "Unknown type:" ctype) + (loop (cons ctype stack) (cadr entry))))) + ((ctype/const? ctype) + (loop stack (ctype-const/qualified-type ctype))) + ((or (ctype/array? ctype) + (ctype/pointer? ctype) + (ctype/struct? ctype) + (ctype/union? ctype) + (ctype/enum? ctype)) ctype) + (else + (error:wrong-type-argument ctype "a C type" 'definite-ctype))))) + +(define (ctype-definition ctype includes) + (let ((type (definite-ctype ctype includes))) + (cond ((or (ctype/basic? type) + (ctype/void? type) + (ctype/array? type) + (ctype/pointer? type) + (ctype/struct-defn? type) + (ctype/union-defn? type) + (ctype/enum-defn? type) + ;; Enum constants are not enumerated in -const.scm files. + (eq? 'ENUM type)) type) + ((ctype/struct-name? type) + (let ((entry (assq (cadr type) (c-includes/structs includes)))) + (if (not entry) + (error "Unknown type:" type) + (cadr entry)))) + ((ctype/union-name? type) + (let ((entry (assq (cadr type) (c-includes/unions includes)))) + (if (not entry) + (error "Unknown type:" type) + (cadr entry)))) + ((ctype/enum-name? type) + (let ((entry (assq (cadr type) (c-includes/enums includes)))) + (if (not entry) + (error "Unknown type:" type) + (cadr entry)))) + (else (error "Unexpected C type:" ctype))))) \ No newline at end of file diff --git a/src/ffi/ed-ffi.scm b/src/ffi/ed-ffi.scm new file mode 100644 index 000000000..c58e44901 --- /dev/null +++ b/src/ffi/ed-ffi.scm @@ -0,0 +1,12 @@ +#| -*- Scheme -*- + +$Id: $ + +FFI buffer packaging info |# + +(standard-scheme-find-file-initialization + '#( + ("ctypes" (ffi)) + ("cdecls" (ffi)) + ("syntax" (ffi)) + ("generator" (ffi generate)))) \ No newline at end of file diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg new file mode 100644 index 000000000..f4524674c --- /dev/null +++ b/src/ffi/ffi.pkg @@ -0,0 +1,38 @@ +#| -*-Scheme-*- + +$Id: $ + +FFI System Packaging |# + +(global-definitions "../runtime/runtime") + +(define-package (ffi) + (parent ()) + (files "ctypes" "cdecls" "syntax") + (import (runtime) + ucode-primitive) + (import (runtime ffi) + make-alien-function + alien-function/filename) + (export () + c-include + load-c-includes + c-include-noisily? + c-> + c->= + c-enum + c-call + c-callback + c-sizeof + c-offset + c-array-loc + c-array-loc!)) + +(define-package (ffi generator) + (parent (ffi)) + (files "generator") + (import (runtime ffi) + alien-function/parameters + alien-function/return-type) + (export () + c-generate)) \ No newline at end of file diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm new file mode 100644 index 000000000..fe34e3386 --- /dev/null +++ b/src/ffi/generator.scm @@ -0,0 +1,691 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Trampoline Generator +;;; package: (ffi generator) + + +(define c-generate-noisily? #t) + +(define (c-generate library #!optional prefix) + (let ((prefix (if (default-object? prefix) "" prefix)) + (includes (include-cdecls library))) + (guarantee-string prefix 'c-generate) + (let ((shim.c (string-append library "-shim.c"))) + (if c-generate-noisily? + (with-notification + (lambda (port) + (write-string "Generating " port) + (write shim.c port)) + (lambda () + (gen-trampolines shim.c prefix includes))) + (gen-trampolines shim.c prefix includes))) + (let ((const.c (string-append library "-const.c"))) + (if c-generate-noisily? + (with-notification + (lambda (port) + (write-string "Generating " port) + (write (enough-namestring const.c) port)) + (lambda () + (gen-groveler const.c prefix includes))) + (gen-groveler const.c prefix includes))) + (let ((types.bin (string-append library "-types.bin"))) + (fasdump includes types.bin (not c-generate-noisily?))))) + +(define (gen-trampolines pathname prefix includes) + (with-output-to-file pathname + (lambda () + (write-string + (string-append + "/* -*-C-*- */ + +#include + +/* Prefix */ +" prefix " +/* End Prefix */ +")) + (gen-callout-trampolines includes) + (if (null? (c-includes/callbacks includes)) + unspecific + (gen-callback-trampolines includes))))) + + +;;; Callout Trampolines + +(define (gen-callout-trampolines includes) + (for-each + (lambda (name.alienf) + (with-simple-restart 'CONTINUE "Continue generating callout trampolines." + (lambda () + (bind-condition-handler + (list condition-type:simple-error) + (lambda (condition) + (let ((restart (find-restart 'CONTINUE condition)) + (msg (access-condition condition 'MESSAGE)) + (irr (access-condition condition 'IRRITANTS))) + (apply warn msg irr) + (if restart + (invoke-restart restart)))) + (lambda () + (gen-callout-trampoline (car name.alienf) (cdr name.alienf) + includes)))))) + (reverse (c-includes/callouts includes)))) + +(define (gen-callout-trampoline name alien includes) + (let* ((ret-ctype (alien-function/return-type alien)) + (params (alien-function/parameters alien)) + (ret-var (callout-return-variable params))) + + ;; The second part first. + (let ((tos-var (new-variable "tos" params))) + (let ((declares + (callout-part2-decls tos-var ret-var ret-ctype includes)) + (restores + (callout-restores name tos-var ret-var ret-ctype includes)) + (return + (callout-return tos-var ret-var ret-ctype includes)) + (name (symbol-name name))) + (write-string + (string-append " +SCM +Scm_continue_"name" (void) +\{ + /* Declare. */" declares " + + /* Restore. */" restores " + + /* Return. */" return " +}")))) + + ;; The first part second. + (let ((declares (callout-part1-decls ret-var ret-ctype params includes)) + (inits (callout-inits ret-ctype params includes)) + (call (callout-call name ret-var ret-ctype params includes)) + (saves (callout-saves ret-var ret-ctype includes))) + (let ((name (symbol-name name))) + (write-string + (string-append " +void +Scm_"name" (void) +\{ + /* Declare. */" declares " + + /* Init. */" inits " + + /* Call. */ + callout_seal (&Scm_continue_"name");" call " + + /* Save. */ + callout_unseal (&Scm_continue_"name");" saves " + + callout_continue (&Scm_continue_"name"); + /* NOTREACHED */ +} +")))))) + +(define (matching-param? string params) + (find-matching-item params + (lambda (param) (string=? string (symbol-name (car param)))))) + +(define (new-variable root-name params) + ;; Returns a name (string) for a variable that must be distinct from + ;; those in the PARAMS alist. + (let loop ((n 0)) + (let ((name (string-append root-name (number->string n)))) + (if (not (matching-param? name params)) + name + (if (> n 9) + (error "Could not generate a unique variable:" root-name) + (loop (1+ n))))))) + +(define (callout-part2-decls tos-var ret-var ret-ctype includes) + ;; Returns a multi-line string declaring the variables to be used in + ;; the second part of a callout trampoline. See the Owner's Manual. + (let ((ctype (definite-ctype ret-ctype includes)) + (decl (decl-string ret-ctype))) + (string-append " + char * "tos-var";" + (if (not (ctype/void? ctype)) (string-append " + "decl" "ret-var";") "") " + SCM "ret-var"s;"))) + +(define (callout-restores name tos-var ret-var ret-ctype includes) + (let* ((ctype (definite-ctype ret-ctype includes)) + (tramp2 (string-append "&Scm_continue_" (symbol-name name))) + (ret-decl (decl-string ret-ctype))) + (string-append " + "tos-var" = callout_lunseal ("tramp2");" + (if (not (ctype/void? ctype)) (string-append " + CSTACK_LPOP ("ret-decl", "ret-var", "tos-var");") "")))) + +(define (callout-return tos-var ret-var ret-ctype includes) + (let ((ctype (definite-ctype ret-ctype includes))) + (string-append + (if (ctype/void? ctype) + (string-append " + "ret-var"s = unspecific();") + (string-append " + "ret-var"s = "(callout-return-converter ctype)" ("ret-var");")) " + callout_pop ("tos-var"); + return ("ret-var"s);"))) + +(define (callout-part1-decls ret-var ret-ctype params includes) + (let ((ctype (definite-ctype ret-ctype includes)) + (ret-decl (decl-string ret-ctype))) + (string-append + (if (not (ctype/void? ctype)) + (string-append " + "ret-decl" "ret-var";") + "") + (apply string-append (let loop ((params params)) + (if (null? params) '() + (cons + (let* ((param (car params)) + (name (symbol-name (car param))) + (type (cadr param)) + (decl (decl-string type))) + (string-append " + "decl" "name";")) + (loop (cdr params))))))))) + +(define (callout-inits ret-ctype params includes) + ;; Returns a multi-line string in C syntax for the Init section. + (let* ((alien-ret-arg? (ctype/pointer? (definite-ctype ret-ctype includes))) + (nargs + ;; (c-call 1:alien-function 2:ret-alien 3:arg1) + ;; (c-call 1:alien-function 2:arg1) + (number->string (+ (length params) (if alien-ret-arg? 2 1))))) + (string-append " + check_number_of_args ("nargs");" + (apply string-append + (let loop ((params params) + (n (if alien-ret-arg? 3 2))) + (if (null? params) '() + (cons + (let* ((param (car params)) + (name (car param)) + (ctype (cadr param)) + (funcast (callout-arg-converter name ctype includes)) + (name (symbol-name name)) + (num (number->string n))) + (string-append " + "name" = "funcast" ("num");")) + (loop (cdr params) (1+ n))))))))) + +(define (callout-saves ret-var ret-ctype includes) + (if (not (ctype/void? (definite-ctype ret-ctype includes))) + (string-append " + CSTACK_PUSH ("(decl-string ret-ctype)", "ret-var");") + "")) + +(define (callout-call name ret-var ret-ctype params includes) + ;; Returns a multi-line string in C syntax for the Call section. + (let ((name (symbol-name name)) + (args (decorated-string-append + "" ", " "" (map (lambda (param) (symbol-name (car param))) + params)))) + (if (not (ctype/void? (definite-ctype ret-ctype includes))) + (string-append " + "ret-var" = "name" ("args");") + (string-append " + "name" ("args");")))) + +(define (callout-arg-converter name arg-ctype includes) + ;; Returns the name of the C function that takes an argument index + ;; and returns it as the C type ARG-CTYPE. May have a cast + ;; expression at the beginning. Handles args named CALLBACK and ID + ;; specially. + (let ((ctype (definite-ctype arg-ctype includes)) + (decl (decl-string arg-ctype))) + (cond ((eq? name '|CALLBACK|) + (string-append "("decl") arg_alien_entry")) + ((eq? name '|ID|) + (string-append "("decl") arg_long")) + ((ctype/pointer? ctype) + (string-append "("decl") arg_pointer")) + ((ctype/enum? ctype) "arg_long") + ((ctype/basic? ctype) + (case ctype + ((CHAR SHORT INT LONG) "arg_long") + ((UCHAR USHORT UINT ULONG) "arg_ulong") + ((FLOAT DOUBLE) "arg_double") + (else (error "Unexpected parameter type:" arg-ctype)))) + (else (error "Unexpected parameter type:" arg-ctype))))) + +(define (callout-return-converter ctype) + ;; Returns the name of a C function that converts from the definite + ;; C type CTYPE to the analogous Scheme object. Note that the + ;; pointer converter, pointer_to_scm, returns pointers via c-call's + ;; second argument. + (cond ((ctype/pointer? ctype) "pointer_to_scm") + ((ctype/enum? ctype) "ulong_to_scm") + ((ctype/basic? ctype) + (case ctype + ((CHAR SHORT INT LONG) "long_to_scm") + ((UCHAR USHORT UINT ULONG) "ulong_to_scm") + ((FLOAT DOUBLE) "double_to_scm") + ((VOID) #f) + (else (error "Unexpected return type:" ctype)))) + (else (error "Unexpected return type:" ctype)))) + +(define (callout-return-variable params) + ;; Returns a name (string) for a variable that will hold the return + ;; value. Checks for two name collisions with the PARAMS, e.g. ret0 + ;; and ret0s, the latter being the SCM version of the return value. + (let loop ((n 0)) + (let* ((ns (number->string n)) + (name1 (string-append "ret" ns)) + (name2 (string-append "ret" ns "s"))) + (if (and (not (matching-param? name1 params)) + (not (matching-param? name2 params))) + name1 + (if (> n 9) + (error "Could not generate a unique ret variable.") + (loop (1+ n))))))) + +(define (decl-string ctype) + ;; Returns a string in C syntax declaring the C type CTYPE. + ;; E.g. given (* |GtkWidget|), returns "GtkWidget *". + (cond ((eq? ctype '*) "void*") + ((eq? ctype 'uchar) "unsigned char") + ((eq? ctype 'ushort) "unsigned short") + ((eq? ctype 'uint) "unsigned int") + ((eq? ctype 'ulong) "unsigned long") + ((symbol? ctype) (symbol-name ctype)) + ((ctype/pointer? ctype) + (string-append (decl-string (ctype-pointer/target-type ctype)) + " *")) + ((ctype/const? ctype) + (string-append "const " + (decl-string (ctype-const/qualified-type ctype)))) + ((ctype/struct-name? ctype) + (string-append "struct " (symbol-name (ctype-struct/name ctype)))) + ((ctype/union-name? ctype) + (string-append "union " (symbol-name (ctype-union/name ctype)))) + ((ctype/enum-name? ctype) + (string-append "enum " (symbol-name (ctype-enum/name ctype)))) + (else + (error "Could not generate a C type declaration:" ctype)))) + + +;;; Callback Trampolines + +(define (gen-callback-trampolines includes) + (for-each + (lambda (name.alienf) + (with-simple-restart 'CONTINUE "Continue generating callback trampolines." + (lambda () + (bind-condition-handler + (list condition-type:simple-error) + (lambda (condition) + (let ((restart (find-restart 'CONTINUE condition)) + (msg (access-condition condition 'MESSAGE)) + (irr (access-condition condition 'IRRITANTS))) + (apply warn msg irr) + (if restart + (invoke-restart restart)))) + (lambda () + (gen-callback-trampoline (car name.alienf) (cdr name.alienf) + includes)))))) + (reverse (c-includes/callbacks includes)))) + +(define (gen-callback-trampoline name alien includes) + (let ((ret-ctype (alien-function/return-type alien)) + (params (alien-function/parameters alien))) + + ;; The second part first. + (let ((args-var (new-variable "arglist" params)) + (tos-var (new-variable "tos" params))) + (let ((declares (callback-decls params)) + (restores (callback-restores params tos-var)) + (constructs (callback-conses params args-var includes)) + (name (symbol-name name))) + (write-string + (string-append " +static void +Scm_kernel_"name" (void) +\{ + /* Declare. */"declares" + SCM "args-var"; + char * "tos-var"; + + /* Init. */ + "tos-var" = callback_lunseal (&Scm_kernel_"name");"restores" + + /* Construct. */ + "args-var" = empty_list();"constructs" + callback_run_handler ((int)ID, "args-var"); + + callback_return ("tos-var"); +}")))) + + ;; The first part second. + (let ((arglist (arglist params)) + (saves (callback-saves params)) + (return (callback-return ret-ctype includes)) + (ret-decl (decl-string ret-ctype)) + (name (symbol-name name))) + (write-string + (string-append + " +"ret-decl" +Scm_"name" ("arglist") +\{"saves" + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_"name");"return" +} +"))))) + +(define (callback-decls params) + ;; Returns a multi-line string declaring the variables to be used in + ;; the second (inner, kernel) part of a callback trampoline. + (apply string-append (map (lambda (param) + (let ((decl (decl-string (cadr param))) + (name (symbol-name (car param)))) + (string-append " + "decl" "name";"))) + params))) + +(define (callback-restores params tos-var) + ;; Returns a multi-line string setting the params from the C data stack. + (apply string-append (map (lambda (param) + (let ((name (symbol-name (car param))) + (decl (decl-string (cadr param)))) + (string-append " + CSTACK_LPOP ("decl", "name", "tos-var");"))) + params))) + +(define (callback-conses params args-var includes) + ;; Returns a multi-line string constructing the arglist. + (apply string-append + (map (lambda (param) + (let ((name (car param)) + (ctype (cadr param))) + (if (eq? name '|ID|) + "" + (let ((name (symbol-name name))) + (let ((construction + (callback-arg-cons name ctype includes))) + (string-append " + "args-var" = cons ("construction", "args-var");")))))) + (reverse params)))) + +(define (arglist params) + (decorated-string-append + "" ", " "" ;prefix, infix, suffix + (map (lambda (param) + (string-append (decl-string (cadr param)) + " " (symbol-name (car param)))) + params))) + +(define (callback-saves params) + (apply string-append + (map (lambda (param) + (let ((name (symbol-name (car param))) + (ctype (cadr param))) + (string-append " + CSTACK_PUSH ("(decl-string ctype)", "name");"))) + (reverse params)))) + +(define (callback-return ret-type includes) + ;; Returns a multi-line string that returns from a callback + ;; trampoline with a value of type RET-TYPE, converted from + ;; val_register. + (let ((funcast (callback-return-converter ret-type includes))) + (if (not funcast) " + return;" + (string-append " + return ("funcast" ());")))) + +(define (callback-arg-cons arg-name arg-ctype includes) + ;; Returns a function call that applies the appropriate Scheme + ;; constructor to the ARG-CTYPE variable ARG-NAME. + (let ((ctype (definite-ctype arg-ctype includes))) + (if (ctype/pointer? ctype) + (string-append "cons_alien((void*)"arg-name")") + (let ((func (callout-return-converter ctype))) + (string-append func"("arg-name")"))))) + +(define (callback-return-converter ret-type includes) + ;; Returns the name of the C function that takes no arguments and + ;; returns the interpreter's VAL register as the C type RET-CTYPE. + (let ((ctype (definite-ctype ret-type includes))) + (cond ((ctype/pointer? ctype) + (string-append "("(decl-string ret-type)")pointer_value")) + ((ctype/enum? ctype) "long_value") + ((ctype/void? ctype) #f) + ((ctype/basic? ctype) + (case ctype + ((CHAR SHORT INT LONG) "long_value") + ((UCHAR USHORT UINT ULONG) "ulong_value") + ((FLOAT DOUBLE) "double_value") + (else (error "Unexpected return type:" ctype)))) + (else (error "Unexpected return type:" ctype))))) + + +;;; Groveler + +(define (gen-groveler pathname prefix includes) + (with-output-to-file pathname + (lambda () + (write-string + (string-append + "/* -*-C-*- */ + +/* Prefix */ +"prefix" +/* End Prefix */ +" (basics-grovel-func) (enums-grovel-func includes))) + (flush-output) + (let* ((structs (gen-struct-grovel-funcs includes)) + (unions (gen-union-grovel-funcs includes))) + (let ((library (c-includes/library includes))) + (write-string + (string-append " +int +main (void) +\{ + FILE * out = fopen (\""library"-const.scm\", \"w\"); + if (out == NULL) { + perror (\"could not open "library"-const.scm\"); + return 1; + } + fprintf (out, \"'( ;; "library" constants\\n\"); + fprintf (out, \" ( ;; enum member values\\n\"); + grovel_enums(out); + fprintf (out, \" )\\n\"); + fprintf (out, \" ( ;; struct values\\n\"); + grovel_basics(out);")) + (for-each (lambda (name) (write-string (string-append " + "name" (out);"))) structs) + (for-each (lambda (name) (write-string (string-append " + "name" (out);"))) unions) + (write-string + (string-append " + fprintf (out, \" ))\\n\"); + if (fclose (out)) { + perror (\"could not close "library"-const.scm\"); + return 1; + } + return 0; +} +"))))))) + +(define (basics-grovel-func) + (string-append " +void +grovel_basics (FILE * out) +\{" + (apply string-append + (map (lambda (entry) + (let* ((name (car entry)) + (decl (decl-string name)) + (name (symbol-name name))) + (string-append " + fprintf (out, \" ((sizeof "name") . %d)\\n\", sizeof ("decl"));"))) + peek-poke-primitives)) + " +\} +")) + +(define (enums-grovel-func includes) + (string-append + " +void +grovel_enums (FILE * out) +\{" + (apply string-append + (map (lambda (constant) + (let ((name (symbol-name (car constant)))) + (string-append " + fprintf (out, \" (|"name"| . %ld)\\n\", ((long)"name"));"))) + (c-includes/enum-constants includes))) + " +\} +")) + +(define (gen-struct-grovel-funcs includes) + ;; Returns the names of the generated functions. + (append-map*! + (map (lambda (name.info) + ;; The named structs, top-level OR internal. + (let ((name (list 'STRUCT (car name.info)))) + (gen-struct-union-grovel-func name includes))) + (c-includes/structs includes)) + (lambda (name.info) + ;; Typedefs giving names to struct types. + (let* ((name (car name.info)) + (ctype (definite-ctype name includes))) + (if (ctype/struct? ctype) + (list (gen-struct-union-grovel-func name includes)) + '()))) + (c-includes/type-names includes))) + +(define (gen-union-grovel-funcs includes) + ;; Returns the names of the generated functions. + (append-map*! + (map (lambda (name.info) + ;; The named unions, top-level OR internal. + (let ((name (list 'UNION (car name.info)))) + (gen-struct-union-grovel-func name includes))) + (c-includes/unions includes)) + (lambda (name.info) + ;; Typedefs giving names to union types. + (let* ((name (car name.info)) + (ctype (definite-ctype name includes))) + (if (ctype/union? ctype) + (list (gen-struct-union-grovel-func name includes)) + '()))) + (c-includes/type-names includes))) + +(define (gen-struct-union-grovel-func name includes) + ;; Generate C code for a grovel_NAME function. + (let ((fname (cond ((ctype/struct-name? name) + (string-append "grovel_struct_" + (symbol-name (ctype-struct/name name)))) + ((ctype/union-name? name) + (string-append "grovel_union_" + (symbol-name (ctype-union/name name)))) + ((symbol? name) + (string-append "grovel_type_" (symbol-name name))) + (else (error "Unexpected name:" name)))) + (ctype (definite-ctype name includes)) + (decl (decl-string name)) + (_ (lambda args (for-each write-string args)))) + (let ((key (list 'SIZEOF name))) + (_ " +void +"fname" (FILE * out) +\{ + "decl" S; + fprintf (out, \" (")(write key)(_" . %d)\\n\", sizeof ("decl"));")) + (for-each-member-path + ctype includes + (lambda (path brief-type) + (let ((path (decorated-string-append + "" "." "" (map symbol-name path))) + (key (cons* 'OFFSET name path))) + (_ " + fprintf (out, \" (")(write key)(_" %d . ")(write brief-type)(_")\\n\", (char*)&(S."path") - (char*)&S);")))) + (_ " +\} +") + fname)) + +(define (for-each-member-path ctype includes receiver) + ;; Calls RECEIVER with a path and an abbreviated type for each + ;; member (and nested member) of the struct or union CTYPE (a C + ;; struct or union type). Each path is a list of member names + ;; (symbols) -- one name for immediate members, multiple names for + ;; nested members. An abbreviated type is a Ctype, but is 'ENUM if + ;; the actual type is (ENUM ...). + + (let ((type (ctype-definition ctype includes))) + (cond ((ctype/struct-defn? type) + (let ((stack (list ctype))) + (for-each (lambda (name.type) + (for-each-member-path* + name.type stack includes receiver)) + (ctype-struct-defn/members type)))) + ((ctype/union-defn? type) + (let ((stack (list ctype))) + (for-each (lambda (name.type) + (for-each-member-path* + name.type stack includes receiver)) + (ctype-union-defn/members type)))) + (else + (error "Unexpected Ctype to for-each-member-path:" ctype))))) + +(define (for-each-member-path* name.type stack includes receiver) + (let ((name (car name.type)) + (type (cdr name.type))) + (let ((ctype (ctype-definition type includes))) + (if (member ctype stack) + (error "Circular definition of C type:" (car (last-pair stack)))) + (cond ((or (ctype/basic? ctype) + (ctype/pointer? ctype) + (ctype/array? ctype)) + (receiver (list name) type)) + ((ctype/enum? ctype) + (receiver (list name) 'ENUM)) + ((ctype/struct-defn? ctype) + (receiver (list name) type) + (let ((new-stack (cons type stack))) + (for-each (lambda (name.type) + (for-each-member-path* + name.type new-stack includes + (lambda (path type) + (receiver (cons name path) type)))) + (ctype-struct-defn/members ctype)))) + ((ctype/union-defn? ctype) + (receiver (list name) type) + (let ((new-stack (cons type stack))) + (for-each (lambda (name.type) + (for-each-member-path* + name.type new-stack includes + (lambda (path type) + (receiver (cons name path) type)))) + (ctype-union-defn/members ctype)))) + (else (error "Unexpected C type from ctype-definition:" ctype)))))) \ No newline at end of file diff --git a/src/ffi/load.scm b/src/ffi/load.scm new file mode 100644 index 000000000..1c713c6d3 --- /dev/null +++ b/src/ffi/load.scm @@ -0,0 +1,10 @@ +#| -*-Scheme-*- + +$Id: $ + +Load the FFI system. |# + +(with-loader-base-uri (system-library-uri "ffi/") + (lambda () + (load-package-set "ffi"))) +(add-subsystem-identification! "FFI" '(0 1)) \ No newline at end of file diff --git a/src/ffi/prhello.cdecl b/src/ffi/prhello.cdecl new file mode 100644 index 000000000..3eda4476d --- /dev/null +++ b/src/ffi/prhello.cdecl @@ -0,0 +1,86 @@ +#| -*-Scheme-*- + +C declarations for prhello.scm. |# + + +(typedef gint int) +(typedef guint uint) +(typedef gchar char) +(typedef gboolean gint) +(typedef gpointer (* mumble)) + +(extern void + gtk_init + (argc (* int)) + (argv (* (* (* char))))) + +(extern (* GtkWidget) + gtk_window_new + (type GtkWindowType)) + +(typedef GtkWindowType + (enum + (GTK_WINDOW_TOPLEVEL) + (GTK_WINDOW_POPUP))) + +(extern (* GtkWidget) + gtk_button_new) + +(extern (* GtkWidget) + gtk_label_new + (str (* (const char)))) + +(extern void + gtk_container_add + (container (* GtkContainer)) + (widget (* GtkWidget))) + +(extern void + gtk_window_set_title + (window (* GtkWindow)) + (title (* (const gchar)))) + +(extern void + gtk_container_set_border_width + (container (* GtkContainer)) + (border_width guint)) + +(extern void + gtk_widget_show_all + (widget (* GtkWidget))) + +(extern void + g_signal_connect + (object (* GtkObject)) + (name (* gchar)) + (CALLBACK GtkSignalFunc) + (ID gpointer)) + +(typedef GtkSignalFunc (* mumble)) + +(callback gboolean + delete_event + (window (* GtkWidget)) + (event (* GdkEventAny)) + (ID gpointer)) + +(callback void + clicked + (widget (* GtkWidget)) + (ID gpointer)) + +(extern void + gtk_widget_destroy + (widget (* GtkWidget))) + +(extern (* (const gchar)) + gtk_label_get_text + (label (* GtkLabel))) + +(extern void + gtk_label_set_text + (label (* GtkLabel)) + (str (* (const char)))) + +(extern void gtk_main) +(extern void gtk_main_quit) diff --git a/src/ffi/prhello.scm b/src/ffi/prhello.scm new file mode 100644 index 000000000..7aaf1614f --- /dev/null +++ b/src/ffi/prhello.scm @@ -0,0 +1,57 @@ +#| -*-Scheme-*- + +$Id: $ + +This is Havoc Pennington's Hello World example from GGAD, in the raw +FFI. Note that no arrangements have been made to de-register the +callbacks. |# + +(declare (usual-integrations)) + +(C-include "prhello") + +(define (hello) + (C-call "gtk_init" 0 null-alien) + (let ((window (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_window_new" alien + (C-enum "GTK_WINDOW_TOPLEVEL")) + (if (alien-null? alien) (error "Could not create window.")) + alien)) + (button (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_button_new" alien) + (if (alien-null? alien) (error "Could not create button.")) + alien)) + (label (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_label_new" alien "Hello, World!") + (if (alien-null? alien) (error "Could not create label.")) + alien))) + (C-call "gtk_container_add" button label) + (C-call "gtk_container_add" window button) + (C-call "gtk_window_set_title" window "Hello") + (C-call "gtk_container_set_border_width" button 10) + (let ((counter 0)) + (C-call "g_signal_connect" window "delete_event" + (C-callback "delete_event") ;trampoline + (C-callback ;callback ID + (lambda (w e) + (outf-console ";Delete me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) + (begin + (C-call "gtk_main_quit") + 0) + 1)))) + (C-call "g_signal_connect" button "clicked" + (C-callback "clicked") ;trampoline + (C-callback ;callback ID + (lambda (w) + (let ((gstring (make-alien '(* |gchar|)))) + (C-call "gtk_label_get_text" gstring label) + (let ((text (c-peek-cstring gstring))) + (C-call "gtk_label_set_text" label + (list->string (reverse! (string->list text)))))) + unspecific)))) + (C-call "gtk_widget_show_all" window) + (C-call "gtk_main") + window)) \ No newline at end of file diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm new file mode 100644 index 000000000..9425ad590 --- /dev/null +++ b/src/ffi/syntax.scm @@ -0,0 +1,510 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Syntax Expanders +;;; package: (ffi syntax) + + +;;; C-include Syntax + +(define-syntax C-include + ;; (C-include "library") ===> #f + (sc-macro-transformer + (lambda (form usage-env) + (call-with-destructured-c-include-form + form + (lambda (library) + (let ((ienv (syntactic-environment->environment usage-env))) + (if (and (environment-bound? ienv 'C-INCLUDES) + (environment-assigned? ienv 'C-INCLUDES)) + (let ((value (environment-lookup ienv 'C-INCLUDES)) + (err (lambda (msg val) + (error (string-append + "C-includes is already bound, " msg) val)))) + (if (c-includes? value) + (if (string=? (c-includes/library value) library) + #f + (err "to a different library:" + (c-includes/library value))) + (err "but not to a c-include structure:" value))) + (begin + (environment-define ienv 'C-INCLUDES (load-c-includes library)) + #f)))))))) + +(define (call-with-destructured-c-include-form form receiver) + ;; Calls RECEIVER with the library. + (if (null? (cdr form)) (serror form "a library name is required")) + (let ((library (cadr form))) + (if (not (string? library)) + (serror form "the 1st arg must be a string")) + (if (not (null? (cddr form))) + (serror form "too many args")) + (receiver library))) + +(define (load-c-includes library) + (let* ((lib (merge-pathnames + library (system-library-directory-pathname "lib"))) + (name (pathname-name lib)) + (const (pathname-new-name lib (string-append name "-const"))) + (types (pathname-new-name lib (string-append name "-types"))) + (includes (fasload types)) + (comment (fasload const)) + (enums.struct-values + (if (comment? comment) (comment-expression comment) + (error:wrong-type-datum comment "a fasl comment")))) + (warn-new-cdecls includes) + (set-c-includes/enum-values! includes (car enums.struct-values)) + (set-c-includes/struct-values! includes (cadr enums.struct-values)) + includes)) + +(define (warn-new-cdecls includes) + (for-each + (lambda (file.modtime) + (let ((read-modtime (cdr file.modtime)) + (this-modtime (file-modification-time (car file.modtime)))) + (if (and this-modtime (< read-modtime this-modtime)) + (warn "new source file:" (car file.modtime))))) + (c-includes/files includes))) + + +;;; C-> and C->= Syntaxes + +(define-syntax C-> + ;; (C-> event "GdkEvent any type") + ;; ===> (#[primitive c-peek-uint] event 14) + ;; (C-> event "GdkEvent any window" window) + ;; ===> (#[primitive c-peek-pointer] event 4 window) + (sc-macro-transformer + (lambda (form usage-env) + (expand-c->-syntax #f form usage-env)))) + +(define-syntax C->= + ;; (C->= event "GdkEvent any type" (C-enum "GDK_MAP")) + ;; ===> (#[primitive c-poke-uint] event 14) + ;; (C->= event "GdkEvent any window" window) + ;; ===> (#[primitive c-poke-pointer] event 4 window) + (sc-macro-transformer + (lambda (form usage-env) + (expand-c->-syntax #t form usage-env)))) + +(define (expand-c->-syntax poke? whole-form usage-env) + (call-with-destructured-c->-form + whole-form + (lambda (alien-form type-member-spec value-form) + (let ((includes (find-c-includes usage-env)) + (alien-form (close-syntax alien-form usage-env)) + (value-form (and value-form (close-syntax value-form usage-env)))) + (call-with-initial-ctype + type-member-spec whole-form + (lambda (ctype member-spec) + (let ((type (ctype-definition ctype includes))) + (cond + ((or (ctype/basic? type) + (ctype/pointer? type) + (ctype/array? type) + (ctype/enum-defn? type)) + (if (null? member-spec) + (if poke? + (expand-poke type alien-form 0 value-form whole-form) + (expand-peek type alien-form 0 value-form whole-form)) + (let ((meta-type (cond ((ctype/basic? type) "basic") + ((ctype/pointer? type) "pointer") + ((ctype/array? type) "array") + ((ctype/enum-defn? type) "enum") + (else "")))) + (serror whole-form meta-type " types have no members")))) + ((or (ctype/struct-defn? type) + (ctype/union-defn? type)) + (if (null? member-spec) + (serror whole-form "cannot peek a whole struct") + (let ((entry (assoc (cons* 'OFFSET ctype member-spec) + (c-includes/struct-values includes)))) + (if (not entry) (serror whole-form "no such member")) + (let ((offset (cadr entry)) + (type (cddr entry))) + (let ((ctype (ctype-definition type includes))) + (if poke? + (expand-poke ctype alien-form offset + value-form whole-form) + (expand-peek ctype alien-form offset + value-form whole-form))))))) + (poke? + (serror whole-form "cannot poke C type " ctype)) + (else + (serror whole-form "cannot peek C type " ctype)))))))))) + +(define (expand-poke ctype alien-form offset value-form whole-form) + (if (not value-form) (serror whole-form "missing value (3rd) arg")) + (cond ((ctype/basic? ctype) + (let ((prim (or (ctype/primitive-modifier ctype) + (serror whole-form "cannot poke basic type " ctype)))) + `(,prim ,alien-form ,offset ,value-form))) + ((ctype/pointer? ctype) + (let ((prim (ucode-primitive c-poke-pointer 3))) + `(,prim ,alien-form ,offset ,value-form))) + ((ctype/array? ctype) + (serror whole-form "cannot poke a whole array")) + ((or (ctype/enum? ctype) (eq? ctype 'ENUM)) + (let ((prim (ucode-primitive c-poke-uint 3))) + `(,prim ,alien-form ,offset ,value-form))) + (else (error "unexpected C type for poking" ctype)))) + +(define (expand-peek ctype alien-form offset value-form whole-form) + (cond ((ctype/basic? ctype) + (if value-form (serror whole-form "ignoring extra (3rd) arg")) + (let ((prim (or (ctype/primitive-accessor ctype) + (serror whole-form "cannot peek basic type " ctype)))) + `(,prim ,alien-form ,offset))) + ((ctype/pointer? ctype) + `(,(ucode-primitive c-peek-pointer 3) + ,alien-form ,offset ,(or value-form '(MAKE-ALIEN)))) + ((ctype/array? ctype) + (if value-form + `(LET ((VALUE ,value-form)) + (COPY-ALIEN-ADDRESS! VALUE ,alien-form) + (ALIEN-BYTE-INCREMENT! VALUE ,offset) + VALUE) + `(ALIEN-BYTE-INCREMENT ,alien-form ,offset))) + ((or (ctype/enum? ctype) (eq? ctype 'ENUM)) + `(,(ucode-primitive c-peek-uint 2) ,alien-form ,offset)) + (else (error "unexpected C type for peeking" ctype)))) + +(define (call-with-destructured-c->-form form receiver) + ;; Calls RECEIVER with ALIEN, SPEC and VALUE (or #f) as in these forms: + ;; + ;; (C-> ALIEN SPEC) VALUE = #f + ;; (C-> ALIEN SPEC* VALUE) SPEC* specifies a pointer-type member + ;; (C->= ALIEN SPEC VALUE) + ;; + (let ((len (length form))) + (if (< len 3) (serror form "too few args")) + (if (> len 4) (serror form "too many args")) + (let ((alien-form (cadr form)) + (type-member-spec (caddr form)) + (value-form (and (= 4 len) (cadddr form)))) + (if (not (string? type-member-spec)) + (serror form "2nd arg must be a string")) + (let ((type-member-spec (map string->symbol + (burst-string type-member-spec #\space #t)))) + (if (null? type-member-spec) + (serror form "2nd arg is an empty string")) + (receiver alien-form type-member-spec value-form))))) + + +;;; C-enum Syntax + +(define-syntax C-enum + ;; (C-enum "GDK_MAP") + ;; ===> 14 + ;; (C-enum "GdkEventType" 14) + ;; ===> GDK_MAP + ;; (C-enum "GdkEventType" FORM) + ;; ===> (C-enum-name FORM '|GdkEventType| + ;; '((|GDK_NOTHING| . -1) (|GDK_DELETE| . 0)...)) + (sc-macro-transformer + (lambda (form usage-env) + (call-with-destructured-c-enum-form + form + (lambda (name value-form) + (let* ((includes (find-c-includes usage-env))) + (if (not value-form) + (lookup-enum-value name form includes) + (if (integer? value-form) + (c-enum-name value-form name + (c-enum-constant-values name form includes)) + (let ((value (close-syntax value-form usage-env)) + (constants (c-enum-constant-values name form includes))) + `(C-ENUM-NAME ,value ',name ',constants)))))))))) + +(define (lookup-enum-value name whole-form includes) + (let ((entry (assq name (c-includes/enum-values includes)))) + (if (not entry) + (serror whole-form "constant not declared") + (cdr entry)))) + +(define (c-enum-constant-values name form includes) + (let ((defn (ctype-definition name includes)) + (vals (c-includes/enum-values includes))) + (if (ctype/enum-defn? defn) + (let loop ((consts (ctype-enum-defn/constants defn))) + (if (pair? consts) + (let* ((name (caar consts)) + (entry (or (assq name vals) + (error "no value for enum constant" name)))) + (cons entry (loop (cdr consts)))) + '())) + (serror form "not an enum type")))) + +(define (call-with-destructured-c-enum-form form receiver) + (let ((len (length form))) + (if (< len 2) (serror form "too few args")) + (if (> len 3) (serror form "too many args")) + (let ((type-str (cadr form)) + (value-form (and (pair? (cddr form)) (caddr form)))) + (if (not (string? type-str)) + (serror form "1st arg must be a string")) + (let ((words (burst-string type-str #\space #t))) + (if (null? words) + (serror form "1st arg is an empty string")) + (let ((name (cond ((and (string=? "enum" (car words)) + (not (null? (cdr words))) + (null? (cddr words))) + `(ENUM ,(string->symbol (cadr words)))) + ((null? (cdr words)) + (string->symbol (car words))) + (else (serror form "not an enum type name"))))) + (if (and value-form (string? value-form)) + (serror form "2nd arg cannot be a string")) + (receiver name value-form)))))) + + +;;; C-sizeof and C-offset Syntaxes + +(define-syntax C-sizeof + ;; (C-sizeof "GdkColor") ===> 10 + (sc-macro-transformer + (lambda (form usage-env) + (expand-c-info-syntax 'SIZEOF form usage-env)))) + +(define-syntax C-offset + ;; (C-offset "GdkColor green") ===> 6 + (sc-macro-transformer + (lambda (form usage-env) + (expand-c-info-syntax 'OFFSET form usage-env)))) + +(define (expand-c-info-syntax which form usage-env) + ;; WHICH can be SIZEOF or OFFSET. + (let ((len (length form))) + (if (< len 2) (serror form "too few args")) + (if (> len 2) (serror form "too many args")) + (let ((str (cadr form))) + (if (not (string? str)) (serror form "arg must be a string")) + (let ((spec (map string->symbol (burst-string str #\space #t)))) + (if (null? spec) (serror form "arg is an empty string")) + (c-info which spec form usage-env))))) + +(define (c-info which spec form usage-env) + ;; Returns the offset or sizeof for SPEC. + (let* ((includes (find-c-includes usage-env)) + (btype.members + (call-with-initial-ctype + spec form + (lambda (ctype member-spec) + (let ((defn (ctype-definition ctype includes))) + (if (and (eq? which 'OFFSET) (null? member-spec)) + (serror form "no member specified")) + (if (and (eq? which 'OFFSET) + (not (or (ctype/struct-defn? defn) + (ctype/union-defn? defn)))) + (serror form "not a struct or union type")) + (if (and (not (eq? which 'OFFSET)) (not (null? member-spec))) + (if (null? (cdr member-spec)) + (serror form "no member name allowed") + (serror form "no member names allowed"))) + (cond ((ctype/basic? defn) + (cons defn '())) + ((ctype/pointer? defn) + (cons '* '())) + ((or (ctype/struct-defn? defn) + (ctype/union-defn? defn)) + (cons ctype member-spec)) + (else + (serror form "unimplemented"))))))) + (entry (assoc (cons which btype.members) + (c-includes/struct-values includes)))) + (if entry + (if (eq? 'OFFSET which) (cadr entry) (cdr entry)) + (if (eq? 'OFFSET which) + (serror form "unknown member") + (serror form "unknown C type " btype.members))))) + +(define (call-with-initial-ctype spec form receiver) + ;; Given SPEC, a list of symbols, calls RECEIVER with a ctype and + ;; member spec (the list of names that followed the C type spec) + ;; + ;; For example RECEIVER is called with + ;; + ;; (* (|struct| |addrinfo|)) and (|ai_socktype|) + ;; + ;; when SPEC is (* |struct| |addrinfo| |ai_socktype|). + (let ((type-name (car spec)) + (member-spec (cdr spec))) + (cond ((memq type-name '(STRUCT UNION ENUM)) + (if (null? member-spec) + (serror form "incomplete C type specification") + (receiver (list type-name (car member-spec)) + (cdr member-spec)))) + ((eq? type-name '*) + (if (null? member-spec) + (receiver '* '()) + ;; Recursively strip prefix pointer op. + (call-with-initial-ctype + member-spec form + (lambda (target-ctype member-spec) + (receiver (list '* target-ctype) + member-spec))))) + (else + (receiver type-name member-spec))))) + + +;;; C-array-loc and -loc! Syntaxes + +(define-syntax C-array-loc + ;; (C-array-loc ALIEN "element type" INDEX) + ;; ===> + ;; (alien-byte-increment ALIEN (* (C-sizeof "element type") INDEX)) + (sc-macro-transformer + (lambda (form usage-env) + (expand-c-array-loc-syntax #f form usage-env)))) + +(define-syntax C-array-loc! + ;; (C-array-loc! ALIEN "element type" INDEX) + ;; ===> + ;; (alien-byte-increment! ALIEN (* (C-sizeof "element type") INDEX)) + (sc-macro-transformer + (lambda (form usage-env) + (expand-c-array-loc-syntax #t form usage-env)))) + +(define (expand-c-array-loc-syntax bang? form usage-env) + (call-with-destructured-C-array-loc-form + form + (lambda (alien-form str index-form) + (let ((spec (map string->symbol (burst-string str #\space #t)))) + (if (null? spec) (serror form "2nd arg is an empty string")) + (let ((alien-form (close-syntax alien-form usage-env)) + (sizeof (c-info `SIZEOF spec form usage-env)) + (index-form (close-syntax index-form usage-env)) + (proc (if bang? 'ALIEN-BYTE-INCREMENT! 'ALIEN-BYTE-INCREMENT))) + `(,proc ,alien-form (* ,sizeof ,index-form))))))) + +(define (call-with-destructured-C-array-loc-form form receiver) + (let ((len (length form))) + (if (< len 4) (serror form "too few args")) + (if (> len 4) (serror form "too many args")) + (let ((alien-form (cadr form)) + (type (if (string? (caddr form)) + (caddr form) + (serror form "the 2nd arg must be a string"))) + (index-form (cadddr form))) + (receiver alien-form type index-form)))) + + +;;; C-call Syntax + +(define-syntax C-call + ;; (C-call "gtk_label_new" alien "Hello, World!") + ;; ===> + ;; (call-alien #[alien-function 33 gtk_label_new] alien "Hello, World!") + (sc-macro-transformer + (lambda (form usage-env) + (call-with-destructured-C-call-form + form + (lambda (func-name arg-forms) + (let* ((includes (find-c-includes usage-env)) + (callouts (c-includes/callouts includes)) + (alien (let ((entry (assq func-name callouts))) + (if (pair? entry) + (cdr entry) + (begin + (warn "no declaration of C function:" func-name) + func-name))))) + `(CALL-ALIEN ,alien + . ,(map (lambda (form) (close-syntax form usage-env)) + arg-forms)))))))) + +(define (call-with-destructured-C-call-form form receiver) + ;; Calls RECEIVER with the optional return-alien-form, func-name + ;; (as a symbol), and the arg-forms. + (if (not (pair? (cdr form))) (serror form "no function name")) + (let ((name (cadr form)) + (args (cddr form))) + (if (not (string? name)) (serror form "first arg is not a string")) + (receiver (string->symbol name) args))) + + +;;; C-callback Syntax + +(define-syntax C-callback + ;; (C-callback "clicked") ===> #[alien-function "clicked"] + ;; and + ;; (C-callback clicked) ===> (register-c-callback clicked) + (sc-macro-transformer + (lambda (form usage-env) + (call-with-destructured-c-callback-form form + (lambda (obj) + (if (string? obj) + (let* ((c-includes (find-c-includes usage-env)) + (callbacks (c-includes/callbacks c-includes)) + (name (string->symbol obj))) + (let ((entry (assq name callbacks))) + (if (pair? entry) (cdr entry) + (serror form "C function not declared")))) + (let ((value-form (close-syntax obj usage-env))) + `(REGISTER-C-CALLBACK ,value-form)))))))) + +(define (call-with-destructured-c-callback-form form receiver) + ;; Calls RECEIVER with the only subform. + (let ((len (length form))) + (if (< len 2) (serror form "too few args")) + (if (> len 2) (serror form "too many args")) + (receiver (cadr form)))) + + +;;; Utilities + +(define (find-c-includes env) + ;; Returns the c-includes structure bound to 'C-INCLUDES in ENV. + (guarantee-syntactic-environment env 'find-c-includes) + (let ((ienv (syntactic-environment->environment env))) + (if (and (environment-bound? ienv 'C-INCLUDES) + (environment-assigned? ienv 'C-INCLUDES)) + (let ((includes (environment-lookup ienv 'C-INCLUDES))) + (if (c-includes? includes) + includes + (error "C-includes is not bound to a c-includes structure:" + includes))) + (error "No C types have been included.")))) + +(define condition-type:serror + (make-condition-type + 'syntaxer-error + condition-type:error + '(FORM MESSAGE) + (lambda (condition port) + (write-string "Syntax error: " port) + (write-string (access-condition condition 'MESSAGE) port) + (write-string " in: " port) + (write (access-condition condition 'FORM) port) + (write-char #\. port)))) + +(define serror + (let ((signaller (condition-signaller condition-type:serror '(FORM MESSAGE) + standard-error-handler))) + (named-lambda (serror form message . args) + (signaller form + (apply string-append + (map (lambda (obj) + (if (string? obj) obj (write-to-string obj))) + (cons message args))))))) \ No newline at end of file diff --git a/src/microcode/boot.c b/src/microcode/boot.c index f58345921..f4b5ee115 100644 --- a/src/microcode/boot.c +++ b/src/microcode/boot.c @@ -67,6 +67,7 @@ const char * scheme_program_name; const char * OS_Name; const char * OS_Variant; struct obstack scratch_obstack; +struct obstack ffi_obstack; void * initial_C_stack_pointer; static char * reload_saved_string; static unsigned int reload_saved_string_length; @@ -114,6 +115,7 @@ main_name (int argc, const char ** argv) OS2_initialize_early (); #endif obstack_init (&scratch_obstack); + obstack_init (&ffi_obstack); dstack_initialize (); transaction_initialize (); reload_saved_string = 0; @@ -296,7 +298,7 @@ start_scheme (void) static void Do_Enter_Interpreter (void) { - Interpret (); + Interpret (0); outf_fatal ("\nThe interpreter returned to top level!\n"); Microcode_Termination (TERM_EXIT); } @@ -312,7 +314,7 @@ Enter_Interpreter (void) SCHEME_OBJECT Re_Enter_Interpreter (void) { - Interpret (); + Interpret (0); return (GET_VAL); } diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index cde298a49..f75ad3922 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -888,7 +888,7 @@ if test ${enable_static_libs} != no; then STATIC_LIBS=${MODULE_LIBS}${STATIC_LIBS} else STATIC_LIBS= - OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld" + OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld pruxffi" AC_DEFINE([UX_DLD_ENABLED], [1], [Define to 1 if unix dynamic loading support is enabled.]) fi diff --git a/src/microcode/const.h b/src/microcode/const.h index cddb0a985..f04b6640c 100644 --- a/src/microcode/const.h +++ b/src/microcode/const.h @@ -71,6 +71,8 @@ USA. #define PRIM_APPLY_INTERRUPT -9 #define PRIM_APPLY_ERROR -10 #define PRIM_NO_TRAP_POP_RETURN -11 +#define PRIM_RETURN_TO_C -12 +#define PRIM_ABORT_TO_C -13 #define ABORT_NAME_TABLE \ { \ @@ -84,7 +86,9 @@ USA. /* -8 */ "TOUCH", \ /* -9 */ "APPLY-INTERRUPT", \ /* -10 */ "REENTER", \ - /* -11 */ "NO-TRAP-POP-RETURN" \ + /* -11 */ "NO-TRAP-POP-RETURN", \ + /* -12 */ "RETURN-TO-C", \ + /* -13 */ "ABORT-TO-C" \ } /* Some numbers of parameters which mean something special */ diff --git a/src/microcode/extern.h b/src/microcode/extern.h index 287a806cb..17ea3d9f2 100644 --- a/src/microcode/extern.h +++ b/src/microcode/extern.h @@ -179,6 +179,7 @@ extern const char * scheme_program_name; extern const char * OS_Name; extern const char * OS_Variant; extern struct obstack scratch_obstack; +extern struct obstack ffi_obstack; extern unsigned long n_heap_blocks; extern unsigned long n_constant_blocks; @@ -305,6 +306,7 @@ extern void import_primitive_table extern void initialize_primitives (void); extern SCHEME_OBJECT make_primitive (const char *, int); +extern SCHEME_OBJECT find_primitive_cname (char *, bool, bool, int); extern SCHEME_OBJECT find_primitive (SCHEME_OBJECT, bool, bool, int); /* Interpreter utilities */ @@ -324,7 +326,7 @@ extern void preserve_interrupt_mask (void); extern void canonicalize_primitive_context (void); extern void back_out_of_primitive (void); -extern void Interpret (void); +extern void Interpret (int pop_return_p); extern void Do_Micro_Error (long, bool); extern void Translate_To_Point (SCHEME_OBJECT); extern void Stack_Death (void) NORETURN; diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h index d5028a009..f93da7424 100644 --- a/src/microcode/fixobj.h +++ b/src/microcode/fixobj.h @@ -122,5 +122,7 @@ USA. #define GC_WABBIT_DESCRIPTOR 0x40 -/* 4 extra slots for expansion and debugging. */ +#define CALLBACK_HANDLER 0x41 + +/* 3 extra slots for expansion and debugging. */ #define N_FIXED_OBJECTS 0x45 diff --git a/src/microcode/interp.c b/src/microcode/interp.c index b7df59724..75d58dca9 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -255,7 +255,7 @@ abort_to_interpreter_argument (void) long prim_apply_error_code; void -Interpret (void) +Interpret (int pop_return_p) { long dispatch_code; struct interpreter_state_s new_state; @@ -275,8 +275,11 @@ Interpret (void) switch (dispatch_code) { - case 0: - break; + case 0: /* first time */ + if (pop_return_p) + goto pop_return; /* continue */ + else + break; /* fall into eval */ case PRIM_APPLY: PROCEED_AFTER_PRIMITIVE (); @@ -310,6 +313,11 @@ Interpret (void) PROCEED_AFTER_PRIMITIVE (); goto pop_return; + case PRIM_RETURN_TO_C: + PROCEED_AFTER_PRIMITIVE (); + unbind_interpreter_state (interpreter_state); + return; + case PRIM_NO_TRAP_POP_RETURN: PROCEED_AFTER_PRIMITIVE (); goto pop_return_non_trapping; @@ -318,6 +326,11 @@ Interpret (void) back_out_of_primitive (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); + case PRIM_ABORT_TO_C: + back_out_of_primitive (); + unbind_interpreter_state (interpreter_state); + return; + case ERR_ARG_1_WRONG_TYPE: back_out_of_primitive (); Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true); diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index 2b5917b4e..807ed990a 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -276,6 +276,7 @@ install-auxDATA: $(aux_DATA) $(INSTALL_DATA) $$p $(DESTDIR)$(AUXDIR)/.; \ fi; \ done + $(INSTALL_DATA) pruxffi.h $(DESTDIR)$(AUXDIR)/mit-scheme.h install-include: $(mkinstalldirs) $(DESTDIR)$(AUXDIR) diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 6a84a280d..5431e4472 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -36,6 +36,7 @@ USA. "prmhash" "prpgsql" "pruxdld" +"pruxffi" "svm1-interp" "termcap" "terminfo" diff --git a/src/microcode/primutl.c b/src/microcode/primutl.c index 40fe438ba..a2b271565 100644 --- a/src/microcode/primutl.c +++ b/src/microcode/primutl.c @@ -331,10 +331,9 @@ make_primitive (const char * name, int arity) } SCHEME_OBJECT -find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity) +find_primitive_cname (char * name, bool intern_p, bool allow_p, int arity) { - tree_node prim - = (tree_lookup (prim_procedure_tree, (STRING_POINTER (sname)))); + tree_node prim = (tree_lookup (prim_procedure_tree, name)); if (prim != 0) { SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value)); @@ -361,9 +360,9 @@ find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity) return (SHARP_F); { - size_t n_bytes = ((STRING_LENGTH (sname)) + 1); + size_t n_bytes = ((strlen (name)) + 1); char * cname = (OS_malloc (n_bytes)); - memcpy (cname, (STRING_POINTER (sname)), n_bytes); + memcpy (cname, name, n_bytes); { SCHEME_OBJECT primitive = (declare_primitive (cname, @@ -377,6 +376,13 @@ find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity) } } } + +SCHEME_OBJECT +find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity) +{ + return (find_primitive_cname (STRING_POINTER (sname), + intern_p, allow_p, arity)); +} /* These are used by fasdump to renumber primitives on the way out. Only those primitives actually referenced by the object being diff --git a/src/microcode/pruxdld.c b/src/microcode/pruxdld.c index 78e102800..a0a6f4498 100644 --- a/src/microcode/pruxdld.c +++ b/src/microcode/pruxdld.c @@ -201,7 +201,7 @@ dld_lookup (void * handle, const char * symbol) { SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1)); VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL))); - VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen"))); + VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym"))); VECTOR_SET (v, 2, (char_pointer_to_string (error_string))); error_with_argument (v); } diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c new file mode 100644 index 000000000..aa3a69bbe --- /dev/null +++ b/src/microcode/pruxffi.c @@ -0,0 +1,1208 @@ +/* -*-C-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Un*x primitives for an FFI. */ + +#include "scheme.h" +#include "prims.h" +#include "bignmint.h" +#include "history.h" +#include "pruxffi.h" +/* Using SCM instead of SCHEME_OBJECT here, hoping to ensure that + these types always match. */ + +/* Alien Addresses */ + +#define HALF_WORD_SHIFT ((sizeof (void*) * CHAR_BIT) / 2) +#define HALF_WORD_MASK ((1 << HALF_WORD_SHIFT) - 1) +#define ARG_RECORD(argument_number) \ + ((RECORD_P (ARG_REF (argument_number))) \ + ? (ARG_REF (argument_number)) \ + : ((error_wrong_type_arg (argument_number)), ((SCM) 0))) + +int +is_alien (SCM alien) +{ + if (RECORD_P (alien) && VECTOR_LENGTH (alien) == 4) + { + SCM high = VECTOR_REF (alien, 1); + SCM low = VECTOR_REF (alien, 2); + if (UNSIGNED_FIXNUM_P (high) && UNSIGNED_FIXNUM_P (low)) + return (1); + } + return (0); +} + +void* +alien_address (SCM alien) +{ + ulong high = FIXNUM_TO_ULONG (VECTOR_REF (alien, 1)); + ulong low = FIXNUM_TO_ULONG (VECTOR_REF (alien, 2)); + return (void*)((high << HALF_WORD_SHIFT) + low); +} + +void +set_alien_address (SCM alien, const void* ptr) +{ + ulong addr = (ulong) ptr; + VECTOR_SET (alien, 1, ULONG_TO_FIXNUM (addr >> HALF_WORD_SHIFT)); + VECTOR_SET (alien, 2, ULONG_TO_FIXNUM (addr & HALF_WORD_MASK)); +} + +SCM +arg_alien (int argn) +{ + SCM alien = ARG_REF (argn); + if (is_alien (alien)) + return (alien); + error_wrong_type_arg (argn); + /* NOTREACHED */ + return ((SCM)0); +} + +void* +arg_address (int argn) +{ + SCM alien = ARG_REF (argn); + if (is_alien (alien)) + return (alien_address (alien)); + error_wrong_type_arg (argn); + /* NOTREACHED */ + return ((SCM)0); +} + + +/* Peek the Basic Types */ + +DEFINE_PRIMITIVE ("C-PEEK-CHAR", Prim_peek_char, 2, 2, 0) +{ + /* Return the C char at the address ALIEN+OFFSET. */ + + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char* ptr = (char*)(addr+offset); + char value = *ptr; + PRIMITIVE_RETURN (LONG_TO_FIXNUM ((long)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-UCHAR", Prim_peek_uchar, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + unsigned char * ptr = (unsigned char*)(addr+offset); + unsigned char value = *ptr; + PRIMITIVE_RETURN (LONG_TO_FIXNUM ((ulong)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-SHORT", Prim_peek_short, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + short* ptr = (short*)(addr+offset); + short value = *ptr; + PRIMITIVE_RETURN (LONG_TO_FIXNUM ((long)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-USHORT", Prim_peek_ushort, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + ushort* ptr = (ushort*)(addr+offset); + ushort value = *ptr; + PRIMITIVE_RETURN (LONG_TO_FIXNUM ((ulong)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-INT", Prim_peek_int, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + int* ptr = (int*)(addr+offset); + int value = *ptr; + PRIMITIVE_RETURN (long_to_integer ((long)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-UINT", Prim_peek_uint, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + uint* ptr = (uint*)(addr+offset); + uint value = *ptr; + PRIMITIVE_RETURN (ulong_to_integer ((ulong)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-LONG", Prim_peek_long, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + long* ptr = (long*)(addr+offset); + long value = *ptr; + PRIMITIVE_RETURN (long_to_integer (value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-ULONG", Prim_peek_ulong, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + ulong* ptr = (ulong*)(addr+offset); + ulong value = *ptr; + PRIMITIVE_RETURN (ulong_to_integer (value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-FLOAT", Prim_peek_float, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + float* ptr = (float*)(addr+offset); + float value = *ptr; + PRIMITIVE_RETURN (double_to_flonum ((double)value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-DOUBLE", Prim_peek_double, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + double* ptr = (double*)(addr+offset); + double value = *ptr; + PRIMITIVE_RETURN (double_to_flonum (value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-POINTER", Prim_peek_pointer, 3, 3, 0) +{ + /* Read the pointer at ALIEN+OFFSET and set ALIEN2 (perhaps the + same as ALIEN) to point to the same address. */ + + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + SCM alien = ARG_RECORD (3); + void** ptr = (void**)(addr+offset); + void* value = *ptr; + set_alien_address (alien, value); + PRIMITIVE_RETURN (alien); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-CSTRING", Prim_peek_cstring, 2, 2, 0) +{ + /* Return a Scheme string containing the characters in a C string + that starts at the address ALIEN+OFFSET. */ + + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char* ptr = (char*)(addr+offset); + PRIMITIVE_RETURN (char_pointer_to_string (ptr)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-CSTRING!", Prim_peek_cstring_bang, 2, 2, 0) +{ + /* Return a Scheme string containing the characters in a C string + that starts at the address ALIEN+OFFSET. Set ALIEN to the + address of the C char after the string's null terminator. */ + + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char* ptr = (char*)(addr+offset); + SCM str = char_pointer_to_string (ptr); + set_alien_address (ARG_REF (1), ptr + strlen (ptr) + 1); + PRIMITIVE_RETURN (str); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP", Prim_peek_cstringp, 2, 2, 0) +{ + /* Follow the pointer at the address ALIEN+OFFSET to a C string. + Copy the C string into the heap and return the new Scheme + string. */ + + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char** ptr = (char**)(addr+offset); + char* value = *ptr; + PRIMITIVE_RETURN (char_pointer_to_string (value)); + } +} + +DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0) +{ + /* Follow the pointer at the address ALIEN+OFFSET to a C string. + Set ALIEN to the address of the char pointer after ALIEN+OFFSET. + Copy the C string into the heap and return the new Scheme + string. */ + + PRIMITIVE_HEADER (2); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char** ptr = (char**)(addr+offset); + char* value = *ptr; + SCM val = char_pointer_to_string (value); + set_alien_address (ARG_REF (1), ptr + 1); /* No more aborts! */ + PRIMITIVE_RETURN (val); + } +} + + +/* Poke the Basic Types */ + +DEFINE_PRIMITIVE ("C-POKE-CHAR", Prim_poke_char, 3, 3, 0) +{ + /* Set the C char at address ALIEN+OFFSET to VALUE (an integer). */ + + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + char* ptr = (char*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-UCHAR", Prim_poke_uchar, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + unsigned char* ptr = (unsigned char*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-SHORT", Prim_poke_short, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + short* ptr = (short*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-USHORT", Prim_poke_ushort, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + ushort* ptr = (ushort*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-INT", Prim_poke_int, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + int* ptr = (int*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-UINT", Prim_poke_uint, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + uint* ptr = (uint*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-LONG", Prim_poke_long, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + long* ptr = (long*)(addr+offset); + *ptr = arg_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-ULONG", Prim_poke_ulong, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + ulong* ptr = (ulong*)(addr+offset); + *ptr = arg_ulong_integer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-FLOAT", Prim_poke_float, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + float* ptr = (float*)(addr+offset); + *ptr = arg_real_number (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-DOUBLE", Prim_poke_double, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + char* addr = (char*) arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + double* ptr = (double*)(addr+offset); + *ptr = arg_real_number (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-POINTER", Prim_poke_pointer, 3, 3, 0) +{ + /* Set the pointer at address ALIEN+OFFSET to ADDRESS (an alien, + string, xstring or 0 for NULL). */ + + PRIMITIVE_HEADER (3); + { + char* addr = arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + void** ptr = (void**)(addr+offset); + *ptr = arg_pointer (3); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-POINTER!", Prim_poke_pointer_bang, 3, 3, 0) +{ + /* Set the pointer at address ALIEN+OFFSET to ADDRESS (an alien, + string, xstring or 0 for NULL). Set ALIEN to the address of the + pointer after ALIEN+OFFSET. */ + + PRIMITIVE_HEADER (3); + { + char* addr = arg_address (1); + uint offset = UNSIGNED_FIXNUM_ARG (2); + void** ptr = (void**)(addr+offset); + *ptr = arg_pointer (3); + set_alien_address (ARG_REF (1), ptr + 1); + } + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("C-POKE-STRING", Prim_poke_string, 3, 3, 0) +{ + /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING. + Assume STRING fits. Null terminate the C string. */ + + PRIMITIVE_HEADER (3); + { + char* address, * scan; + int offset, length; + SCM string; + + address = arg_address (1); + offset = UNSIGNED_FIXNUM_ARG (2); + CHECK_ARG (3, STRING_P); + string = ARG_REF (3); + length = STRING_LENGTH (string); + scan = STRING_POINTER (string); + strncpy (address + offset, scan, length+1); + + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +DEFINE_PRIMITIVE ("C-POKE-STRING!", Prim_poke_string_bang, 3, 3, 0) +{ + /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING. + Assume STRING fits. Null terminate the C string. Set ALIEN to + the address of the C char following the NULL terminator. */ + + PRIMITIVE_HEADER (3); + { + char* address, * scan; + int offset, length; + SCM string; + + address = arg_address (1); + offset = UNSIGNED_FIXNUM_ARG (2); + CHECK_ARG (3, STRING_P); + string = ARG_REF (3); + length = STRING_LENGTH (string); + scan = STRING_POINTER (string); + strncpy (address + offset, scan, length+1); + set_alien_address (ARG_REF (1), address + offset + length+1); + + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + + +/* Malloc/Free. */ + +DEFINE_PRIMITIVE ("C-MALLOC", Prim_c_malloc, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + { + SCM alien = arg_alien (1); + int size = arg_ulong_integer (2); + void* mem = malloc (size); + set_alien_address (alien, mem); + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +DEFINE_PRIMITIVE ("C-FREE", Prim_c_free, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + void* addr = arg_address (1); + if (addr != NULL) + free (addr); + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + + +/* The CStack */ + +char* +cstack_top (void) +{ + return (ffi_obstack.next_free); +} + +void +cstack_push (void* addr, int bytes) +{ + obstack_grow ((&ffi_obstack), addr, bytes); +} + +char* +cstack_lpop (char* tos, int bytes) +{ + tos = tos - bytes; + if (tos < ffi_obstack.object_base) + { + outf_error ("\ninternal error: C stack exhausted\n"); + outf_error ("\tCould not pop %d bytes.\n", bytes); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + return (tos); +} + +void +cstack_pop (char* tos) +{ + if (tos < ffi_obstack.object_base) + { + outf_error ("\ninternal error: C stack over-popped.\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + (&ffi_obstack)->next_free = tos; +} + +/* Number CStack frames, to detect slips. */ +int cstack_depth = 0; + + +/* Callouts */ + +DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0) +{ + /* All the smarts are in the trampolines. */ + + PRIMITIVE_HEADER (LEXPR); + canonicalize_primitive_context (); + { + CalloutTrampOut tramp; + + tramp = (CalloutTrampOut) arg_alien_entry (1); + tramp (); + /* NOTREACHED */ + outf_error ("\ninternal error: Callout part1 trampoline returned.\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + /* really NOTREACHED */ + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +static SCM c_call_continue = SHARP_F; + +void +callout_seal (CalloutTrampIn tramp) +{ + /* Used in a callout part1 trampoline. Arrange for subsequent + aborts to start part2. + + Seal the CStack, substitute the C-CALL-CONTINUE primitive for + the C-CALL primitive, and back out. The tramp can then execute + the toolkit function safely, even if there is a callback. */ + + if (c_call_continue == SHARP_F) + { + c_call_continue + = find_primitive_cname ("C-CALL-CONTINUE", + false, false, LEXPR_PRIMITIVE_ARITY); + if (c_call_continue == SHARP_F) + { + outf_error ("\nNo C-CALL-CONTINUE primitive!\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + } + cstack_depth += 1; + CSTACK_PUSH (int, cstack_depth); + CSTACK_PUSH (CalloutTrampIn, tramp); + + /* Back out of C-CALL-CONTINUE. */ + SET_PRIMITIVE (c_call_continue); + back_out_of_primitive (); + /* Ready for Interpret(1). */ +} + +void +callout_unseal (CalloutTrampIn expected) +{ + /* Used by a callout part1 trampoline to strip the CStack's frame + header (tramp, depth) before pushing return values. */ + + char* tos; + CalloutTrampIn found; + int depth; + + tos = cstack_top (); + CSTACK_LPOP (CalloutTrampIn, found, tos); + CSTACK_LPOP (int, depth, tos); + if (found != expected || depth != cstack_depth) + { + outf_error ("\ninternal error: slipped in 1st part of callout\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + cstack_pop (tos); +} + +void +callout_continue (CalloutTrampIn tramp) +{ + /* Re-seal the CStack frame over the C results (again, pushing the + cstack_depth and callout-part2) and abort. Restart as + C-CALL-CONTINUE and run callout-part2. */ + + CSTACK_PUSH (int, cstack_depth); + CSTACK_PUSH (CalloutTrampIn, tramp); + + PRIMITIVE_ABORT (PRIM_POP_RETURN); + /* NOTREACHED */ +} + +DEFINE_PRIMITIVE ("C-CALL-CONTINUE", Prim_c_call_continue, 1, LEXPR, 0) +{ + /* (Re)Run the callout trampoline part 2 (CalloutTrampIn). */ + + PRIMITIVE_HEADER (LEXPR); + { + char* tos; + CalloutTrampIn tramp; + int depth; + SCM val; + + tos = cstack_top (); + CSTACK_LPOP (CalloutTrampIn, tramp, tos); + CSTACK_LPOP (int, depth, tos); + if (depth != cstack_depth) + { + outf_error ("\ninternal error: slipped in 2nd part of callout\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + val = tramp (); + PRIMITIVE_RETURN (val); + } +} + +char* +callout_lunseal (CalloutTrampIn expected) +{ + /* Used by a callout part2 trampoline to strip the CStack's frame + header (tramp, depth) before lpopping return value(s). */ + + char* tos; + CalloutTrampIn found; + int depth; + + tos = cstack_top (); + CSTACK_LPOP (CalloutTrampIn, found, tos); + CSTACK_LPOP (int, depth, tos); + if (depth != cstack_depth || found != expected) + { + outf_error ("\ninternal error: slipped in 1st part of callout\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + return (tos); +} + +void +callout_pop (char* tos) +{ + /* Used by a callout part2 trampoline just before returning. */ + + cstack_depth -= 1; + cstack_pop (tos); +} + + +/* Callbacks */ + +static SCM run_callback = SHARP_F; +static SCM return_to_c = SHARP_F; + +void +callback_run_kernel (int callback_id, CallbackKernel kernel) +{ + /* Used by callback trampolines. + + Expect the args on the CStack. Push a couple primitive apply + frames on the Scheme stack and seal the CStack. Then call + Interpret(). Cannot abort. */ + + long int_mask; + + if (run_callback == SHARP_F) + { + run_callback = find_primitive_cname ("RUN-CALLBACK", false, false, 0); + return_to_c = find_primitive_cname ("RETURN-TO-C", false, false, 0); + if (run_callback == SHARP_F || return_to_c == SHARP_F) + { + outf_error + ("\nWarning: punted callback #%d. Missing primitives!\n", + callback_id); + outf_flush_error (); + SET_VAL (FIXNUM_ZERO); + return; + } + } + + /* Need to push 2 each of prim+header+continuation. */ + if (! CAN_PUSH_P (2*(1+1+CONTINUATION_SIZE))) + { + outf_error + ("\nWarning: punted callback #%d. No room on stack!\n", callback_id); + outf_flush_error (); + SET_VAL (FIXNUM_ZERO); + return; + } + + cstack_depth += 1; + CSTACK_PUSH (int, cstack_depth); + CSTACK_PUSH (CallbackKernel, kernel); + + STACK_PUSH (return_to_c); + PUSH_APPLY_FRAME_HEADER (0); + SET_RC (RC_INTERNAL_APPLY); + SAVE_CONT(); + STACK_PUSH (run_callback); + PUSH_APPLY_FRAME_HEADER (0); + SAVE_CONT(); + + /* Turn off thread switching. */ + int_mask = GET_INT_MASK; + SET_INTERRUPT_MASK (int_mask & ~INT_Timer); + Interpret (1); + SET_INTERRUPT_MASK (int_mask); + + cstack_depth -= 1; +} + +DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0) +{ + /* All the smarts are in the kernel. */ + + PRIMITIVE_HEADER (0); + { + char* tos; + CallbackKernel kernel; + int depth; + + tos = cstack_top (); + CSTACK_LPOP (CallbackKernel, kernel, tos); + CSTACK_LPOP (int, depth, tos); + if (depth != cstack_depth) + { + outf_error ("\nWarning: C data stack slipped in run-callback!\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + + kernel (); + /* NOTREACHED */ + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +DEFINE_PRIMITIVE ("RETURN-TO-C", Prim_return_to_c, 0, 0, 0) +{ + /* Callbacks are possible while stopped. The PRIM_RETURN_TO_C abort + expects this primitive to clean up its stack frame. */ + + PRIMITIVE_HEADER (0); + canonicalize_primitive_context (); + { + SCM primitive; + long nargs; + + primitive = GET_PRIMITIVE; + assert (PRIMITIVE_P (primitive)); + nargs = (PRIMITIVE_N_ARGUMENTS (primitive)); + POP_PRIMITIVE_FRAME (nargs); + SET_EXP (SHARP_F); + PRIMITIVE_ABORT (PRIM_RETURN_TO_C); + /* NOTREACHED */ + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +char* +callback_lunseal (CallbackKernel expected) +{ + /* Used by a callback kernel to strip the CStack's frame header + (kernel, depth) before lpopping arguments. */ + + char* tos; + CallbackKernel found; + int depth; + + tos = cstack_top (); + CSTACK_LPOP (CallbackKernel, found, tos); + CSTACK_LPOP (int, depth, tos); + if (depth != cstack_depth || found != expected) + { + outf_error ("\ninternal error: slipped in callback kernel\n"); + outf_flush_error (); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); + } + return (tos); +} + +static SCM valid_callback_handler (void); +static SCM valid_callback_id (int id); + +void +callback_run_handler (int callback_id, SCM arglist) +{ + /* Similar to setup_interrupt [utils.c]. Used by callback kernels, + inside the interpreter. Thus it MAY GC abort. + + Push a Scheme callback handler apply frame. This leaves the + interpreter ready to tail-call the Scheme procedure. (The + RUN-CALLBACK primitive apply frame is already gone.) The + trampoline should abort with PRIM_APPLY. */ + + SCM handler, fixnum_id; + + handler = valid_callback_handler (); + fixnum_id = valid_callback_id (callback_id); + + stop_history (); + /* preserve_interrupt_mask (); + + The above statement appears in setup_interrupt. In this case, + something similar is done in callback_run_kernel, BEFORE + re-entering the interpreter. (The "BEFORE" part is + important!) */ + + Will_Push (STACK_ENV_EXTRA_SLOTS + 3); + STACK_PUSH (arglist); + STACK_PUSH (fixnum_id); + STACK_PUSH (handler); + PUSH_APPLY_FRAME_HEADER (2); + Pushed (); + /* Turn off interrupts: */ + /* SET_INTERRUPT_MASK (interrupt_mask); + + The above statement (from setup_interrupt) must move to + callback_run_kernel. */ +} + +static SCM +valid_callback_handler (void) +{ + /* Validate the Scheme callback handler procedure. */ + + SCM handler; + + handler = (VECTOR_REF (fixed_objects, CALLBACK_HANDLER)); + if (! interpreter_applicable_p (handler)) + { + outf_error ("\nWarning: bogus callback handler: 0x%x.\n", (uint)handler); + outf_flush_error (); + Do_Micro_Error (ERR_INAPPLICABLE_OBJECT, true); + abort_to_interpreter (PRIM_APPLY); + /* NOTREACHED */ + } + return (handler); +} + +static SCM +valid_callback_id (int id) +{ + /* Validate the callback ID and convert to a fixnum. */ + + if (ULONG_TO_FIXNUM_P (id)) + return (ULONG_TO_FIXNUM (id)); + signal_error_from_primitive (ERR_ARG_1_BAD_RANGE); + /* NOTREACHED */ + return (FIXNUM_ZERO); +} + +void +callback_return (char* tos) +{ + cstack_pop (tos); + PRIMITIVE_ABORT (PRIM_APPLY); +} + + +/* Converters */ + +long +arg_long (int argn) +{ + return (arg_integer (argn)); +} + +ulong +arg_ulong (int argn) +{ + return (arg_ulong_integer (argn)); +} + +double +arg_double (int argn) +{ + /* Convert the object to a double. Like arg_real_number. */ + + return (arg_real_number (argn)); +} + +void* +arg_alien_entry (int argn) +{ + /* Expect an alien-function. Return its address. */ + + SCM alienf = VECTOR_ARG (argn); + int length = VECTOR_LENGTH (alienf); + if (length < 3) + error_wrong_type_arg (argn); + return (alien_address (alienf)); +} + +void* +arg_pointer (int argn) +{ + /* Accept an alien, string, xstring handle (positive integer), + or zero (for a NULL pointer). */ + + SCM arg = ARG_REF (argn); + if (integer_zero_p (arg)) + return ((void*)0); + if (STRING_P (arg)) + return ((void*) (STRING_POINTER (arg))); + if ((INTEGER_P (arg)) && (integer_to_ulong_p (arg))) + { + unsigned char* result = lookup_external_string (arg, NULL); + if (result == 0) + error_wrong_type_arg (argn); + return ((void*) result); + } + if (is_alien (arg)) + return (alien_address (arg)); + + error_wrong_type_arg (argn); + /*NOTREACHED*/ + return ((void*)0); +} + +SCM +long_to_scm (const long i) +{ + return (long_to_integer (i)); +} + +SCM +ulong_to_scm (const ulong i) +{ + return (ulong_to_integer (i)); +} + +SCM +double_to_scm (const double d) +{ + return (double_to_flonum (d)); +} + +SCM +pointer_to_scm (const void* p) +{ + /* Return a pointer from a callout. Expect the first real argument + (the 2nd) to be either #F or an alien. */ + + SCM arg = ARG_REF (2); + if (arg == SHARP_F) + return (UNSPECIFIC); + if (is_alien (arg)) + { + set_alien_address (arg, p); + return (arg); + } + + error_wrong_type_arg (2); + /* NOTREACHED */ + return (SHARP_F); +} + +SCM +cons_alien (const void* addr) +{ + /* Construct an alien. Used by callback kernels to construct + arguments for the Scheme callback-handler, or part2 of callouts + returning a new alien. Note that these should be fixed up on the + Scheme side with the record type. */ + + SCM alien; + Primitive_GC_If_Needed (5); + alien = (MAKE_POINTER_OBJECT (TC_RECORD, Free)); + (*Free++) = MAKE_OBJECT (TC_MANIFEST_VECTOR, 4); + (*Free++) = SHARP_F; + (*Free++) = FIXNUM_ZERO; + (*Free++) = FIXNUM_ZERO; + (*Free++) = SHARP_F; + set_alien_address (alien, addr); + return (alien); +} + +long +long_value (void) +{ + /* Convert VAL to a long. Accept integers AND characters. Like + arg_integer otherwise. */ + + SCM value = GET_VAL; + if (CHARACTER_P (value)) + return (CHAR_TO_ASCII (value)); + if (! (INTEGER_P (value))) + { + /* error_wrong_type_arg (1); Not inside the interpreter here. */ + outf_error ("\nWarning: Callback did not return an integer!\n"); + outf_flush_error (); + return (0); + } + if (! (integer_to_long_p (value))) + { + /* error_bad_range_arg (1); */ + outf_error + ("\nWarning: Callback returned an integer larger than a C long!\n"); + outf_flush_error (); + return (0); + } + return (integer_to_long (value)); +} + +ulong +ulong_value (void) +{ + /* Convert VAL to an unsigned long. Accept integers AND characters. + Like arg_integer otherwise. */ + + SCM value = GET_VAL; + if (CHARACTER_P (value)) + return (CHAR_TO_ASCII (value)); + if (! (INTEGER_P (value))) + { + /* error_wrong_type_arg (1); Not inside the interpreter here. */ + outf_error ("\nWarning: Callback did not return an integer!\n"); + outf_flush_error (); + return (0); + } + if (! (integer_to_ulong_p (value))) + { + /* error_bad_range_arg (1); */ + outf_error + ("\nWarning: Callback returned an integer larger than a C ulong!\n"); + outf_flush_error (); + return (0); + } + return (integer_to_ulong (value)); +} + +double +double_value (void) +{ + /* Convert VAL to a double. Like arg_real_number. */ + + SCM value = GET_VAL; + + if (! REAL_P (value)) + { + /* error_wrong_type_arg (1); Not inside the interpreter here. */ + outf_error ("\nWarning: Callback did not return a real.\n"); + outf_flush_error (); + return (0.0); + } + if (! (real_number_to_double_p (value))) + { + /* error_bad_range_arg (1); */ + outf_error + ("\nWarning: Callback returned a real larger than a C double!\n"); + outf_flush_error (); + return (0.0); + } + return (real_number_to_double (value)); +} + +void* +pointer_value (void) +{ + SCM value = GET_VAL; + + if (integer_zero_p (value)) + return (NULL); + /* NOT allowing a Scheme string (heap pointer!) into the toolkit. */ + if ((INTEGER_P (value)) && (integer_to_ulong_p (value))) + { + unsigned char* result = lookup_external_string (value, NULL); + if (result == 0) + { + outf_error ("\nWarning: Callback returned a bogus xstring.\n"); + outf_flush_error (); + return (NULL); + } + return ((void*) result); + } + if (is_alien (value)) + return (alien_address (value)); + + outf_error ("\nWarning: Callback did not return a pointer.\n"); + outf_flush_error (); + return (NULL); +} + + +/* Utilities */ + + +void +check_number_of_args (int num) +{ + if (GET_LEXPR_ACTUALS < num) + { + signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS); + } +} + +SCM +unspecific (void) +{ + return (UNSPECIFIC); +} + +SCM +empty_list (void) +{ + return (EMPTY_LIST); +} + +DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0) +{ + /* To avoid the normal i/o system when debugging a callback. */ + + PRIMITIVE_HEADER (1); + { + SCM arg = ARG_REF (1); + if (STRING_P (arg)) + { + char* string = ((char*) STRING_LOC (arg, 0)); + outf_console ("%s", string); + outf_flush_console (); + } + else + { + error_wrong_type_arg (1); + } + PRIMITIVE_RETURN (UNSPECIFIC); + } +} diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h new file mode 100644 index 000000000..9cb0717bb --- /dev/null +++ b/src/microcode/pruxffi.h @@ -0,0 +1,97 @@ +/* -*-C-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Headers for the FFI (foreign function interface). */ + +/* This file declares all of the C functions needed by a shim. It is + installed as mit-scheme.h and represents the interface between the + shims and the machine. It should not include any other headers, + and should minimize dependencies on the exact configuration of the + machine. Thus it declares teensy functions like empty_list(). */ + +/* This is redundant, but avoids the need for object.h, config.h, types.h... */ +typedef unsigned long SCM; + +extern char* cstack_top (void); +extern void cstack_push (void * addr, int bytes); +extern char* cstack_lpop (char* tos, int bytes); +extern void cstack_pop (char* tos); + +#define CSTACK_PUSH(TYPE,VAR) \ + cstack_push (((void *)(&VAR)), sizeof (TYPE)); + +/* "Local" CStack pops keep the top-of-stack in a local variable + (TOS). Thus after an abort the trampoline can start again from the + undisturbed top of the obstack. */ +#define CSTACK_LPOP(TYPE,VAR,TOS) \ + TOS = cstack_lpop (TOS, sizeof (TYPE)); \ + VAR = *(TYPE *)TOS; + +typedef void (*CalloutTrampOut)(void); +typedef SCM (*CalloutTrampIn)(void); +extern void callout_seal (CalloutTrampIn tramp); +extern void callout_unseal (CalloutTrampIn expected); +extern void callout_continue (CalloutTrampIn tramp); +extern char* callout_lunseal (CalloutTrampIn expected); +extern void callout_pop (char* tos); + +typedef void (*CallbackKernel)(void); +extern void callback_run_kernel (int callback_id, CallbackKernel kernel); +extern char* callback_lunseal (CallbackKernel expected); +extern void callback_run_handler (int callback_id, SCM arglist); +extern void callback_return (char* tos); + +/* Converters. */ + +extern long arg_long (int argn); +extern unsigned long arg_ulong (int argn); +extern double arg_double (int argn); +extern void* arg_alien_entry (int argn); +extern void* arg_pointer (int argn); + +extern SCM long_to_scm (const long i); +extern SCM ulong_to_scm (const unsigned long i); +extern SCM double_to_scm (const double d); +extern SCM pointer_to_scm (const void* p); + +extern SCM cons_alien (const void* p); + +extern long long_value (void); +extern unsigned long ulong_value (void); +extern double double_value (void); +extern void* pointer_value (void); + +/* Utilities: */ + +extern void check_number_of_args (int num); +extern SCM unspecific (void); +extern SCM empty_list (void); + +#ifndef MIT_SCHEME /* Do not include in the microcode, just shims. */ +extern SCM cons (SCM car, SCM cdr); +/* For debugging messages from shim code. */ +extern void outf_error (const char *, ...); +extern void outf_flush_error (void); +#endif diff --git a/src/microcode/utabmd.scm b/src/microcode/utabmd.scm index 01c52ca89..ae8ea7ad3 100644 --- a/src/microcode/utabmd.scm +++ b/src/microcode/utabmd.scm @@ -110,6 +110,7 @@ USA. PC-Sample/UFO-Table ;3E COMPILED-CODE-BKPT-HANDLER ;3F GC-WABBIT-DESCWIPTOR ;40 + CALLBACK-HANDLER ;41 )) ;;; [] Types diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index b16e68889..0fcee566b 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -58,6 +58,7 @@ USA. ("equals" (runtime equality)) ("error" (runtime error-handler)) ("events" (runtime event-distributor)) + ("ffi" (runtime ffi)) ("fileio" (runtime file-i/o-port)) ("fixart" (runtime fixnum-arithmetic)) ("format" (runtime format)) diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm new file mode 100644 index 000000000..dc53234eb --- /dev/null +++ b/src/runtime/ffi.scm @@ -0,0 +1,505 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Aliens and Alien Functions +;;; package: (runtime ffi) + +(declare (usual-integrations)) + + +;;; Aliens + +(define-structure (alien (constructor %make-alien) + (conc-name %alien/) + (copier copy-alien) + (predicate alien?)) + ;; Two fixnums. + (high-bits 0) (low-bits 0) + ;; A symbol or list. + ctype) + +(set-record-type-unparser-method! rtd:alien + (standard-unparser-method + 'alien + (lambda (alien port) + (write-char #\space port) + (write (%alien/ctype alien) port) + (write-string " 0x" port) + (write-string (alien/address-string alien) port)))) + +(define-integrable alien/ctype %alien/ctype) + +(define-integrable set-alien/ctype! set-%alien/ctype!) + +(define (alien/address-string alien) + ;; Returns a string of length 8, e.g. "081adc60". + (let ((high (%alien/high-bits alien))) + (if (eq? high #f) "< null >" + (let ((low (%alien/low-bits alien)) + (4hex (lambda (n) + (string-pad-left (number->string n 16) 4 #\0)))) + (string-append (4hex high) (4hex low)))))) + +(define (make-alien #!optional ctype) + (let ((ctype (if (default-object? ctype) #f ctype))) + (%make-alien 0 0 ctype))) + +(define-integrable (alien/address alien) + (+ (* (%alien/high-bits alien) #x10000) + (%alien/low-bits alien))) + +(define-integrable (copy-alien-address! alien source) + (if (not (eq? alien source)) + (begin + (set-%alien/high-bits! alien (%alien/high-bits source)) + (set-%alien/low-bits! alien (%alien/low-bits source))))) + +(define-integrable (alien-null? alien) + (and (fix:zero? (%alien/high-bits alien)) + (fix:zero? (%alien/low-bits alien)))) + +(define-integrable (alien-null! alien) + (set-%alien/high-bits! alien 0) + (set-%alien/low-bits! alien 0)) + +(define null-alien (make-alien '|void|)) + +(define-integrable (alien=? alien1 alien2) + (and (fix:= (%alien/high-bits alien1) (%alien/high-bits alien2)) + (fix:= (%alien/low-bits alien1) (%alien/low-bits alien2)))) + +(define (alien-hash alien modulus) + ;; Appropriate for hash table construction (as is alien=?). + (remainder (fix:xor (%alien/high-bits alien) + (%alien/low-bits alien)) modulus)) + +(define (alien-byte-increment alien offset #!optional ctype) + ;; Returns a new alien - a copy of ALIEN - whose address is OFFSET + ;; bytes from ALIEN's. If CTYPE is specified, the type slot of the + ;; new alien is set. + (let ((new (copy-alien alien))) + (alien-byte-increment! new offset) + (if (not (default-object? ctype)) + (set-%alien/ctype! new ctype)) + new)) + +(define (alien-byte-increment! alien increment #!optional ctype) + ;; This procedure returns ALIEN after modifying it to have an + ;; address INCREMENT bytes away from its previous address. If CTYPE + ;; is specified, the type slot of ALIEN is set. + (let ((quotient.remainder (fix:divide increment #x10000))) + (let ((new-high (fix:+ (%alien/high-bits alien) + (integer-divide-quotient quotient.remainder))) + (new-low (fix:+ (%alien/low-bits alien) + (integer-divide-remainder quotient.remainder)))) + (cond ((fix:negative? new-high) + (error:bad-range-argument increment 'alien-byte-increment!)) + ((fix:negative? new-low) + (if (fix:zero? new-high) + (error:bad-range-argument increment 'alien-byte-increment!) + (begin + (set-%alien/low-bits! alien (fix:+ new-low #x10000)) + (set-%alien/high-bits! alien (fix:-1+ new-high))))) + ((fix:>= new-low #x10000) + (set-%alien/low-bits! alien (fix:- new-low #x10000)) + (set-%alien/high-bits! alien (fix:1+ new-high))) + (else + (set-%alien/low-bits! alien new-low) + (set-%alien/high-bits! alien new-high))))) + (if (not (default-object? ctype)) + (set-%alien/ctype! alien ctype)) + alien) + +(define (guarantee-alien operator object #!optional ctype) + (let loop ((object object)) + (if (and (alien? object) + (or (default-object? ctype) + (equal? (%alien/ctype object) ctype))) + object + (loop + (call-with-current-continuation + (lambda (continuation) + (with-restart + 'USE-VALUE ;name + "Continue with an alien." ;reporter + continuation ;effector + (lambda () ;interactor + (values + (prompt-for-evaluated-expression + "New alien (an expression to be evaluated)"))) + (lambda () ;thunk + (error:wrong-type-argument + object "an alien" operator))))))))) + + +;;; Alien Functions + +(define-structure (alien-function + (constructor %make-alien-function) + (conc-name %alien-function/) + (predicate alien-function?) + ;; To be fasdump/loadable. + (type vector) (named 'alien-function) + (print-procedure + (standard-unparser-method 'ALIEN-FUNCTION + (lambda (alienf port) + (write-char #\space port) + (write-string (%alien-function/name alienf) + port))))) + + ;; C function entry address as two fixnums. + high-bits low-bits + + ;; String: name of trampoline. (Starts with "Scm_".) + name + + ;; String: name of shim. (WithOUT "-shim.so" on the end.) + library + + ;; Caseful symbol or list, e.g. (* |GtkWidget|). + return-type + + ;; Alist of parameter names * types, e.g. ((widget (* |GtkWidget|))...) + parameters + + ;; Filename from which the EXTERN declaration was read. + filename + + ;; Band ID + band-id) + +(define (make-alien-function name library return-type params filename) + (%make-alien-function 0 0 (string-append "Scm_" name) + library return-type params filename #f)) + +(define-integrable alien-function/return-type %alien-function/return-type) + +(define-integrable alien-function/parameters %alien-function/parameters) + +(define-integrable alien-function/filename %alien-function/filename) + +(define-integrable (alien-function/name alienf) + (string-tail (%alien-function/name alienf) 4)) + +(define (%set-alien-function/address! alienf address) + (let ((qr (integer-divide address #x10000))) + (set-%alien-function/high-bits! alienf (integer-divide-quotient qr)) + (set-%alien-function/low-bits! alienf (integer-divide-remainder qr)))) + +(define band-id) + +(define (reset-alien-functions!) + (set! band-id (list (get-universal-time)))) + +(define (alien-function-cache! afunc) + (if (eq? band-id (%alien-function/band-id afunc)) + unspecific + (let* ((library (%alien-function/library afunc)) + (name (%alien-function/name afunc)) + (pathname (merge-pathnames + (pathname-new-type (string-append library "-shim") "so") + (system-library-directory-pathname "lib"))) + (handle (or (find-dld-handle + (lambda (h) + (pathname=? pathname (dld-handle-pathname h)))) + (dld-load-file pathname))) + (address (dld-lookup-symbol handle name))) + (if address + (%set-alien-function/address! afunc address) + (error:bad-range-argument afunc 'alien-function-cache!)) + (set-%alien-function/band-id! afunc band-id)))) + +(define (c-peek-cstring alien) + ((ucode-primitive c-peek-cstring 2) alien 0)) + +(define (c-peek-cstring! alien) + ((ucode-primitive c-peek-cstring! 2) alien 0)) + +(define (c-peek-cstringp alien) + ((ucode-primitive c-peek-cstringp 2) alien 0)) + +(define (c-peek-cstringp! alien) + ((ucode-primitive c-peek-cstringp! 2) alien 0)) + +(define (c-poke-pointer dest alien) + ;; Sets the pointer at the alien DEST to point to the ALIEN. + ((ucode-primitive c-poke-pointer 3) dest 0 alien)) + +(define (c-poke-pointer! dest alien) + ;; Like c-poke-pointer, but increments DEST by a pointer width. + ((ucode-primitive c-poke-pointer! 3) dest 0 alien)) + +(define (c-poke-string alien string) + ;; Copy STRING to the bytes at the ALIEN address. + (guarantee-string string 'C-POKE-STRING) + ((ucode-primitive c-poke-string 3) alien 0 string)) + +(define (c-poke-string! alien string) + ;; Like c-poke-string, but increments ALIEN by the null-terminated + ;; STRING length. + (guarantee-string string 'C-POKE-STRING) + ((ucode-primitive c-poke-string! 3) alien 0 string)) + +(define (c-enum-name value enum-name constants) + enum-name + (let loop ((consts constants)) + (if (null? consts) + (error:bad-range-argument value 'c-enum-name) + (let ((name.value (car consts))) + (if (= value (cdr name.value)) + (car name.value) + (loop (cdr consts))))))) + +(define (call-alien alien-function . args) + (if (not (alien-function? alien-function)) + (error:bad-range-argument alien-function 'call-alien)) + (alien-function-cache! alien-function) + (for-each + (lambda (arg) + (if (alien-function? arg) + (alien-function-cache! arg))) + args) + (without-timer-interrupts + (lambda () + (call-alien* alien-function args)))) + +(define (call-alien* alien-function args) + (let ((old-top calloutback-stack)) + (if-tracing + (outf-console ";"(tindent)"=> "alien-function" "args"\n") + (set! calloutback-stack (cons (cons* alien-function args) old-top))) + (let ((value (apply (ucode-primitive c-call) alien-function args))) + (if-tracing + (assert (eq? old-top (cdr calloutback-stack)) + "call-alien: freak stack "calloutback-stack"\n") + (set! calloutback-stack old-top) + (outf-console ";"(tindent)"<= "value"\n")) + value))) + + +;;; Malloc/Free + +;; Weak alist of: ( malloc alien X copy for the finalizer )... +(define malloced-aliens '()) + +(define (finalize-malloced-aliens) + (let loop ((aliens malloced-aliens) + (prev #f)) + (if (pair? aliens) + (if (weak-pair/car? (car aliens)) + (loop (cdr aliens) aliens) + (let ((copy (weak-cdr (car aliens))) + (next (cdr aliens))) + (if prev + (set-cdr! prev next) + (set! malloced-aliens next)) + (if (not (alien-null? copy)) + (begin + ((ucode-primitive c-free 1) copy) + (alien-null! copy))) + (loop next prev)))))) + +(define (reset-malloced-aliens!) + (let loop ((aliens malloced-aliens)) + (if (pair? aliens) + (let ((alien (weak-car (car aliens))) + (copy (weak-cdr (car aliens)))) + (if alien (alien-null! alien)) + (alien-null! copy) + (loop (cdr aliens))))) + (set! malloced-aliens '())) + +(define (malloc size ctype) + ;; Add copy to finalizer BEFORE calling malloc. + (let ((alien (make-alien ctype)) + (copy (make-alien ctype))) + (set! malloced-aliens (cons (weak-cons alien copy) malloced-aliens)) + ((ucode-primitive c-malloc 2) copy size) + ;; Even an interrupt here will not leak a byte. + (copy-alien-address! alien copy) + alien)) + +(define (free alien) + (if (not (alien? alien)) + (warn "Cannot free a non-alien:" alien) + (let ((weak (weak-assq alien malloced-aliens))) + (if (not weak) + (warn "Cannot free an alien that was not malloced:" alien) + (let ((copy (weak-cdr weak))) + (without-interrupts + (lambda () + (if (not (alien-null? copy)) + (begin + (alien-null! copy) + ((ucode-primitive c-free 1) copy) + (alien-null! alien)))))))))) + +(define (weak-assq obj alist) + (let loop ((alist alist)) + (if (null? alist) #f + (let* ((entry (car alist)) + (key (weak-car entry))) + (if (eq? obj key) entry + (loop (cdr alist))))))) + + +;;; Callback support + +(define registered-callbacks) +(define first-free-id) + +(define (reset-callbacks!) + (set! registered-callbacks (make-vector 100 #f)) + (set! first-free-id 1)) + +(define (register-c-callback procedure) + (if (not (procedure? procedure)) + (error:wrong-type-argument procedure "a procedure" 'register-c-callback)) + (without-interrupts + (lambda () + (let ((id first-free-id)) + (set! first-free-id (next-free-id (1+ id))) + (vector-set! registered-callbacks id procedure) + id)))) + +(define (next-free-id id) + (let ((len (vector-length registered-callbacks))) + (let next-id ((id id)) + (cond ((= id len) + (set! registered-callbacks + (vector-grow registered-callbacks (* 2 len))) + (next-free-id id)) + ((not (vector-ref registered-callbacks id)) id) + ;; When not recycling ids, the above is always true. + ;; There is no need for the next-id loop. + (else (next-id (1+ id))))))) + +(define (de-register-c-callback id) + (vector-set! registered-callbacks id #f) + ;; Uncomment to recycle ids. + ;;(if (< id first-free-id) + ;; (set! first-free-id id)) + ) + +(define (normalize-aliens! args) + ;; Any vectors among ARGS are assumed to be freshly-consed aliens + ;; without their record-type. Fix them. + (let ((tag (record-type-dispatch-tag rtd:alien))) + (let loop ((args args)) + (if (null? args) + unspecific + (let ((arg (car args))) + (if (%record? arg) (%record-set! arg 0 tag)) + (loop (cdr args))))))) + +(define (callback-handler id args) + ;; Installed in the fixed-objects-vector, this procedure is called + ;; by a callback trampoline, which ensures that timer interrupts are + ;; masked until the interpreter returns a value. + + (if (not (< id (vector-length registered-callbacks))) + (error:bad-range-argument id 'apply-callback)) + (let ((procedure (vector-ref registered-callbacks id))) + (if (not procedure) + (error:bad-range-argument id 'apply-callback)) + (normalize-aliens! args) + (let ((old-top calloutback-stack)) + (if-tracing + (outf-console ";"(tindent)"=>> "procedure" "args"\n") + (set! calloutback-stack (cons (cons procedure args) old-top))) + (let ((value (apply-callback-proc procedure args))) + (if-tracing + (assert (and (pair? calloutback-stack) + (eq? old-top (cdr calloutback-stack))) + "callback-handler: freak stack "calloutback-stack"\n") + (set! calloutback-stack old-top) + (outf-console ";"(tindent)"<<= "value"\n")) + value)))) + +(define (apply-callback-proc procedure args) + (call-with-current-continuation + (lambda (return) + (with-restart + 'USE-VALUE ;name + "Return a value from the callback." ;reporter + return ;effector + (lambda () ;interactor + (values (prompt-for-evaluated-expression + "Value to return from callback"))) + (lambda () ;thunk + (let ((done? #f)) + (if (not done?) + (begin + (set! done? #t) + (apply procedure args)) + (let loop () + (error "Cannot return from a callback more than once.") + (loop))))))))) + +;; For callback debugging... +(define (outf-console . objects) + ((ucode-primitive outf-console) + (apply string-append + (map (lambda (o) (if (string? o) o (write-to-string o))) + objects)))) + +(define (initialize-callbacks!) + (vector-set! (get-fixed-objects-vector) #x41 callback-handler)) + + +(define calloutback-stack '()) + +(define tracing? #f) + +(define (reset-package!) + (reset-alien-functions!) + (reset-malloced-aliens!) + (reset-callbacks!) + (set! tracing? #f) + (set! calloutback-stack '())) + +(define (initialize-package!) + (reset-package!) + (initialize-callbacks!) + (add-event-receiver! event:after-restore reset-package!) + unspecific) + +(define-syntax if-tracing + (syntax-rules () + ((_ . BODY) + (if tracing? ((lambda () . BODY)))))) + +(define-syntax assert + (syntax-rules () + ((_ TEST . MSG) + (if (not TEST) (error "Failed assert:" . MSG))))) + +(define-syntax trace + (syntax-rules () + ((_ . MSG) + (if tracing? ((lambda () (outf-console . MSG))))))) + +(define (tindent) + (make-string (* 2 (length calloutback-stack)) #\space)) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 6868d92bb..71d81c6d0 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -521,7 +521,8 @@ USA. (RUNTIME HTTP-SYNTAX) (RUNTIME HTTP-CLIENT) (RUNTIME HTML-FORM-CODEC) - (RUNTIME WIN32-REGISTRY))) + (RUNTIME WIN32-REGISTRY) + (RUNTIME FFI))) (let ((obj (file->object "site" #t #f))) (if obj diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 4058fc31b..520065745 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2976,6 +2976,46 @@ USA. directory-channel/descriptor) (initialization (initialize-package!))) +(define-package (runtime ffi) + (parent (runtime)) + (files "ffi") + (export () + make-alien + copy-alien + alien/ctype + set-alien/ctype! + alien? + alien-null? + alien-null! + alien/address-string + null-alien + alien=? + alien-hash + copy-alien-address! + alien-function? + alien-function/name + alien-byte-increment + alien-byte-increment! + guarantee-alien + c-peek-cstring + c-peek-cstring! + c-peek-cstringp + c-peek-cstringp! + c-poke-pointer + c-poke-pointer! + c-poke-string + c-poke-string! + c-enum-name + call-alien + malloc + free + register-c-callback + de-register-c-callback + outf-console) + (import (runtime thread) + without-timer-interrupts) + (initialization (initialize-package!))) + (define-package (runtime program-copier) (files "prgcop") (parent (runtime)) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index c539bfc83..d18c1fb0a 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -283,6 +283,13 @@ USA. (define (allow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING)) +(define (without-timer-interrupts thunk) + (let* ((old-mask + ((ucode-primitive disable-interrupts! 1) interrupt-bit/timer)) + (value (thunk))) + (set-interrupt-enables! old-mask) + value)) + (define (thread-timer-interrupt-handler) (set! next-scheduled-timeout #f) (set-interrupt-enables! interrupt-mask/gc-ok) -- 2.25.1