From: Juho S. <js...@us...> - 2006-09-18 20:09:28
|
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv6222/tests Modified Files: foreign-stack-alignment.impure.lisp debug.impure.lisp Added Files: step.impure.lisp Log Message: 0.9.16.38: Rewrite the single-stepper to solve the compilation/run-time performance and type-inference inaccuracy problems with the old approach. Also make some UI improvements to the stepper. * The IR1 stage no longer instruments the code. Instead it only detects function call forms which should (according to the policy) be steppable, and records a string representation of those forms in the matching combination nodes (to be stored in the debug-info). * Modify the function call vops to emit some instrumentation just before the actual call happens. This will check either the symbol-value of *STEPPING* (unithreaded) or the new STEPPING slot of threads (multithreaded) and trap if it's true. The trap handler will replace the closure / fdefn that was about to be called with a wrapper, which will signal a stepper condition and then call the original function. * Emit a similar bit of instrumentation before any call that got optimized to a simple VOP. The difference is that the only thing that the trap handler will do is to directly signal the condition. * The necessary VOP / runtime changes have only been done on x86, x86-64 and ppc so far. Alpha, Mips and Sparc should still compile, but the stepper won't work there. * Remove the old single-stepper REPL, and instead integrate the stepper into the debugger. * Add STEP-OUT functionality (stop stepping temporarily, resuming it once the current function returns). --- NEW FILE: step.impure.lisp --- ;;;; This file is for testing the single-stepper. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. ;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (in-package :cl-user) ;; No stepper support on some platforms. #-(or x86 x86-64 ppc) (sb-ext:quit :unix-status 104) (defun fib (x) (declare (optimize debug)) (if (< x 2) 1 (+ (fib (1- x)) (fib (- x 2))))) (defvar *cerror-called* nil) (defun fib-break (x) (declare (optimize debug)) (if (< x 2) (progn (unless *cerror-called* (cerror "a" "b") (setf *cerror-called* t)) 1) (+ (fib-break (1- x)) (fib-break (- x 2))))) (defun test-step-into () (let* ((results nil) (expected '(("(< X 2)" :unknown) ("(- X 1)" :unknown) ("(FIB (1- X))" (2)) ("(< X 2)" :unknown) ("(- X 1)" :unknown) ("(FIB (1- X))" (1)) ("(< X 2)" :unknown) ("(- X 2)" :unknown) ("(FIB (- X 2))" (0)) ("(< X 2)" :unknown) ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) ("(- X 2)" :unknown) ("(FIB (- X 2))" (1)) ("(< X 2)" :unknown) ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (push (list (step-condition-form condition) (step-condition-args condition)) results) (invoke-restart 'step-into)))))) (step (fib 3)) (assert (equal expected (reverse results))))) (defun test-step-next () (let* ((results nil) (expected '(("(< X 2)" :unknown) ("(- X 1)" :unknown) ("(FIB (1- X))" (2)) ("(< X 2)" :unknown) ("(- X 1)" :unknown) ("(FIB (1- X))" (1)) ("(- X 2)" :unknown) ("(FIB (- X 2))" (0)) ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) ("(- X 2)" :unknown) ("(FIB (- X 2))" (1)) ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (push (list (step-condition-form condition) (step-condition-args condition)) results) (if (< (incf count) 4) (invoke-restart 'step-into) (invoke-restart 'step-next))))))) (step (fib 3)) (assert (equal expected (reverse results))))) (defun test-step-out () (let* ((results nil) (expected '(("(< X 2)" :unknown) ("(- X 1)" :unknown) ("(FIB (1- X))" (2)) ("(< X 2)" :unknown) ("(- X 2)" :unknown) ("(FIB (- X 2))" (1)) ("(< X 2)" :unknown) ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (push (list (step-condition-form condition) (step-condition-args condition)) results) (if (= (incf count) 4) (invoke-restart 'step-out) (invoke-restart 'step-into))))))) (step (fib 3)) (assert (equal expected (reverse results))))) (defun test-step-start-from-break () (let* ((results nil) (expected '(("(- X 2)" :unknown) ("(FIB-BREAK (- X 2))" (0)) ("(< X 2)" :unknown) ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown) ("(- X 2)" :unknown) ("(FIB-BREAK (- X 2))" (1)) ("(< X 2)" :unknown) ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (push (list (step-condition-form condition) (step-condition-args condition)) results) (invoke-restart 'step-into)))))) (setf *cerror-called* nil) (handler-bind ((error (lambda (c) (sb-impl::enable-stepping) (invoke-restart 'continue)))) (fib-break 3)) (assert (equal expected (reverse results))))) (defun test-step-frame () (let* ((count 0) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (let* ((frame (sb-di::find-stepped-frame)) (dfun (sb-di::frame-debug-fun frame)) (name (sb-di::debug-fun-name dfun))) (assert (equal name 'fib)) (incf count))))))) (step (fib 3)) (assert (= count 6)))) (defun test-step-backtrace () (let* ((*stepper-hook* (lambda (condition) (typecase condition (step-form-condition (let ((*debug-io* (make-broadcast-stream))) (backtrace))))))) (step (fib 3)))) (handler-bind ((step-condition (lambda (c) (funcall *stepper-hook* c)))) (with-test (:name :step-into) (test-step-into)) (with-test (:name :step-next) (test-step-next)) (with-test (:name :step-out) (test-step-out)) (with-test (:name :step-start-from-break) (test-step-start-from-break)) (with-test (:name :step-frame) (test-step-frame)) (with-test (:name :step-backtrace) (test-step-backtrace))) Index: foreign-stack-alignment.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/foreign-stack-alignment.impure.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- foreign-stack-alignment.impure.lisp 13 May 2006 19:29:59 -0000 1.3 +++ foreign-stack-alignment.impure.lisp 18 Sep 2006 20:09:15 -0000 1.4 @@ -43,7 +43,7 @@ ;;;; number. (run "cc" - #+x86-64 "-fPIC" + #+(and linux (or x86-64 ppc)) "-fPIC" "stack-alignment-offset.c" "-o" "stack-alignment-offset") (defparameter *good-offset* @@ -53,7 +53,7 @@ ;;;; Build the tool again, this time as a shared object, and load it (run "cc" "stack-alignment-offset.c" - #+x86-64 "-fPIC" + #+(and linux (or x86-64 ppc)) "-fPIC" #+darwin "-bundle" #-darwin "-shared" "-o" "stack-alignment-offset.so") Index: debug.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/debug.impure.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- debug.impure.lisp 13 Sep 2006 15:59:33 -0000 1.30 +++ debug.impure.lisp 18 Sep 2006 20:09:15 -0000 1.31 @@ -159,8 +159,13 @@ ;; bug 353: This test fails at least most of the time for x86/linux ;; ca. 0.8.20.16. -- WHN - (with-test (:name (:undefined-function :bug-356) - :fails-on '(or (and :x86 :linux) :alpha)) + (with-test (:name (:undefined-function :bug-353) + ;; This used to have fewer :fails-on features pre-0.9.16.38, + ;; but it turns out that the bug was just being masked by + ;; the presence of the IR1 stepper instrumentation (and + ;; is thus again failing now that the instrumentation is + ;; no more). + :fails-on '(or :x86 :x86-64 :alpha)) (assert (verify-backtrace (lambda () (test #'not-optimized)) (list *undefined-function-frame* |