mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

FFI: Add support for functions that set 'errno'.

Browse source 
Implements wishlist item <https://debbugs.gnu.org/18592>.
Requested by Frank Terbeck <ft@bewatermyfriend.org>.
Based on a proposed patch by Nala Ginrut <nalaginrut@gmail.com>.
Patch ported to 2.2 by Andy Wingo <wingo@pobox.com>.

* libguile/foreign.c (cif_to_procedure): Add 'with_errno' argument.
  If true, truncate result to only one return value.
  (scm_i_foreign_call): Separate the arguments.  Always return errno.
  (pointer_to_procedure): New static function.
  (scm_pointer_to_procedure_with_errno): New C API function, implemented
  in terms of 'pointer_to_procedure'.
  (scm_pointer_to_procedure): Reimplement in terms of
  'pointer_to_procedure', no longer bound to "pointer->procedure".  See
  below.
  (scm_i_pointer_to_procedure): New C function bound to
  "pointer->procedure" which now accepts the optional #:return-errno?
  keyword argument, implemented in terms of 'pointer_to_procedure'.
  (k_return_errno): New keyword #:return-errno?.
* libguile/foreign.h (scm_pointer_to_procedure_with_errno): Add prototype.
* doc/ref/api-foreign.texi (Dynamic FFI): Adjust documentation.
* libguile/vm-engine.c (foreign-call): Return two values.
This commit is contained in:
Mark H Weaver 2016-01-05 16:30:41 -05:00 • committed by Andy Wingo
parent 546eb479b1
commit a396e14cb1
4 changed files with 101 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

15
doc/ref/api-foreign.texi
View file

@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008,
@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Foreign Function Interface
@ -813,8 +813,11 @@ tightly packed structs and unions by hand. See the code for
Of course, the land of C is not all nouns and no verbs: there are
functions too, and Guile allows you to call them.
@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types
@deffnx {C Procedure} scm_pointer_to_procedure (return_type, func_ptr, arg_types)
@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types @
[#:return-errno?=#f]
@deffnx {C Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types)
@deffnx {C Function} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types)
Make a foreign function.
Given the foreign void pointer @var{func_ptr}, its argument and
@ -825,6 +828,10 @@ and return appropriate values.
@var{arg_types} should be a list of foreign types.
@code{return_type} should be a foreign type. @xref{Foreign Types}, for
more information on foreign types.
If @var{return-errno?} is true, or when calling
@code{scm_pointer_to_procedure_with_errno}, the returned procedure will
return two values, with @code{errno} as the second value.
@end deffn
Here is a better definition of @code{(math bessel)}:

