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