From: Matt Birkholz Date: Fri, 15 May 2009 08:06:16 +0000 (-0700) Subject: Simplified interrupt frobination. Fixed malloced-aliens cleanup. X-Git-Tag: 20100708-Gtk~36^2^2~1 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=72de1afb4222c54685682d5e06a9e1f06f816ea0;p=mit-scheme.git 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 aa3a69bbe..7e93d31cd 100644 --- 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 dc53234eb..18d45a7a3 100644 --- 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 520065745..10ae4991b 100644 --- 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)