From 7d3765a319a2edeb8f55ae5517e11862fb623ae1 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 12 Jan 2018 01:51:49 -0700 Subject: [PATCH] ffi: Re-alienate the floenv after Scheme is re-entered. Also, preserve the floenv around callouts, and set it to the default for callbacks (as for interrupts). And clean up some trailing whitespace. --- src/microcode/pruxffi.c | 5 +++-- src/runtime/ffi.scm | 22 +++++++++++++--------- 2 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index 566e07175..d14a06dfc 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -719,6 +719,7 @@ callback_run_kernel (long callback_id, CallbackKernel kernel) SET_LEXPR_ACTUALS (nargs); cstack_depth -= 1; + alienate_float_environment (); } DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0) @@ -726,7 +727,7 @@ 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; @@ -1098,7 +1099,7 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) /* To avoid the normal IO system when debugging a callback. */ PRIMITIVE_HEADER (1); - { + { SCM arg = ARG_REF (1); if (STRING_P (arg)) { diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index fe2707ebc..64f6cf172 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -228,7 +228,7 @@ USA. (define-integrable alien-function/filename %alien-function/filename) (define-integrable (alien-function/name alienf) - (string-tail (%alien-function/name alienf) 4)) + (string-tail (%alien-function/name alienf) 4)) (define (%set-alien-function/address! alienf address) (let ((qr (integer-divide address %radix))) @@ -370,7 +370,9 @@ USA. (lambda () (without-interrupts (lambda () - (call-alien* alien-function args)))))) + (flo:preserving-environment + (lambda () + (call-alien* alien-function args)))))))) #;(define-integrable (call-alien* alien-function args) (apply (ucode-primitive c-call -1) alien-function args)) @@ -527,13 +529,15 @@ USA. ;; 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) - (callback-handler* procedure args))) + (flo:with-default-environment + (lambda () + (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) + (callback-handler* procedure args))))) #;(define-integrable (callback-handler* procedure args) (apply-callback-proc procedure args)) -- 2.25.1