[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/02: FFI: Add support for functions that set 'errno'.
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/02: FFI: Add support for functions that set 'errno'. |
|
Date: |
Sun, 18 Dec 2016 22:06:39 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit a396e14cb139eba37eeeea44e745bfc57bd1f37d
Author: Mark H Weaver <address@hidden>
Date: Tue Jan 5 16:30:41 2016 -0500
FFI: Add support for functions that set 'errno'.
Implements wishlist item <https://debbugs.gnu.org/18592>.
Requested by Frank Terbeck <address@hidden>.
Based on a proposed patch by Nala Ginrut <address@hidden>.
Patch ported to 2.2 by Andy Wingo <address@hidden>.
* 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.
---
doc/ref/api-foreign.texi | 15 ++++--
libguile/foreign.c | 114 ++++++++++++++++++++++++++++++----------------
libguile/foreign.h | 7 ++-
libguile/vm-engine.c | 29 +++---------
4 files changed, 97 insertions(+), 68 deletions(-)
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 76614f0..5279022 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2008,
address@hidden 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation,
Inc.
address@hidden Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016
address@hidden 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.
address@hidden {Scheme Procedure} pointer->procedure return_type func_ptr
arg_types
address@hidden {C Procedure} scm_pointer_to_procedure (return_type, func_ptr,
arg_types)
address@hidden {Scheme Procedure} pointer->procedure return_type func_ptr
arg_types @
+ [#:return-errno?=#f]
address@hidden {C Function} scm_pointer_to_procedure (return_type, func_ptr,
arg_types)
address@hidden {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
address@hidden, 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)}:
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 17a3eed..17af101 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -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);
+}
-/* We support calling foreign functions with up to 100 arguments. */
+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);
+}
-#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)
+SCM_KEYWORD (k_return_errno, "return-errno?");
-#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)
+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);
-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)
- };
+ return pointer_to_procedure (return_type, func_ptr, arg_types,
+ scm_to_bool (return_errno));
+}
+#undef FUNC_NAME
-#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;
+
+ 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 &foreign_stub_code[nargs * 4];
+ 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);
}
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 4c1a19f..a0c09cc 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4406845..195237a 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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