122
libguile/foreign.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2010-2013 Free Software Foundation, Inc.
/* Copyright (C) 2010-2016 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -26,6 +26,7 @@
#include <alignof.h>
#include <string.h>
#include <assert.h>
#include <errno.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
@ -75,7 +76,7 @@ null_pointer_error (const char *func_name)
}
static SCM cif_to_procedure (SCM cif, SCM func_ptr);
static SCM cif_to_procedure (SCM cif, SCM func_ptr, int with_errno);
static SCM pointer_weak_refs = SCM_BOOL_F;
@ -740,16 +741,10 @@ make_cif (SCM return_type, SCM arg_types, const char *caller)
}
#undef FUNC_NAME
SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
(SCM return_type, SCM func_ptr, SCM arg_types),
"Make a foreign function.\n\n"
"Given the foreign void pointer @var{func_ptr}, its argument and\n"
"return types @var{arg_types} and @var{return_type}, return a\n"
"procedure that will pass arguments to the foreign function\n"
"and return appropriate values.\n\n"
"@var{arg_types} should be a list of foreign types.\n"
"@code{return_type} should be a foreign type.")
#define FUNC_NAME s_scm_pointer_to_procedure
static SCM
pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types,
int with_errno)
#define FUNC_NAME "pointer->procedure"
{
ffi_cif *cif;
@ -757,45 +752,81 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0,
cif = make_cif (return_type, arg_types, FUNC_NAME);
return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr);
return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr,
with_errno);
}
#undef FUNC_NAME
SCM
scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types)
{
return pointer_to_procedure (return_type, func_ptr, arg_types, 0);
}
SCM
scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr,
SCM arg_types)
{
return pointer_to_procedure (return_type, func_ptr, arg_types, 1);
}
SCM_KEYWORD (k_return_errno, "return-errno?");
SCM_INTERNAL SCM scm_i_pointer_to_procedure (SCM, SCM, SCM, SCM);
SCM_DEFINE (scm_i_pointer_to_procedure, "pointer->procedure", 3, 0, 1,
(SCM return_type, SCM func_ptr, SCM arg_types, SCM keyword_args),
"Make a foreign function.\n\n"
"Given the foreign void pointer @var{func_ptr}, its argument and\n"
"return types @var{arg_types} and @var{return_type}, return a\n"
"procedure that will pass arguments to the foreign function\n"
"and return appropriate values.\n\n"
"@var{arg_types} should be a list of foreign types.\n"
"@code{return_type} should be a foreign type.\n"
"If the @code{#:return-errno?} keyword argument is provided and\n"
"its value is true, then the returned procedure will return two\n"
"values, with @code{errno} as the second value.")
#define FUNC_NAME s_scm_i_pointer_to_procedure
{
SCM return_errno = SCM_BOOL_F;
scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
k_return_errno, &return_errno,
SCM_UNDEFINED);
return pointer_to_procedure (return_type, func_ptr, arg_types,
scm_to_bool (return_errno));
}
#undef FUNC_NAME
/* We support calling foreign functions with up to 100 arguments. */
#define CODE(nreq) \
SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
SCM_PACK_OP_12_12 (foreign_call, 0, 1), \
SCM_PACK_OP_24 (handle_interrupts, 0), \
SCM_PACK_OP_24 (return_values, 0)
#define CODE_10(n) \
CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \
CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9)
static const scm_t_uint32 foreign_stub_code[] =
{
CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40),
CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90)
};
#undef CODE
#undef CODE_10
static const scm_t_uint32 *
get_foreign_stub_code (unsigned int nargs)
get_foreign_stub_code (unsigned int nargs, int with_errno)
{
if (nargs >= 100)
scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
SCM_EOL);
size_t i;
size_t code_len = with_errno ? 4 : 5;
scm_t_uint32 *code;
return &foreign_stub_code[nargs * 4];
code = scm_gc_malloc_pointerless (code_len * sizeof (scm_t_uint32),
"foreign code");
if (nargs >= (1 << 24) + 1)
scm_misc_error ("make-foreign-function", "too many arguments: ~a",
scm_list_1 (scm_from_uint (nargs)));
i = 0;
code[i++] = SCM_PACK_OP_24 (assert_nargs_ee, nargs + 1);
code[i++] = SCM_PACK_OP_12_12 (foreign_call, 0, 1);
code[i++] = SCM_PACK_OP_24 (handle_interrupts, 0);
if (!with_errno)
code[i++] = SCM_PACK_OP_24 (reset_frame, 2);
code[i++] = SCM_PACK_OP_24 (return_values, 0);
return code;
}
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
cif_to_procedure (SCM cif, SCM func_ptr, int with_errno)
{
ffi_cif *c_cif;
SCM ret;
@ -805,7 +836,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs));
SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
@ -960,7 +991,8 @@ pack (const ffi_type * type, const void *loc, int return_value_p)
SCM
scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret,
const union scm_vm_stack_element *argv)
{
/* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
objtable. */
@ -973,8 +1005,8 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
size_t arg_size;
scm_t_ptrdiff off;
cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
func = SCM_POINTER_VALUE (SCM_CDR (foreign));
cif = SCM_POINTER_VALUE (cif_scm);
func = SCM_POINTER_VALUE (pointer_scm);
/* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs);
@ -1010,7 +1042,9 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv)
max (sizeof (void *), cif->rtype->alignment));
/* off we go! */
errno = 0;
ffi_call (cif, func, rvalue, args);
*errno_ret = errno;
return pack (cif->rtype, rvalue, 1);
}

7
libguile/foreign.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_FOREIGN_H
#define SCM_FOREIGN_H
/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
/* Copyright (C) 2010, 2011, 2012, 2013, 2016 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -97,9 +97,12 @@ union scm_vm_stack_element;
SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_API SCM scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign,
SCM_INTERNAL SCM scm_i_foreign_call (SCM cif_scm, SCM pointer_scm,
int *errno_ret,
const union scm_vm_stack_element *argv);

29
libguile/vm-engine.c
View file

@ -791,6 +791,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (X8_C12_C12))
{
scm_t_uint16 cif_idx, ptr_idx;
int err = 0;
SCM closure, cif, pointer, ret;
UNPACK_12_12 (op, cif_idx, ptr_idx);
@ -800,30 +801,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
SYNC_IP ();
// FIXME: separate args
ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), sp);
ret = scm_i_foreign_call (cif, pointer, &err, sp);
CACHE_SP ();
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
SCM vals = scm_struct_ref (ret, SCM_INUM0);
long len = scm_ilength (vals);
ALLOC_FRAME (1 + len);
while (len--)
{
SP_SET (len, SCM_CAR (vals));
vals = SCM_CDR (vals);
}
NEXT (1);
}
else
{
ALLOC_FRAME (2);
SP_SET (0, ret);
NEXT (1);
}
ALLOC_FRAME (3);
SP_SET (1, ret);
SP_SET (0, scm_from_int (err));
NEXT (1);
}
/* continuation-call contregs:24