From: Matt Birkholz Date: Fri, 19 Aug 2011 02:17:53 +0000 (-0700) Subject: Moved outf-console to -error (stderr); fiddled FFI debugging. X-Git-Tag: release-9.2.0~347^2~2^2~5 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ece62e004e3b01681153de73e7a2ec756a00e031;p=mit-scheme.git Moved outf-console to -error (stderr); fiddled FFI debugging. --- diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo index e023561a3..0ab9f6fd1 100644 --- a/doc/ffi/ffi.texinfo +++ b/doc/ffi/ffi.texinfo @@ -589,11 +589,11 @@ balk at a callback procedure that calls @code{yield-thread}, waits for I/O, sleeps, or otherwise causes a thread switch. Presumably such a procedure has some other way of enforcing the LIFO ordering. -The @code{outf-console} procedure is provided for debugging purposes. +The @code{outf-error} procedure is provided for debugging purposes. It writes one or more argument strings (and @code{write}s any -non-strings) to the console and flushes, atomically, via a machine +non-strings) to the Unix ``stderr'' channel, atomically, via a machine primitive, bypassing the runtime's I/O buffering and thread switching. -Thus multiple debugging trace messages arrive on the console intact +Thus trace messages from multiple threads will appear on stderr intact and uninterrupted. diff --git a/doc/ffi/prhello.scm b/doc/ffi/prhello.scm index 25caeff5f..9ceb62d11 100644 --- a/doc/ffi/prhello.scm +++ b/doc/ffi/prhello.scm @@ -32,7 +32,7 @@ callbacks. |# (C-callback "delete_event") ;trampoline (C-callback ;callback ID (lambda (w e) - (outf-console ";Delete me "(- 2 counter)" times.\n") + (outf-error ";Delete me "(- 2 counter)" times.\n") (set! counter (1+ counter)) ;; Three or more is the charm. (if (> counter 2) diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index a64179e18..2f45ea3da 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -998,7 +998,7 @@ empty_list (void) return (EMPTY_LIST); } -DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0) +DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) { /* To avoid the normal i/o system when debugging a callback. */ @@ -1008,8 +1008,8 @@ DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0) if (STRING_P (arg)) { char * string = ((char *) STRING_LOC (arg, 0)); - outf_console ("%s", string); - outf_flush_console (); + outf_error ("%s", string); + outf_flush_error (); } else { diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 489ddca42..7ee4bd6a0 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2006, 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -322,15 +322,15 @@ USA. (define (call-alien* alien-function args) (let ((old-top calloutback-stack)) - (if-tracing - (outf-console ";"(tindent)"=> "alien-function" "args"\n") + (%if-tracing + (outf-error ";"(tindent)"=> "alien-function" "args"\n") (set! calloutback-stack (cons (cons* alien-function args) old-top))) (let ((value (apply (ucode-primitive c-call -1) alien-function args))) - (if-tracing - (assert (eq? old-top (cdr calloutback-stack)) - "call-alien: freak stack "calloutback-stack"\n") + (%if-tracing + (%assert (eq? old-top (cdr calloutback-stack)) + "call-alien: freak stack "calloutback-stack"\n") (set! calloutback-stack old-top) - (outf-console ";"(tindent)"<= "value"\n")) + (outf-error ";"(tindent)"<= "value"\n")) value))) @@ -469,16 +469,16 @@ USA. (error:bad-range-argument id 'apply-callback)) (normalize-aliens! args) (let ((old-top calloutback-stack)) - (if-tracing - (outf-console ";"(tindent)"=>> "procedure" "args"\n") + (%if-tracing + (outf-error ";"(tindent)"=>> "procedure" "args"\n") (set! calloutback-stack (cons (cons procedure args) old-top))) (let ((value (apply-callback-proc procedure args))) - (if-tracing - (assert (and (pair? calloutback-stack) - (eq? old-top (cdr calloutback-stack))) - "callback-handler: freak stack "calloutback-stack"\n") + (%if-tracing + (%assert (and (pair? calloutback-stack) + (eq? old-top (cdr calloutback-stack))) + "callback-handler: freak stack "calloutback-stack"\n") (set! calloutback-stack old-top) - (outf-console ";"(tindent)"<<= "value"\n")) + (outf-error ";"(tindent)"<<= "value"\n")) value)))) (define (apply-callback-proc procedure args) @@ -501,27 +501,39 @@ USA. (error "Cannot return from a callback more than once.") (loop))))))))) -;; For callback debugging... -(define (outf-console . objects) - ((ucode-primitive outf-console 1) +;;; For callback debugging: + +(define (outf-error . objects) + ((ucode-primitive outf-error 1) (apply string-append (map (lambda (o) (if (string? o) o (write-to-string o))) objects)))) +(define (registered-callback-count) + (let* ((vector registered-callbacks) + (end (vector-length vector))) + (let loop ((i 0)(count 0)) + (if (fix:< i end) + (loop (fix:1+ i) + (if (vector-ref vector i) + (fix:1+ count) + count)) + (cons count end))))) + (define (initialize-callbacks!) (vector-set! (get-fixed-objects-vector) #x41 callback-handler)) (define calloutback-stack '()) -(define trace? #f) +(define %trace? #f) (define (reset-package!) (reset-alien-functions!) (reset-malloced-aliens!) (reset-callbacks!) (set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000)) - (set! trace? #f) + (set! %trace? #f) (set! calloutback-stack '())) (define (initialize-package!) @@ -531,20 +543,20 @@ USA. (add-gc-daemon! free-malloced-aliens) unspecific) -(define-syntax if-tracing +(define-syntax %if-tracing (syntax-rules () ((_ . BODY) - (if trace? ((lambda () . BODY)))))) + (if %trace? ((lambda () . BODY)))))) -(define-syntax assert +(define-syntax %assert (syntax-rules () ((_ TEST . MSG) (if (not TEST) (error "Failed assert:" . MSG))))) -(define-syntax trace +(define-syntax %trace (syntax-rules () ((_ . MSG) - (if trace? ((lambda () (outf-console . MSG))))))) + (if %trace? ((lambda () (outf-error . 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 bffa129a4..99cefe50b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3282,7 +3282,7 @@ USA. free register-c-callback de-register-c-callback - outf-console) + outf-error) (initialization (initialize-package!))) (define-package (runtime program-copier)