Simplified interrupt frobination. Fixed malloced-aliens cleanup.

* src/microcode/pruxffi.c:

Punted fiddling the interrupt mask in callback_run_kernel and(!)
callback_run_handler.  It should already be set up by the callout.

* src/runtime/ffi.scm, src/runtime/runtime.pkg:

Punted without-timer-interrupts; used without-interrupts instead.
Push malloced-aliens atomically.  Fixed bug in call to c-free.
Actually register the free-malloced-aliens gc-daemon.

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index aa3a69bbe460b690f69a02e43211c22b725e90c2..7e93d31cdd19cfe1ea283397962bfa02e29860fd 100644 (file)
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -740,8 +740,6 @@ callback_run_kernel (int callback_id, CallbackKernel kernel)
      frames on the Scheme stack and seal the CStack.  Then call
      Interpret().  Cannot abort. */
 
-  long int_mask;
-
   if (run_callback == SHARP_F)
     {
       run_callback = find_primitive_cname ("RUN-CALLBACK", false, false, 0);
@@ -778,13 +776,7 @@ callback_run_kernel (int callback_id, CallbackKernel kernel)
   STACK_PUSH (run_callback);
   PUSH_APPLY_FRAME_HEADER (0);
   SAVE_CONT();
-
-  /* Turn off thread switching. */
-  int_mask = GET_INT_MASK;
-  SET_INTERRUPT_MASK (int_mask & ~INT_Timer);
   Interpret (1);
-  SET_INTERRUPT_MASK (int_mask);
-
   cstack_depth -= 1;
 }
 
@@ -864,8 +856,8 @@ static SCM valid_callback_id (int id);
 void
 callback_run_handler (int callback_id, SCM arglist)
 {
-  /* Similar to setup_interrupt [utils.c].  Used by callback kernels,
-     inside the interpreter.  Thus it MAY GC abort.
+  /* 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
@@ -878,12 +870,6 @@ callback_run_handler (int callback_id, SCM arglist)
   fixnum_id = valid_callback_id (callback_id);
 
   stop_history ();
-  /* preserve_interrupt_mask ();
-
-     The above statement appears in setup_interrupt.  In this case,
-     something similar is done in callback_run_kernel, BEFORE
-     re-entering the interpreter.  (The "BEFORE" part is
-     important!) */
 
   Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
     STACK_PUSH (arglist);
@@ -891,11 +877,6 @@ callback_run_handler (int callback_id, SCM arglist)
     STACK_PUSH (handler);
     PUSH_APPLY_FRAME_HEADER (2);
   Pushed ();
-  /* Turn off interrupts: */
-  /* SET_INTERRUPT_MASK (interrupt_mask);
-
-     The above statement (from setup_interrupt) must move to
-     callback_run_kernel. */
 }
 
 static SCM

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index dc53234eb837d6bebd11a91bcaef8164873adae6..18d45a7a3833b6e103a260980f2c298c49604cba 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -281,7 +281,7 @@ USA.
      (if (alien-function? arg)
         (alien-function-cache! arg)))
    args)
-  (without-timer-interrupts
+  (without-interrupts
    (lambda ()
      (call-alien* alien-function args))))
 
@@ -301,10 +301,10 @@ USA.
 
 ;;; Malloc/Free
 
-;; Weak alist of: ( malloc alien X copy for the finalizer )...
+;; Weak alist of: ( malloc alien X copy for c-free )...
 (define malloced-aliens '())
 
-(define (finalize-malloced-aliens)
+(define (free-malloced-aliens)
   (let loop ((aliens malloced-aliens)
             (prev #f))
     (if (pair? aliens)
@@ -332,10 +332,13 @@ USA.
   (set! malloced-aliens '()))
 
 (define (malloc size ctype)
-  ;; Add copy to finalizer BEFORE calling malloc.
+  ;; Add copy to malloced-aliens BEFORE calling malloc.
   (let ((alien (make-alien ctype))
        (copy (make-alien ctype)))
-    (set! malloced-aliens (cons (weak-cons alien copy) malloced-aliens))
+    (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)
@@ -350,11 +353,11 @@ USA.
            (let ((copy (weak-cdr weak)))
              (without-interrupts
               (lambda ()
-                (if (not (alien-null? copy))
+                (if (not (alien-null? alien))
                     (begin
-                      (alien-null! copy)
+                      (alien-null! alien)
                       ((ucode-primitive c-free 1) copy)
-                      (alien-null! alien))))))))))
+                      (alien-null! copy))))))))))
 
 (define (weak-assq obj alist)
   (let loop ((alist alist))
@@ -416,8 +419,8 @@ USA.
 
 (define (callback-handler id args)
   ;; Installed in the fixed-objects-vector, this procedure is called
-  ;; by a callback trampoline, which ensures that timer interrupts are
-  ;; masked until the interpreter returns a value.
+  ;; 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))
@@ -471,25 +474,26 @@ USA.
 
 (define calloutback-stack '())
 
-(define tracing? #f)
+(define trace? #f)
 
 (define (reset-package!)
   (reset-alien-functions!)
   (reset-malloced-aliens!)
   (reset-callbacks!)
-  (set! tracing? #f)
+  (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 tracing? ((lambda () . BODY))))))
+     (if trace? ((lambda () . BODY))))))
 
 (define-syntax assert
   (syntax-rules ()
@@ -499,7 +503,7 @@ USA.
 (define-syntax trace
   (syntax-rules ()
     ((_ . MSG)
-     (if tracing? ((lambda () (outf-console . MSG)))))))
+     (if trace? ((lambda () (outf-console . MSG)))))))
 
 (define (tindent)
   (make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5200657455d67addd0e8d9136c435901a080affd..10ae4991b780c887c377de70b68503a18d268245 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3012,8 +3012,6 @@ USA.
          register-c-callback
          de-register-c-callback
          outf-console)
-  (import (runtime thread)
-         without-timer-interrupts)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)