[Guile-commits] 06/13: Rework foreign-call trampoline

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit 939b1ae23f680365fb6fd0a78653a281aaed95b6
Author: Andy Wingo <address@hidden>
Date:   Sat Aug 11 14:22:32 2018 +0200

    Rework foreign-call trampoline
    
    * libguile/foreign.c (scm_i_foreign_call): Rename back from
      foreign_call.  Need a new trampoline that's easier to call from JIT,
      until we actually rewrite the FFI in terms of the JIT.
      (scm_register_foreign): Remove foreign_call intrinsic init.
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Foreign-call
      intrinsic sets return directly on stack.
    * libguile/vm-engine.c (foreign-call): Adapt to new intrinsic behavior.
    * libguile/vm.c (foreign_call, scm_bootstrap_vm): Add new intrinsic
      wrapper.
---
 libguile/foreign.c    |  9 ++++-----
 libguile/foreign.h    |  3 +++
 libguile/intrinsics.h |  2 +-
 libguile/vm-engine.c  |  8 ++------
 libguile/vm.c         | 14 ++++++++++++++
 5 files changed, 24 insertions(+), 12 deletions(-)

diff --git a/libguile/foreign.c b/libguile/foreign.c
index 7a6f44e..68fa5b2 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1016,9 +1016,9 @@ pack (const ffi_type * type, const void *loc, int 
return_value_p)
 
 #define MAX(A, B) ((A) >= (B) ? (A) : (B))
 
-static SCM
-foreign_call (SCM cif_scm, SCM pointer_scm, SCM *errno_ret,
-              const union scm_vm_stack_element *argv)
+SCM
+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. */
@@ -1070,7 +1070,7 @@ foreign_call (SCM cif_scm, SCM pointer_scm, SCM 
*errno_ret,
   /* off we go! */
   errno = 0;
   ffi_call (cif, func, rvalue, args);
-  *errno_ret = scm_from_int (errno);
+  *errno_ret = errno;
 
   return pack (cif->rtype, rvalue, 1);
 }
@@ -1305,6 +1305,5 @@ scm_register_foreign (void)
                             "scm_init_foreign",
                             (scm_t_extension_init_func)scm_init_foreign,
                             NULL);
-  scm_vm_intrinsics.foreign_call = foreign_call;
   pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 }
diff --git a/libguile/foreign.h b/libguile/foreign.h
index d2278e8..41f26b3 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -104,6 +104,9 @@ 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 cif_scm, SCM pointer_scm,
+                                     int *errno_ret,
+                                     const union scm_vm_stack_element *argv);
 
 
 
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 1305623..877aced 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -116,7 +116,7 @@ typedef uint32_t* (*scm_t_vra_from_thread_intrinsic) 
(scm_thread*);
   M(u32_from_thread_u32_u32, compute_kwargs_npositional, 
"compute-kwargs-npositional", COMPUTE_KWARGS_NPOSITIONAL) \
   M(thread_u32_u32_scm_u8_u8, bind_kwargs, "bind-kwargs", BIND_KWARGS) \
   M(thread_mra, push_interrupt_frame, "push-interrupt-frame", 
PUSH_INTERRUPT_FRAME) \
-  M(scm_from_scm_scm_scmp_sp, foreign_call, "foreign-call", FOREIGN_CALL) \
+  M(thread_scm_scm, foreign_call, "foreign-call", FOREIGN_CALL) \
   M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", 
REINSTATE_CONTINUATION_X) \
   M(scm_from_thread, capture_continuation, "capture-continuation", 
CAPTURE_CONTINUATION) \
   M(thread_scm, compose_continuation, "compose-continuation", 
COMPOSE_CONTINUATION) \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 0948956..26ba168 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -620,7 +620,7 @@ VM_NAME (scm_thread *thread)
   VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (X8_C12_C12))
     {
       uint16_t cif_idx, ptr_idx;
-      SCM closure, cif, pointer, ret, err;
+      SCM closure, cif, pointer;
 
       UNPACK_12_12 (op, cif_idx, ptr_idx);
 
@@ -629,13 +629,9 @@ VM_NAME (scm_thread *thread)
       pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
 
       SYNC_IP ();
-      ret = CALL_INTRINSIC (foreign_call, (cif, pointer, &err, sp));
+      CALL_INTRINSIC (foreign_call, (thread, cif, pointer));
       CACHE_SP ();
 
-      ALLOC_FRAME (2);
-      SP_SET (1, ret);
-      SP_SET (0, err);
-
       NEXT (1);
     }
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 3159aca..d475005 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1194,6 +1194,19 @@ unpack_values_object (scm_thread *thread, SCM obj)
     SCM_FRAME_LOCAL (thread->vm.fp, n) = scm_i_value_ref (obj, n);
 }
 
+static void
+foreign_call (scm_thread *thread, SCM cif, SCM pointer)
+{
+  SCM ret;
+  int err = 0;
+
+  ret = scm_i_foreign_call (cif, pointer, &err, thread->vm.sp);
+
+  alloc_frame (thread, 2);
+  SCM_FRAME_LOCAL (thread->vm.fp, 0) = ret;
+  SCM_FRAME_LOCAL (thread->vm.fp, 1) = scm_from_int (err);
+}
+
 static SCM
 capture_delimited_continuation (struct scm_vm *vp,
                                 union scm_vm_stack_element *saved_fp,
@@ -1701,6 +1714,7 @@ scm_bootstrap_vm (void)
   scm_vm_intrinsics.invoke_return_hook = invoke_return_hook;
   scm_vm_intrinsics.invoke_next_hook = invoke_next_hook;
   scm_vm_intrinsics.invoke_abort_hook = invoke_abort_hook;
+  scm_vm_intrinsics.foreign_call = foreign_call;
 
   sym_keyword_argument_error = scm_from_latin1_symbol 
("keyword-argument-error");
   sym_regular = scm_from_latin1_symbol ("regular");