From: Matt Birkholz Date: Mon, 31 May 2010 20:39:18 +0000 (-0700) Subject: A fairly straightforward merge of the FFI. X-Git-Tag: 20100708-Gtk~36^2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b08ba0a5e5be9f1a46c3437c966501940fe0ebe7;p=mit-scheme.git A fairly straightforward merge of the FFI. * src/etc/Clean.sh (maintainer-clean): Clean up src/*/TAGS. * src/ffi/Clean.sh (maintainer-clean): Clean up prhello-const*. * src/ffi/ffi.cbf, src/ffi/ffi.sf: Separate syntaxing and compiling. Temporarily hacked to load the (runtime ffi) package when necessary. Replaces compile.scm. * src/ffi/make.scm: Replaces load.scm. * src/ffi/compile.scm, src/ffi/load.scm: Replaced by ffi.sf, ffi.cbf and make.scm. --- b08ba0a5e5be9f1a46c3437c966501940fe0ebe7 diff --cc doc/Makefile.in index 0563f2d39,59e772726..e27b25be3 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@@ -1,7 -1,8 +1,4 @@@ -# $Id: Makefile.in,v 1.17 2008/01/30 20:06:10 cph Exp $ -# --# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, --# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, - # 2005, 2006, 2007, 2008, 2009 Massachusetts Institute of - # Technology -# 2005, 2006, 2007, 2008 Massachusetts Institute of Technology ++# Copyright (C) 2010 Massachusetts Institute of Technology # # This file is part of MIT/GNU Scheme. # diff --cc doc/configure.ac index 5b1dc6b1d,908fc513d..eaa0c3ff5 --- a/doc/configure.ac +++ b/doc/configure.ac @@@ -7,9 -7,10 +7,7 @@@ AC_INIT([MIT/GNU Scheme documentation] AC_CONFIG_SRCDIR([ref-manual/scheme.texinfo]) AC_COPYRIGHT( --[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, -- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology - 2006, 2007, 2008 Massachusetts Institute of Technology ++[Copyright (C) 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. diff --cc doc/ffi/Makefile.in index 000000000,6b2c6b274..fdca4e10f mode 000000,100644..100644 --- a/doc/ffi/Makefile.in +++ b/doc/ffi/Makefile.in @@@ -1,0 -1,12 +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 ++TEXINFO_ROOT = ffi + TARGET_ROOT = mit-scheme-ffi + + include $(top_srcdir)/make-common diff --cc doc/ffi/ffi.texinfo index 000000000,99ab2c2ff..6ff732b5b mode 000000,100644..100644 --- a/doc/ffi/ffi.texinfo +++ b/doc/ffi/ffi.texinfo @@@ -1,0 -1,1225 +1,1224 @@@ + \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 ++Copyright @copyright{} 2010 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. ++This FFI provides Scheme syntax for calling C functions and accessing ++C data. The functions and data structures are 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 compiled and linked to the C toolkit, producing 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. ++needed at syntax time. The compiled @file{-shim.so} file is used at ++run time, dynamically loaded into the Scheme machine. @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) ++(C-> alien "GtkWidget style" 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. ++address is a GtkWidget. Load its @code{style} member (an alien ++address), into @code{alien} (clobbering @code{alien}'s old address).'' + + 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 ++optional preamble. It reads the @file{@i{library}.cdecl} file and ++writes two @file{.c} files. The preamble 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. ++installing a shim for the example ``Hello, World!'' program. They can ++be found in @file{src/ffi/Makefile} + + @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/. ++ $(INSTALL_DATA) prhello-types.bin ../lib/. ++ $(INSTALL_DATA) prhello-const.bin ../lib/. ++ $(INSTALL_DATA) prhello-shim.so ../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 ++ | ../microcode/scheme --library ../lib --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: ++To run the example: + + @smallexample + @verbatim ++ cd src/ffi/ ++ make install-example ++ ../microcode/scheme --library ../lib + (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. ++You might also syntax the Scheme code first, as in the following ++script. The syntactic transformers of the FFI are needed here. + + @smallexample + @verbatim ++ ../microcode/scheme --library ../lib --batch-mode < $@ + compile-microcode: (cd microcode && $(MAKE) all) diff --cc src/Setup.sh index be098824a,d6ffacffc..8145f2cc1 --- a/src/Setup.sh +++ b/src/Setup.sh @@@ -72,6 -45,9 +72,8 @@@ maybe_link lib/lib ../microcod 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 --cc src/configure.ac index 490d06153,92887611a..1f6bb9ee9 --- a/src/configure.ac +++ b/src/configure.ac @@@ -136,8 -91,7 +137,8 @@@ if test x"${mit_scheme_native_code}" = 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 ++ 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 --cc src/etc/Clean.sh index 56a40cae5,cf9855496..10d048b4c --- a/src/etc/Clean.sh +++ b/src/etc/Clean.sh @@@ -82,6 -83,6 +82,7 @@@ if [ ${MAINTAINER} = yes ]; the maybe_rm Makefile.in maybe_rm Makefile-bundle fi ++ maybe_rm TAGS fi for KEYWORD in ${KEYWORDS}; do diff --cc src/etc/create-makefiles.sh index 90bde24c3,20f8e2dc5..9e7dcda3d --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@@ -47,9 -48,11 +47,9 @@@ run_cmd rm -f compiler/machine compiler 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 --batch-mode <" ++ exit 1 ++fi ++ ++../etc/Clean.sh "${1}" ++. ../etc/functions.sh ++ ++maybe_rm prhello-const prhello-const.scm diff --cc src/ffi/Makefile-fragment index 000000000,4390b5777..e530bb020 mode 000000,100644..100644 --- a/src/ffi/Makefile-fragment +++ b/src/ffi/Makefile-fragment @@@ -1,0 -1,48 +1,47 @@@ + #-*-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/. ++ $(INSTALL_DATA) prhello-types.bin ../lib/. ++ $(INSTALL_DATA) prhello-const.bin ../lib/. ++ $(INSTALL_DATA) prhello-shim.so ../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 ++ | ../microcode/scheme --library ../lib --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 --cc src/ffi/cdecls.scm index 000000000,fd23c56a4..323adcedd mode 000000,100644..100644 --- a/src/ffi/cdecls.scm +++ b/src/ffi/cdecls.scm @@@ -1,0 -1,367 +1,365 @@@ + #| -*-Scheme-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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))))))))) diff --cc src/ffi/ctypes.scm index 000000000,53eb4d46c..14d91fbc0 mode 000000,100644..100644 --- a/src/ffi/ctypes.scm +++ b/src/ffi/ctypes.scm @@@ -1,0 -1,294 +1,292 @@@ + #| -*-Scheme-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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))))) diff --cc src/ffi/ed-ffi.scm index 000000000,c58e44901..3377386c5 mode 000000,100644..100644 --- a/src/ffi/ed-ffi.scm +++ b/src/ffi/ed-ffi.scm @@@ -1,0 -1,12 +1,10 @@@ + #| -*- Scheme -*- + -$Id: $ - + FFI buffer packaging info |# + + (standard-scheme-find-file-initialization + '#( + ("ctypes" (ffi)) + ("cdecls" (ffi)) + ("syntax" (ffi)) + ("generator" (ffi generate)))) diff --cc src/ffi/ffi.cbf index 000000000,000000000..d81904058 new file mode 100644 --- /dev/null +++ b/src/ffi/ffi.cbf @@@ -1,0 -1,0 +1,6 @@@ ++#| -*-Scheme-*- ++ ++Compile the FFI system. |# ++ ++(fluid-let ((compiler:coalescing-constant-warnings? #f)) ++ (compile-directory ".")) diff --cc src/ffi/ffi.pkg index 000000000,f4524674c..cf471ce51 mode 000000,100644..100644 --- a/src/ffi/ffi.pkg +++ b/src/ffi/ffi.pkg @@@ -1,0 -1,38 +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) ++ (import (runtime syntax environment) ++ syntactic-environment->environment) + (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)) diff --cc src/ffi/ffi.sf index 000000000,000000000..2dc098295 new file mode 100644 --- /dev/null +++ b/src/ffi/ffi.sf @@@ -1,0 -1,0 +1,42 @@@ ++#| -*-Scheme-*- ++ ++Syntax the FFI system. |# ++ ++(load-option 'CREF) ++ ++;; Temporary hack, until (runtime ffi) is in the released version. ++(if (not (name->package '(RUNTIME FFI))) ++ (let ((path (package-set-pathname "../runtime/runtime"))) ++ (if (not (file-exists? path)) ++ (cref/generate-trivial-constructor "../runtime/runtime")) ++ (eval `(for-each-vector-element ++ (package-file/descriptions (fasload ,path)) ++ (lambda (description) ++ (if (equal? (package-description/name description) '(RUNTIME FFI)) ++ (begin ++ (construct-normal-package-from-description description) ++ (create-links-from-description description) ++ (load "../runtime/ffi" (->environment '(RUNTIME FFI)) ++ 'ignored #t))))) ++ (->environment '(PACKAGE))))) ++ ++(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 esp. ucode-primitive in (ffi). ++ (if (not (name->package '(FFI))) ++ (let ((path (package-set-pathname "ffi"))) ++ (if (not (file-exists? path)) ++ (cref/generate-trivial-constructor "ffi")) ++ (construct-packages-from-file (fasload path)))) ++ ++ ;; Syntax everything 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)))) diff --cc src/ffi/generator.scm index 000000000,fe34e3386..c7e6ebbea mode 000000,100644..100644 --- a/src/ffi/generator.scm +++ b/src/ffi/generator.scm @@@ -1,0 -1,691 +1,689 @@@ + #| -*-Scheme-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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)))))) diff --cc src/ffi/make.scm index 000000000,1c713c6d3..0876e4f5e mode 000000,100644..100644 --- a/src/ffi/make.scm +++ b/src/ffi/make.scm @@@ -1,0 -1,10 +1,8 @@@ + #| -*-Scheme-*- + -$Id: $ - -Load the FFI system. |# ++Build the FFI system. |# + + (with-loader-base-uri (system-library-uri "ffi/") + (lambda () + (load-package-set "ffi"))) + (add-subsystem-identification! "FFI" '(0 1)) diff --cc src/ffi/prhello.cdecl index 000000000,3eda4476d..91a85df34 mode 000000,100644..100644 --- a/src/ffi/prhello.cdecl +++ b/src/ffi/prhello.cdecl @@@ -1,0 -1,86 +1,85 @@@ + #| -*-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) ++(extern void gtk_main_quit) diff --cc src/ffi/prhello.scm index 000000000,7aaf1614f..25caeff5f mode 000000,100644..100644 --- a/src/ffi/prhello.scm +++ b/src/ffi/prhello.scm @@@ -1,0 -1,57 +1,55 @@@ + #| -*-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)) diff --cc src/ffi/syntax.scm index 000000000,9425ad590..e550a98cd mode 000000,100644..100644 --- a/src/ffi/syntax.scm +++ b/src/ffi/syntax.scm @@@ -1,0 -1,510 +1,507 @@@ + #| -*-Scheme-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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"))) ++ (let* ((lib (merge-pathnames library (system-library-directory-pathname))) + (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 ++ 'ffi-syntaxer-error + condition-type:error + '(FORM MESSAGE) + (lambda (condition port) - (write-string "Syntax error: " port) ++ (write-string "FFI 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))))))) diff --cc src/microcode/configure.ac index a2126d7f2,86f4c038b..6ea3b0c1b --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@@ -943,45 -910,75 +943,45 @@@ if test "${no_x}" != yes; the fi if test "x${x_libraries}" != x; then FOO=-L`echo ${x_libraries} | sed -e "s/:/ -L/g"` - LIBS="${LIBS} ${FOO}" + LDFLAGS="${LDFLAGS} ${FOO}" fi - LIBS="${LIBS} -lX11" - OPTIONAL_BASES="${OPTIONAL_BASES} x11base x11term x11graph x11color" + MODULE_LIBS="-lX11 ${MODULE_LIBS}" + MODULE_BASES="${MODULE_BASES} prx11" + MODULE_AUX_BASES="${MODULE_AUX_BASES} x11base x11color x11graph x11term" +fi + +dnl Check for dynamic loader support. +AC_CHECK_FUNC([dlopen], + [], + [ + AC_CHECK_LIB([dl], [dlopen], + [ + AC_DEFINE([HAVE_LIBDL], [1], + [Define to 1 if you have the `dl' library (-ldl).]) + LIBS="-ldl ${LIBS}" + ], + [ + if test ${mit_scheme_native_code} = c; then + AC_MSG_ERROR( + [--enable-native-code=c requires dynamic loader support]) + fi + ]) + ]) - 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.]) + +if test ${enable_valgrind_mode} != no; then + SCHEME_DEFS="${SCHEME_DEFS} -DVALGRIND_MODE" + M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1" fi -AC_MSG_CHECKING([for native-code support]) OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl" -GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h" -SCM_ARCH=none -ENC_WARNP=no - -case ${enable_native_code} in -yes) - case ${host_cpu} in - alpha*) - SCM_ARCH=alpha - ;; - hppa*) - SCM_ARCH=hppa - GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h" - ;; - i?86) - SCM_ARCH=i386 - ;; - # x86_64) - # SCM_ARCH=i386 - # CFLAGS="${CFLAGS} -m32" - # LDFLAGS="${LDFLAGS} -m32" - # ;; - m68k|m680?0) - SCM_ARCH=mc68k - ;; - mips*) - SCM_ARCH=mips - ;; - vax) - SCM_ARCH=vax - ;; - esac - ;; -c) - SCM_ARCH=c - ;; -svm) - SCM_ARCH=svm1 - ;; -no|none) - ;; -*) - dnl This is not quite right, because the compiler and microcode - dnl disagree abou what some architectures should be called, such as - dnl bobcat vs mc68k or spectrum versus hppa. I don't know what the - dnl state of Scheme on these architectures is, however, so at least - dnl this will flag an error if you try to use them. - if test -f "cmpauxmd/${enable_native_code}.m4"; then - SCM_ARCH="${enable_native_code}" - else - ENC_WARNP=yes - fi - ;; -esac -case ${SCM_ARCH} in +case ${mit_scheme_native_code} in none) - AC_MSG_RESULT([no]) ;; c) - AC_MSG_RESULT([yes, using portable C code]) AC_CONFIG_LINKS([cmpauxmd.c:cmpauxmd/c.c]) AC_CONFIG_FILES([liarc-cc], [chmod +x liarc-cc]) AC_CONFIG_FILES([liarc-ld], [chmod +x liarc-ld]) diff --cc src/microcode/fixobj.h index afc33febc,f93da7424..528ff7f27 --- a/src/microcode/fixobj.h +++ b/src/microcode/fixobj.h @@@ -119,79 -122,7 +119,81 @@@ 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 + +#define FIXED_OBJECTS_NAMES \ +{ \ + /* 0x00 */ "non-object", \ + /* 0x01 */ "system-interrupt-vector", \ + /* 0x02 */ "system-error-vector", \ + /* 0x03 */ "obarray", \ + /* 0x04 */ "microcode-types-vector", \ + /* 0x05 */ "microcode-returns-vector", \ + /* 0x06 */ "interrupt-mask-vector", \ + /* 0x07 */ "microcode-errors-vector", \ + /* 0x08 */ "microcode-identification-vector", \ + /* 0x09 */ "system-call-names", \ + /* 0x0A */ "system-call-errors", \ + /* 0x0B */ "gc-daemon", \ + /* 0x0C */ "trap-handler", \ + /* 0x0D */ "edwin-auto-save", \ + /* 0x0E */ "stepper-state", \ + /* 0x0F */ "microcode-fixed-objects-slots", \ + /* 0x10 */ "files-to-delete", \ + /* 0x11 */ "state-space-tag", \ + /* 0x12 */ "state-point-tag", \ + /* 0x13 */ "dummy-history", \ + /* 0x14 */ "bignum-one", \ + /* 0x15 */ 0, \ + /* 0x16 */ "microcode-terminations-vector", \ + /* 0x17 */ "microcode-terminations-procedures", \ + /* 0x18 */ 0, \ + /* 0x19 */ 0, \ + /* 0x1A */ 0, \ + /* 0x1B */ 0, \ + /* 0x1C */ 0, \ + /* 0x1D */ "error-procedure", \ + /* 0x1E */ 0, \ + /* 0x1F */ 0, \ + /* 0x20 */ "compiler-error-procedure", \ + /* 0x21 */ 0, \ + /* 0x22 */ "state-space-root", \ + /* 0x23 */ "primitive-profiling-table", \ + /* 0x24 */ "generic-trampoline-zero?", \ + /* 0x25 */ "generic-trampoline-positive?", \ + /* 0x26 */ "generic-trampoline-negative?", \ + /* 0x27 */ "generic-trampoline-add-1", \ + /* 0x28 */ "generic-trampoline-subtract-1", \ + /* 0x29 */ "generic-trampoline-equal?", \ + /* 0x2A */ "generic-trampoline-less?", \ + /* 0x2B */ "generic-trampoline-greater?", \ + /* 0x2C */ "generic-trampoline-add", \ + /* 0x2D */ "generic-trampoline-subtract", \ + /* 0x2E */ "generic-trampoline-multiply", \ + /* 0x2F */ "generic-trampoline-divide", \ + /* 0x30 */ "generic-trampoline-quotient", \ + /* 0x31 */ "generic-trampoline-remainder", \ + /* 0x32 */ "generic-trampoline-modulo", \ + /* 0x33 */ "arity-dispatcher-tag", \ + /* 0x34 */ "pc-sample/builtin-table" \ + /* 0x35 */ "pc-sample/utility-table", \ + /* 0x36 */ "pc-sample/primitive-table", \ + /* 0x37 */ "pc-sample/code-block-table", \ + /* 0x38 */ "pc-sample/purified-code-block-block-buffer", \ + /* 0x39 */ "pc-sample/purified-code-block-offset-buffer", \ + /* 0x3A */ "pc-sample/heathen-code-block-block-buffer", \ + /* 0x3B */ "pc-sample/heathen-code-block-offset-buffer", \ + /* 0x3C */ "pc-sample/interp-proc-buffer", \ + /* 0x3D */ "pc-sample/prob-comp-table", \ + /* 0x3E */ "pc-sample/ufo-table", \ + /* 0x3F */ "compiled-code-bkpt-handler", \ + /* 0x40 */ "gc-wabbit-descwiptor", \ + /* 0x41 */ 0, \ + /* 0x42 */ 0, \ + /* 0x43 */ 0, \ + /* 0x44 */ 0, \ + /* 0x45 */ 0 \ +} diff --cc src/microcode/makegen/Makefile.in.in index 6279a7f6a,807ed990a..89824c892 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@@ -221,6 -223,6 +221,9 @@@ prx11.so: prx11.o x11base.o x11color.o tags: TAGS TAGS: etags -r '/^DEF[A-Z0-9_]*[ \t]*(\("[^"]+"\|[a-zA-Z_][a-zA-Z0-9_]*\)/' \ ++ *.[ch] */*.[ch] \ ++ || etags \ ++ --regex-C='/^DEF[A-Z0-9_]*[ \t]*\(("[^"]+"|[a-zA-Z_][a-zA-Z0-9_]+)/\1/'\ *.[ch] */*.[ch] mostlyclean: diff --cc src/microcode/makegen/files-optional.scm index 990fefbd2,5431e4472..81bf608a6 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@@ -34,7 -36,7 +34,8 @@@ USA "prmhash" "prpgsql" "pruxdld" + "pruxffi" +"prx11" "svm1-interp" "termcap" "terminfo" diff --cc src/microcode/pruxffi.c index 000000000,7e93d31cd..0506bab9b mode 000000,100644..100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@@ -1,0 -1,1189 +1,1187 @@@ + /* -*-C-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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. */ + + 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(); + Interpret (1); + 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) + { + /* 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 (); + + Will_Push (STACK_ENV_EXTRA_SLOTS + 3); + STACK_PUSH (arglist); + STACK_PUSH (fixnum_id); + STACK_PUSH (handler); + PUSH_APPLY_FRAME_HEADER (2); + Pushed (); + } + + 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 --cc src/microcode/pruxffi.h index 000000000,9cb0717bb..25f4d4bc6 mode 000000,100644..100644 --- a/src/microcode/pruxffi.h +++ b/src/microcode/pruxffi.h @@@ -1,0 -1,97 +1,95 @@@ + /* -*-C-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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 --cc src/runtime/ffi.scm index 000000000,18d45a7a3..038c09686 mode 000000,100644..100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@@ -1,0 -1,509 +1,507 @@@ + #| -*-Scheme-*- + -$Id: $ - -Copyright (C) 2006, 2007, 2008, 2009 Matthew Birkholz ++Copyright (C) 2010 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"))) ++ (system-library-directory-pathname))) + (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-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))) ++ (let ((value (apply (ucode-primitive c-call -1) 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 c-free )... + (define malloced-aliens '()) + + (define (free-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 malloced-aliens BEFORE calling malloc. + (let ((alien (make-alien ctype)) + (copy (make-alien ctype))) + (let ((entry (weak-cons alien copy))) + (without-interrupts + (lambda () + (set! malloced-aliens (cons entry 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? alien)) + (begin + (alien-null! alien) + ((ucode-primitive c-free 1) copy) + (alien-null! copy)))))))))) + + (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. The callout should have already masked + ;; all but the GC interrupts. + + (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) ++ ((ucode-primitive outf-console 1) + (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 trace? #f) + + (define (reset-package!) + (reset-alien-functions!) + (reset-malloced-aliens!) + (reset-callbacks!) + (set! trace? #f) + (set! calloutback-stack '())) + + (define (initialize-package!) + (reset-package!) + (initialize-callbacks!) + (add-event-receiver! event:after-restore reset-package!) + (add-gc-daemon! free-malloced-aliens) + unspecific) + + (define-syntax if-tracing + (syntax-rules () + ((_ . BODY) + (if trace? ((lambda () . BODY)))))) + + (define-syntax assert + (syntax-rules () + ((_ TEST . MSG) + (if (not TEST) (error "Failed assert:" . MSG))))) + + (define-syntax trace + (syntax-rules () + ((_ . MSG) + (if trace? ((lambda () (outf-console . MSG))))))) + + (define (tindent) + (make-string (* 2 (length calloutback-stack)) #\space)) diff --cc src/runtime/make.scm index 302925d21,71d81c6d0..b1210c11c --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@@ -537,7 -521,8 +537,8 @@@ USA (RUNTIME HTTP-SYNTAX) (RUNTIME HTTP-CLIENT) (RUNTIME HTML-FORM-CODEC) - (OPTIONAL (RUNTIME WIN32-REGISTRY)))) - (RUNTIME WIN32-REGISTRY) - (RUNTIME FFI))) ++ (OPTIONAL (RUNTIME WIN32-REGISTRY)) ++ (OPTIONAL (RUNTIME FFI)))) (let ((obj (file->object "site" #t #f))) (if obj