0.pre8.7

	Implement WITH-TIMEOUT macro, using the SIGALRM handler.

	Write each output from TRACE in a single write() call, to make
	it much much easier (as in, possible) to see what's happening
	when multiple threads are calling TRACEd code at once

	Delete some dead code in compiler/x86/macros.lisp

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 9923ac7..07393fa 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -769,6 +769,11 @@
               (reader-error-format-control condition)
               (reader-error-format-arguments condition)
               (reader-impossible-number-error-error condition))))))
+
+;;; should this inherit from error?  good question
+(define-condition timeout (error) ())
+
+
 \f
 ;;;; special SBCL extension conditions
 

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index c93e07f..609be52 100644 (file)
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -250,7 +250,7 @@
                        (trace-wherein-p frame wherein)))))
        (when conditionp
         (let ((sb-kernel:*current-level-in-print* 0)
-              (*standard-output* *trace-output*)
+              (*standard-output* (make-string-output-stream))
               (*in-trace* t))
           (fresh-line)
           (print-trace-indentation)
@@ -263,7 +263,9 @@
                 (prin1 `(,(trace-info-what info) ,@arg-list)))
               (print-frame-call frame))
           (terpri)
-          (trace-print frame (trace-info-print info)))
+          (trace-print frame (trace-info-print info))
+          (write-sequence (get-output-stream-string *standard-output*)
+                          *trace-output*))
         (trace-maybe-break info (trace-info-break info) "before" frame)))
 
      (lambda (frame cookie)
@@ -290,7 +292,7 @@
                     (let ((cond (trace-info-condition-after info)))
                       (and cond (funcall (cdr cond) frame)))))
        (let ((sb-kernel:*current-level-in-print* 0)
-             (*standard-output* *trace-output*)
+             (*standard-output* (make-string-output-stream))
              (*in-trace* t))
          (fresh-line)
          (pprint-logical-block (*standard-output* nil)
@@ -302,7 +304,9 @@
              (pprint-newline :linear)
              (prin1 v)))
          (terpri)
-         (trace-print frame (trace-info-print-after info)))
+         (trace-print frame (trace-info-print-after info))
+         (write-sequence (get-output-stream-string *standard-output*)
+                         *trace-output*))
        (trace-maybe-break info
                           (trace-info-break-after info)
                           "after"

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 9ad1f36..34629f5 100644 (file)
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -114,7 +114,12 @@
 #!-linux
 (define-signal-handler sigsys-handler "bad argument to a system call")
 (define-signal-handler sigpipe-handler "SIGPIPE")
-(define-signal-handler sigalrm-handler "SIGALRM")
+
+(defun sigalrm-handler (signal info context)
+  (declare (ignore signal info context))
+  (declare (type system-area-pointer context))
+  (cerror "Continue" 'sb!kernel::timeout))
+
 
 (defun sigquit-handler (signal code context)
   (declare (ignore signal code context))

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index b1193bf..0a0da11 100644 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -685,6 +685,98 @@
              (addr tz))))
 \f
 
+;; Type of the second argument to `getitimer' and
+;; the second and third arguments `setitimer'. 
+(define-alien-type nil
+  (struct itimerval
+    (it-interval (struct timeval))     ; timer interval
+    (it-value (struct timeval))))      ; current value
+
+(defconstant ITIMER-REAL 0)
+(defconstant ITIMER-VIRTUAL 1)
+(defconstant ITIMER-PROF 2)
+
+(defun unix-getitimer(which)
+  "Unix-getitimer returns the INTERVAL and VALUE slots of one of
+   three system timers (:real :virtual or :profile). On success,
+   unix-getitimer returns 5 values,
+   T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec."
+  (declare (type (member :real :virtual :profile) which)
+          (values t
+                  (unsigned-byte 29) (mod 1000000)
+                  (unsigned-byte 29) (mod 1000000)))
+  (let ((which (ecase which
+                (:real ITIMER-REAL)
+                (:virtual ITIMER-VIRTUAL)
+                (:profile ITIMER-PROF))))
+    (with-alien ((itv (struct itimerval)))
+      (syscall* ("getitimer" int (* (struct itimerval)))
+               (values T
+                       (slot (slot itv 'it-interval) 'tv-sec)
+                       (slot (slot itv 'it-interval) 'tv-usec)
+                       (slot (slot itv 'it-value) 'tv-sec)
+                       (slot (slot itv 'it-value) 'tv-usec))
+               which (alien-sap (addr itv))))))
+
+(defun unix-setitimer (which int-secs int-usec val-secs val-usec)
+  " Unix-setitimer sets the INTERVAL and VALUE slots of one of
+   three system timers (:real :virtual or :profile). A SIGALRM signal
+   will be delivered VALUE <seconds+microseconds> from now. INTERVAL,
+   when non-zero, is <seconds+microseconds> to be loaded each time
+   the timer expires. Setting INTERVAL and VALUE to zero disables
+   the timer. See the Unix man page for more details. On success,
+   unix-setitimer returns the old contents of the INTERVAL and VALUE
+   slots as in unix-getitimer."
+  (declare (type (member :real :virtual :profile) which)
+          (type (unsigned-byte 29) int-secs val-secs)
+          (type (integer 0 (1000000)) int-usec val-usec)
+          (values t
+                  (unsigned-byte 29) (mod 1000000)
+                  (unsigned-byte 29) (mod 1000000)))
+  (let ((which (ecase which
+                (:real ITIMER-REAL)
+                (:virtual ITIMER-VIRTUAL)
+                (:profile ITIMER-PROF))))
+    (with-alien ((itvn (struct itimerval))
+                (itvo (struct itimerval)))
+      (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
+           (slot (slot itvn 'it-interval) 'tv-usec) int-usec
+           (slot (slot itvn 'it-value   ) 'tv-sec ) val-secs
+           (slot (slot itvn 'it-value   ) 'tv-usec) val-usec)
+      (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
+               (values T
+                       (slot (slot itvo 'it-interval) 'tv-sec)
+                       (slot (slot itvo 'it-interval) 'tv-usec)
+                       (slot (slot itvo 'it-value) 'tv-sec)
+                       (slot (slot itvo 'it-value) 'tv-usec))
+               which (alien-sap (addr itvn))(alien-sap (addr itvo))))))
+
+(defmacro with-timeout (expires &body body)
+  "Execute the body, interrupting it with a SIGALRM after at least
+EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
+previous timer after the body has finished executing"
+  (let ((saved-seconds (gensym "SAVED-SECONDS"))
+       (saved-useconds (gensym "SAVED-USECONDS"))
+       (s (gensym "S")) (u (gensym "U")))
+    `(let (- ,saved-seconds ,saved-useconds)
+      (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
+       (unix-getitimer :real))
+      (multiple-value-bind (,s ,u) (floor ,expires)
+       (setf ,u (floor (* ,u 1000000)))
+       (if (and (> ,expires 0)
+                (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
+                    (> ,saved-seconds ,s)
+                    (and (= ,saved-seconds ,s)
+                         (> ,saved-useconds ,u))))
+           (unwind-protect
+                (progn
+                  (unix-setitimer :real 0 0 ,s ,u)
+                  ,@body)
+             (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
+           ,@body)))))
+
+\f
+
 (defconstant ENOENT 2) ; Unix error code, "No such file or directory"
 (defconstant EINTR 4) ; Unix error code, "Interrupted system call"
 (defconstant EIO 5) ; Unix error code, "I/O error"

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 9db903d..6fc2e5e 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -257,17 +257,6 @@
   (cons 'progn
        (emit-error-break vop error-trap error-code values)))
 
-;;; not used in SBCL
-#|
-(defmacro cerror-call (vop label error-code &rest values)
-  #!+sb-doc
-  "Cause a continuable error. If the error is continued, execution resumes
-  at LABEL."
-  `(progn
-     ,@(emit-error-break vop cerror-trap error-code values)
-     (inst jmp ,label)))
-|#
-
 (defmacro generate-error-code (vop error-code &rest values)
   #!+sb-doc
   "Generate-Error-Code Error-code Value*
@@ -278,24 +267,6 @@
        (error-call ,vop ,error-code ,@values)
        start-lab)))
 
-;;; not used in SBCL
-#|
-(defmacro generate-cerror-code (vop error-code &rest values)
-  #!+sb-doc
-  "Generate-CError-Code Error-code Value*
-  Emit code for a continuable error with the specified Error-Code and
-  context Values. If the error is continued, execution resumes after
-  the GENERATE-CERROR-CODE form."
-  (let ((continue (gensym "CONTINUE-LABEL-"))
-       (error (gensym "ERROR-LABEL-")))
-    `(let ((,continue (gen-label))
-          (,error (gen-label)))
-       (emit-label ,continue)
-       (assemble (*elsewhere*)
-        (emit-label ,error)
-        (cerror-call ,vop ,continue ,error-code ,@values))
-       ,error)))
-|#
 \f
 ;;;; PSEUDO-ATOMIC
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 3ef0e85..354c137 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.6"
+"0.pre8.7"