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)
  19 (sb-ext:exit :code 104)
  20
  21 (defun fib (x)
  22   (declare (optimize debug))
  23   (if (< x 2)
  24       1
  25       (+ (fib (1- x))
  26          (fib (- x 2)))))
  27
  28 (defvar *cerror-called* nil)
  29
  30 (define-condition cerror-break (error) ())
  31
  32 (defun fib-break (x)
  33   (declare (optimize debug))
  34   (if (< x 2)
  35       (progn
  36         (unless *cerror-called*
  37           (cerror "a" 'cerror-break)
  38           (setf *cerror-called* t))
  39         1)
  40       (+ (fib-break (1- x))
  41          (fib-break (- x 2)))))
  42
  43 (defun in ()
  44   (declare (optimize debug))
  45   (print 1)
  46   (print 2)
  47   (print 3)
  48   (print 4))
  49
  50 (defun out ()
  51   (declare (optimize debug))
  52   (in))
  53
  54 (defun test-step-into ()
  55   (let* ((results nil)
  56          ;; The generic-< VOP on x86oids doesn't emit a full call
  57          (expected
  58           #-(or x86 x86-64)
  59            '(("(< X 2)" :unknown)
  60              ("(- X 1)" :unknown)
  61              ("(FIB (1- X))" (2))
  62              ("(< X 2)" :unknown)
  63              ("(- X 1)" :unknown)
  64              ("(FIB (1- X))" (1))
  65              ("(< X 2)" :unknown)
  66              ("(- X 2)" :unknown)
  67              ("(FIB (- X 2))" (0))
  68              ("(< X 2)" :unknown)
  69              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  70              ("(- X 2)" :unknown)
  71              ("(FIB (- X 2))" (1))
  72              ("(< X 2)" :unknown)
  73              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
  74            #+(or x86 x86-64)
  75            '(("(- X 1)" :unknown)
  76              ("(FIB (1- X))" (2))
  77              ("(- X 1)" :unknown)
  78              ("(FIB (1- X))" (1))
  79              ("(- X 2)" :unknown)
  80              ("(FIB (- X 2))" (0))
  81              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  82              ("(- X 2)" :unknown)
  83              ("(FIB (- X 2))" (1))
  84              ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  85          (*stepper-hook* (lambda (condition)
  86                            (typecase condition
  87                              (step-form-condition
  88                               (push (list (step-condition-form condition)
  89                                           (step-condition-args condition))
  90                                     results)
  91                               (invoke-restart 'step-into))))))
  92     (step (fib 3))
  93     (assert (equal expected (reverse results)))))
  94
  95 (defun test-step-next ()
  96   (let* ((results nil)
  97          (expected
  98           #-(or x86 x86-64)
  99           '(("(< X 2)" :unknown)
 100             ("(- X 1)" :unknown)
 101             ("(FIB (1- X))" (2))
 102             ("(< X 2)" :unknown)
 103             ("(- X 1)" :unknown)
 104             ("(FIB (1- X))" (1))
 105             ("(- X 2)" :unknown)
 106             ("(FIB (- X 2))" (0))
 107             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
 108             ("(- X 2)" :unknown)
 109             ("(FIB (- X 2))" (1))
 110             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
 111           #+(or x86 x86-64)
 112           '(("(- X 1)" :unknown)
 113             ("(FIB (1- X))" (2))
 114             ("(- X 1)" :unknown)
 115             ("(FIB (1- X))" (1))
 116             ("(- X 2)" :unknown)
 117             ("(FIB (- X 2))" (0))
 118             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
 119             ("(- X 2)" :unknown)
 120             ("(FIB (- X 2))" (1))
 121             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 122          (count 0)
 123          (*stepper-hook* (lambda (condition)
 124                            (typecase condition
 125                              (step-form-condition
 126                               (push (list (step-condition-form condition)
 127                                           (step-condition-args condition))
 128                                     results)
 129                               (if (< (incf count) 4)
 130                                   (invoke-restart 'step-into)
 131                                   (invoke-restart 'step-next)))))))
 132     (step (fib 3))
 133     (assert (equal expected (reverse results)))))
 134
 135 (defun test-step-out ()
 136   (let* ((results nil)
 137          (expected
 138           #-(or x86 x86-64)
 139           '(("(< X 2)" :unknown)
 140             ("(- X 1)" :unknown)
 141             ("(FIB (1- X))" (2))
 142             ("(< X 2)" :unknown)
 143             ("(- X 2)" :unknown)
 144             ("(FIB (- X 2))" (1))
 145             ("(< X 2)" :unknown)
 146             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
 147           #+(or x86 x86-64)
 148           '(("(- X 1)" :unknown)
 149             ("(FIB (1- X))" (2))
 150             ("(- X 1)" :unknown)
 151             ("(FIB (1- X))" (1))
 152             ("(- X 2)" :unknown)
 153             ("(FIB (- X 2))" (1))
 154             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 155          (count 0)
 156          (*stepper-hook* (lambda (condition)
 157                            (typecase condition
 158                              (step-form-condition
 159                               (push (list (step-condition-form condition)
 160                                           (step-condition-args condition))
 161                                     results)
 162                               (if (= (incf count) 4)
 163                                   (invoke-restart 'step-out)
 164                                   (invoke-restart 'step-into)))))))
 165     (step (fib 3))
 166     (assert (equal expected (reverse results)))))
 167
 168 (defun test-step-start-from-break ()
 169   (let* ((results nil)
 170          (expected
 171           #-(or x86 x86-64)
 172           '(("(- X 2)" :unknown)
 173             ("(FIB-BREAK (- X 2))" (0))
 174             ("(< X 2)" :unknown)
 175             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 176             ("(- X 2)" :unknown)
 177             ("(FIB-BREAK (- X 2))" (1))
 178             ("(< X 2)" :unknown)
 179             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))
 180           #+(or x86 x86-64)
 181           '(("(- X 2)" :unknown)
 182             ("(FIB-BREAK (- X 2))" (0))
 183             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 184             ("(- X 2)" :unknown)
 185             ("(FIB-BREAK (- X 2))" (1))
 186             ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
 187          (*stepper-hook* (lambda (condition)
 188                            (typecase condition
 189                              (step-form-condition
 190                               (push (list (step-condition-form condition)
 191                                           (step-condition-args condition))
 192                                     results)
 193                               (invoke-restart 'step-into))))))
 194     (setf *cerror-called* nil)
 195     (handler-bind ((cerror-break
 196                     (lambda (c)
 197                       (declare (ignore c))
 198                       (sb-impl::enable-stepping)
 199                       (invoke-restart 'continue))))
 200       (fib-break 3))
 201     (assert (equal expected (reverse results)))))
 202
 203 (defun test-step-frame ()
 204   (let* ((count 0)
 205          (*stepper-hook* (lambda (condition)
 206                            (typecase condition
 207                              (step-form-condition
 208                               (let* ((frame (sb-di::find-stepped-frame))
 209                                      (dfun (sb-di::frame-debug-fun frame))
 210                                      (name (sb-di::debug-fun-name dfun)))
 211                                 (assert (equal name 'fib))
 212                                 (incf count)
 213                                 (invoke-restart 'step-next)))))))
 214     (step (fib 3))
 215     (assert (= count #-(or x86 x86-64) 6 #+(or x86 x86-64) 5))))
 216
 217 (defun test-step-backtrace ()
 218   (let* ((*stepper-hook* (lambda (condition)
 219                            (typecase condition
 220                              (step-form-condition
 221                               (let ((*debug-io* (make-broadcast-stream)))
 222                                 (print-backtrace)))))))
 223     (step (fib 3))))
 224
 225 (defun test-step-next/2 ()
 226   (let* ((results nil)
 227          (expected '(("(IN)" ())
 228                      ("(PRINT 1)" (1))
 229                      ("(PRINT 2)" (2))
 230                      ("(PRINT 3)" (3))
 231                      ("(PRINT 4)" (4))))
 232          (count 0)
 233          (*stepper-hook* (lambda (condition)
 234                            (typecase condition
 235                              (step-form-condition
 236                               (push (list (step-condition-form condition)
 237                                           (step-condition-args condition))
 238                                     results)
 239                               (if (>= (incf count) 3)
 240                                   (invoke-restart 'step-into)
 241                                   (invoke-restart 'step-into)))))))
 242     (step (out))
 243     (assert (equal expected (reverse results)))))
 244
 245 (defun test-step-out/2 ()
 246   (let* ((results nil)
 247          (expected '(("(IN)" ())
 248                      ("(PRINT 1)" (1))
 249                      ("(PRINT 2)" (2))))
 250          (count 0)
 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                               (if (>= (incf count) 3)
 258                                   (invoke-restart 'step-out)
 259                                   (invoke-restart 'step-into)))))))
 260     (step (out))
 261     (assert (equal expected (reverse results)))))
 262
 263 (with-test (:name :step-into)
 264   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 265     (test-step-into)))
 266
 267 (with-test (:name :step-next)
 268   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 269       (test-step-next)))
 270
 271 (with-test (:name :step-out)
 272   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 273     (test-step-out)))
 274
 275 (with-test (:name :step-start-from-break)
 276   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 277     (test-step-start-from-break)))
 278
 279 (with-test (:name :step-frame)
 280   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 281     (test-step-frame)))
 282
 283 (with-test (:name :step-backtrace)
 284   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 285     (test-step-backtrace)))
 286
 287 (with-test (:name :step-next/2)
 288   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 289     (test-step-next/2)))
 290
 291 (with-test (:name :step-out/2)
 292   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 293     (test-step-out/2)))