mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
336 lines
12 KiB
Common Lisp
336 lines
12 KiB
Common 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.
|
|
|
|
;; No stepper support on some platforms.
|
|
#+(or interpreter riscv loongarch64 (and ppc64 big-endian)) (invoke-restart 'run-tests::skip-file)
|
|
|
|
;; These tests should either with code in dynamic space
|
|
;; or immobile space, but they only accidentally worked
|
|
;; because the default is dynamic space.
|
|
;; Make sure they work in the non-default.
|
|
;; The issue was that when we elide the move to register
|
|
;; of the jump address, there's no register for the stepper
|
|
;; to mess with on return from the breakpoint.
|
|
#+immobile-code (setq sb-c::*compile-to-memory-space* :immobile)
|
|
|
|
(defun fib (x)
|
|
(declare (optimize debug))
|
|
(if (< x 2)
|
|
1
|
|
(+ (fib (1- x))
|
|
(fib (- x 2)))))
|
|
|
|
(defvar *cerror-called* nil)
|
|
|
|
(define-condition cerror-break (error) ())
|
|
|
|
(defun fib-break (x)
|
|
(declare (optimize debug))
|
|
(if (< x 2)
|
|
(progn
|
|
(unless *cerror-called*
|
|
(cerror "a" 'cerror-break)
|
|
(setf *cerror-called* t))
|
|
1)
|
|
(+ (fib-break (1- x))
|
|
(fib-break (- x 2)))))
|
|
|
|
(defun in ()
|
|
(declare (optimize debug))
|
|
(print 1)
|
|
(print 2)
|
|
(print 3)
|
|
(print 4))
|
|
|
|
(defun out ()
|
|
(declare (optimize debug))
|
|
(in))
|
|
|
|
(defun test-step-into ()
|
|
(let* ((results nil)
|
|
;; The generic-< VOP on x86oids doesn't emit a full call
|
|
(expected
|
|
#-(or x86 x86-64 arm64)
|
|
'(("(FIB 3)" (3))
|
|
("(< 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))
|
|
#+(or x86 x86-64)
|
|
'(("(FIB 3)" (3))
|
|
("(- X 1)" :unknown)
|
|
("(FIB (1- X))" (2))
|
|
("(- 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))
|
|
#+arm64
|
|
'(("(FIB 3)" (3))
|
|
("(FIB (1- X))" (2))
|
|
("(FIB (1- X))" (1))
|
|
("(FIB (- X 2))" (0))
|
|
("(FIB (- X 2))" (1))))
|
|
(*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
|
|
#-(or x86 x86-64 arm64)
|
|
'(("(FIB 3)" (3))
|
|
("(< 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))
|
|
#+(or x86 x86-64)
|
|
'(("(FIB 3)" (3))
|
|
("(- X 1)" :unknown)
|
|
("(FIB (1- X))" (2))
|
|
("(- 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))
|
|
#+arm64
|
|
'(("(FIB 3)" (3))
|
|
("(FIB (1- X))" (2))
|
|
("(FIB (1- X))" (1))
|
|
("(FIB (- X 2))" (0))
|
|
("(FIB (- X 2))" (1))))
|
|
(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)
|
|
#+(or x86 x86-64) 4
|
|
#-(or x86 x86-64) 5)
|
|
(invoke-restart 'step-into)
|
|
(invoke-restart 'step-next)))))))
|
|
(step (fib 3))
|
|
(assert (equal expected (reverse results)))))
|
|
|
|
(defun test-step-out ()
|
|
(let* ((results nil)
|
|
(expected
|
|
#-(or x86 x86-64 arm64)
|
|
'(("(FIB 3)" (3))
|
|
("(< 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))
|
|
#+(or x86 x86-64)
|
|
'(("(FIB 3)" (3))
|
|
("(- X 1)" :unknown)
|
|
("(FIB (1- X))" (2))
|
|
("(- X 1)" :unknown)
|
|
("(FIB (1- X))" (1))
|
|
("(- X 2)" :unknown)
|
|
("(FIB (- X 2))" (1))
|
|
("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
|
|
#+arm64
|
|
'(("(FIB 3)" (3))
|
|
("(FIB (1- X))" (2))
|
|
("(FIB (1- X))" (1))
|
|
("(FIB (- X 2))" (0))
|
|
("(FIB (- X 2))" (1))))
|
|
(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) 5)
|
|
(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
|
|
#-(or x86 x86-64 arm64)
|
|
'(("(- 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))
|
|
#+(or x86 x86-64)
|
|
'(("(- X 2)" :unknown)
|
|
("(FIB-BREAK (- X 2))" (0))
|
|
("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
|
|
("(- X 2)" :unknown)
|
|
("(FIB-BREAK (- X 2))" (1))
|
|
("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))
|
|
#+arm64
|
|
'(("(FIB-BREAK (- X 2))" (0))
|
|
("(FIB-BREAK (- X 2))" (1))))
|
|
(*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 ((cerror-break
|
|
(lambda (c)
|
|
(declare (ignore c))
|
|
(sb-impl::enable-stepping)
|
|
(invoke-restart 'continue))))
|
|
(fib-break 3))
|
|
(assert (equal expected (reverse results)))))
|
|
|
|
(defun test-step-frame ()
|
|
(declare (optimize (debug 0)))
|
|
(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)
|
|
(invoke-restart 'step-next)))))))
|
|
(step (fib 3))
|
|
(assert (= count #+arm64 2 #-(or x86 x86-64 arm64) 6 #+(or x86 x86-64) 5))))
|
|
|
|
(defun test-step-backtrace ()
|
|
(let* ((*stepper-hook* (lambda (condition)
|
|
(typecase condition
|
|
(step-form-condition
|
|
(let ((*debug-io* (make-broadcast-stream)))
|
|
(print-backtrace)))))))
|
|
(step (fib 3))))
|
|
|
|
(defun test-step-next/2 ()
|
|
(let* ((results nil)
|
|
(expected '(("(OUT)" ())
|
|
("(IN)" ())
|
|
("(PRINT 1)" (1))
|
|
("(PRINT 2)" (2))
|
|
("(PRINT 3)" (3))
|
|
("(PRINT 4)" (4))))
|
|
(*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 (out))
|
|
(assert (equal expected (reverse results)))))
|
|
|
|
(defun test-step-out/2 ()
|
|
(let* ((results nil)
|
|
(expected '(("(OUT)" ())
|
|
("(IN)" ())
|
|
("(PRINT 1)" (1))
|
|
("(PRINT 2)" (2))))
|
|
(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 (out))
|
|
(assert (equal expected (reverse results)))))
|
|
|
|
(with-test (:name :step-into :fails-on :arm)
|
|
(test-step-into))
|
|
|
|
(with-test (:name :step-next :fails-on :arm)
|
|
(test-step-next))
|
|
|
|
(with-test (:name :step-out :fails-on :arm)
|
|
(test-step-out))
|
|
|
|
(with-test (:name :step-start-from-break :fails-on :arm)
|
|
(test-step-start-from-break))
|
|
|
|
(with-test (:name :step-frame :fails-on :arm)
|
|
(test-step-frame))
|
|
|
|
(with-test (:name :step-backtrace)
|
|
(test-step-backtrace))
|
|
|
|
(with-test (:name :step-next/2)
|
|
(test-step-next/2))
|
|
|
|
(with-test (:name :step-out/2)
|
|
(test-step-out/2))
|
|
|
|
;;; This ironically-named test asserts that we do NOT step-instrument
|
|
;;; a call to TWO-ARG-/ (because it doesn't work). I guess it used to crash on x86.
|
|
;;; But I sure as heck don't understand whether it's actually testing that,
|
|
;;; because it doesn't seem to offer to step into the division function on_any platform.
|
|
;;; It shows that it steps into CHECKED-COMPILE which returns 6 values.
|
|
(with-test (:name :static-fun-step)
|
|
(handler-bind ((step-form-condition
|
|
(lambda (c)
|
|
c
|
|
; (format t "~&~A~%" c)
|
|
(invoke-restart 'step-into))))
|
|
(assert (= (step (funcall (checked-compile
|
|
`(lambda (x) (declare (optimize debug)) (/ 1 x)))
|
|
2))
|
|
1/2))))
|