tests/step.impure.lisp

   1 ;;;; This file is for testing the single-stepper.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 #+interpreter (sb-ext:exit :code 104)
  17 ;; No stepper support on some platforms.
  18 #-(or x86 x86-64 ppc sparc mips arm arm64)
  19 (sb-ext:exit :code 104)
  20
  21 ;; These tests should either with code in dynamic space
  22 ;; or immobile space, but they only accidentally worked
  23 ;; because the default is dynamic space.
  24 ;; Make sure they work in the non-default.
  25 ;; The issue was that when we elide the move to register
  26 ;; of the jump address, there's no register for the stepper
  27 ;; to mess with on return from the breakpoint.
  28 #+immobile-code (setq sb-c::*compile-to-memory-space* :immobile)
  29
  30 (defun fib (x)
  31   (declare (optimize debug))
  32   (if (< x 2)
  33       1
  34       (+ (fib (1- x))
  35          (fib (- x 2)))))
  36
  37 (defvar *cerror-called* nil)
  38
  39 (define-condition cerror-break (error) ())
  40
  41 (defun fib-break (x)
  42   (declare (optimize debug))
  43   (if (< x 2)
  44       (progn
  45         (unless *cerror-called*
  46           (cerror "a" 'cerror-break)
  47           (setf *cerror-called* t))
  48         1)
  49       (+ (fib-break (1- x))
  50          (fib-break (- x 2)))))
  51
  52 (defun in ()
  53   (declare (optimize debug))
  54   (print 1)
  55   (print 2)
  56   (print 3)
  57   (print 4))
  58
  59 (defun out ()
  60   (declare (optimize debug))
  61   (in))
  62
  63 (defun test-step-into ()
  64   (let* ((results nil)
  65          ;; The generic-< VOP on x86oids doesn't emit a full call
  66          (expected
  67           #-(or x86 x86-64)
  68           '(("(FIB 3)" (3))
  69             ("(< X 2)" :unknown)
  70             ("(- X 1)" :unknown)
  71             ("(FIB (1- X))" (2))
  72             ("(< X 2)" :unknown)
  73             ("(- X 1)" :unknown)
  74             ("(FIB (1- X))" (1))
  75             ("(< X 2)" :unknown)
  76             ("(- X 2)" :unknown)
  77             ("(FIB (- X 2))" (0))
  78             ("(< X 2)" :unknown)
  79             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  80             ("(- X 2)" :unknown)
  81             ("(FIB (- X 2))" (1))
  82             ("(< X 2)" :unknown)
  83             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
  84            #+(or x86 x86-64)
  85            '(("(FIB 3)" (3))
  86              ("(- X 1)" :unknown)
  87              ("(FIB (1- X))" (2))
  88              ("(- X 1)" :unknown)
  89              ("(FIB (1- X))" (1))
  90              ("(- X 2)" :unknown)
  91              ("(FIB (- X 2))" (0))
  92              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  93              ("(- X 2)" :unknown)
  94              ("(FIB (- X 2))" (1))
  95              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  96          (*stepper-hook* (lambda (condition)
  97                            (typecase condition
  98                              (step-form-condition
  99                               (push (list (step-condition-form condition)
 100                                           (step-condition-args condition))
 101                                     results)
 102                               (invoke-restart 'step-into))))))
 103     (step (fib 3))
 104     (assert (equal expected (reverse results)))))
 105
 106 (defun test-step-next ()
 107   (let* ((results nil)
 108          (expected
 109           #-(or x86 x86-64)
 110           '(("(FIB 3)" (3))
 111             ("(< X 2)" :unknown)
 112             ("(- X 1)" :unknown)
 113             ("(FIB (1- X))" (2))
 114             ("(< X 2)" :unknown)
 115             ("(- X 1)" :unknown)
 116             ("(FIB (1- X))" (1))
 117             ("(- X 2)" :unknown)
 118             ("(FIB (- X 2))" (0))
 119             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
 120             ("(- X 2)" :unknown)
 121             ("(FIB (- X 2))" (1))
 122             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
 123           #+(or x86 x86-64)
 124           '(("(FIB 3)" (3))
 125             ("(- X 1)" :unknown)
 126             ("(FIB (1- X))" (2))
 127             ("(- X 1)" :unknown)
 128             ("(FIB (1- X))" (1))
 129             ("(- X 2)" :unknown)
 130             ("(FIB (- X 2))" (0))
 131             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
 132             ("(- X 2)" :unknown)
 133             ("(FIB (- X 2))" (1))
 134             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 135          (count 0)
 136          (*stepper-hook* (lambda (condition)
 137                            (typecase condition
 138                              (step-form-condition
 139                               (push (list (step-condition-form condition)
 140                                           (step-condition-args condition))
 141                                     results)
 142                               (if (< (incf count)
 143                                      #+(or x86 x86-64) 4
 144                                      #-(or x86 x86-64) 5)
 145                                   (invoke-restart 'step-into)
 146                                   (invoke-restart 'step-next)))))))
 147     (step (fib 3))
 148     (assert (equal expected (reverse results)))))
 149
 150 (defun test-step-out ()
 151   (let* ((results nil)
 152          (expected
 153           #-(or x86 x86-64)
 154           '(("(FIB 3)" (3))
 155             ("(< X 2)" :unknown)
 156             ("(- X 1)" :unknown)
 157             ("(FIB (1- X))" (2))
 158             ("(< X 2)" :unknown)
 159             ("(- X 2)" :unknown)
 160             ("(FIB (- X 2))" (1))
 161             ("(< X 2)" :unknown)
 162             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
 163           #+(or x86 x86-64)
 164           '(("(FIB 3)" (3))
 165             ("(- X 1)" :unknown)
 166             ("(FIB (1- X))" (2))
 167             ("(- X 1)" :unknown)
 168             ("(FIB (1- X))" (1))
 169             ("(- X 2)" :unknown)
 170             ("(FIB (- X 2))" (1))
 171             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 172          (count 0)
 173          (*stepper-hook* (lambda (condition)
 174                            (typecase condition
 175                              (step-form-condition
 176                               (push (list (step-condition-form condition)
 177                                           (step-condition-args condition))
 178                                     results)
 179                               (if (= (incf count) 5)
 180                                   (invoke-restart 'step-out)
 181                                   (invoke-restart 'step-into)))))))
 182     (step (fib 3))
 183     (assert (equal expected (reverse results)))))
 184
 185 (defun test-step-start-from-break ()
 186   (let* ((results nil)
 187          (expected
 188           #-(or x86 x86-64)
 189           '(("(- X 2)" :unknown)
 190             ("(FIB-BREAK (- X 2))" (0))
 191             ("(< X 2)" :unknown)
 192             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 193             ("(- X 2)" :unknown)
 194             ("(FIB-BREAK (- X 2))" (1))
 195             ("(< X 2)" :unknown)
 196             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))
 197           #+(or x86 x86-64)
 198           '(("(- X 2)" :unknown)
 199             ("(FIB-BREAK (- X 2))" (0))
 200             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 201             ("(- X 2)" :unknown)
 202             ("(FIB-BREAK (- X 2))" (1))
 203             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
 204          (*stepper-hook* (lambda (condition)
 205                            (typecase condition
 206                              (step-form-condition
 207                               (push (list (step-condition-form condition)
 208                                           (step-condition-args condition))
 209                                     results)
 210                               (invoke-restart 'step-into))))))
 211     (setf *cerror-called* nil)
 212     (handler-bind ((cerror-break
 213                     (lambda (c)
 214                       (declare (ignore c))
 215                       (sb-impl::enable-stepping)
 216                       (invoke-restart 'continue))))
 217       (fib-break 3))
 218     (assert (equal expected (reverse results)))))
 219
 220 (defun test-step-frame ()
 221   (declare (optimize (debug 0)))
 222   (let* ((count 0)
 223          (*stepper-hook* (lambda (condition)
 224                            (typecase condition
 225                              (step-form-condition
 226                               (let* ((frame (sb-di::find-stepped-frame))
 227                                      (dfun (sb-di::frame-debug-fun frame))
 228                                      (name (sb-di::debug-fun-name dfun)))
 229                                 (assert (equal name 'fib))
 230                                 (incf count)
 231                                 (invoke-restart 'step-next)))))))
 232     (step (fib 3))
 233     (assert (= count #-(or x86 x86-64) 6 #+(or x86 x86-64) 5))))
 234
 235 (defun test-step-backtrace ()
 236   (let* ((*stepper-hook* (lambda (condition)
 237                            (typecase condition
 238                              (step-form-condition
 239                               (let ((*debug-io* (make-broadcast-stream)))
 240                                 (print-backtrace)))))))
 241     (step (fib 3))))
 242
 243 (defun test-step-next/2 ()
 244   (let* ((results nil)
 245          (expected '(("(OUT)" ())
 246                      ("(IN)" ())
 247                      ("(PRINT 1)" (1))
 248                      ("(PRINT 2)" (2))
 249                      ("(PRINT 3)" (3))
 250                      ("(PRINT 4)" (4))))
 251          (*stepper-hook* (lambda (condition)
 252                            (typecase condition
 253                              (step-form-condition
 254                               (push (list (step-condition-form condition)
 255                                           (step-condition-args condition))
 256                                     results)
 257                               (invoke-restart 'step-into))))))
 258     (step (out))
 259     (assert (equal expected (reverse results)))))
 260
 261 (defun test-step-out/2 ()
 262   (let* ((results nil)
 263          (expected '(("(OUT)" ())
 264                      ("(IN)" ())
 265                      ("(PRINT 1)" (1))
 266                      ("(PRINT 2)" (2))))
 267          (count 0)
 268          (*stepper-hook* (lambda (condition)
 269                            (typecase condition
 270                              (step-form-condition
 271                               (push (list (step-condition-form condition)
 272                                           (step-condition-args condition))
 273                                     results)
 274                               (if (>= (incf count) 4)
 275                                   (invoke-restart 'step-out)
 276                                   (invoke-restart 'step-into)))))))
 277     (step (out))
 278     (assert (equal expected (reverse results)))))
 279
 280 (with-test (:name :step-into)
 281   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 282     (test-step-into)))
 283
 284 (with-test (:name :step-next)
 285   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 286       (test-step-next)))
 287
 288 (with-test (:name :step-out)
 289   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 290     (test-step-out)))
 291
 292 (with-test (:name :step-start-from-break)
 293   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 294     (test-step-start-from-break)))
 295
 296 (with-test (:name :step-frame)
 297   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 298     (test-step-frame)))
 299
 300 (with-test (:name :step-backtrace)
 301   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 302     (test-step-backtrace)))
 303
 304 (with-test (:name :step-next/2)
 305   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 306     (test-step-next/2)))
 307
 308 (with-test (:name :step-out/2)
 309   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 310     (test-step-out/2)))