src/compiler/ir1-step.lisp

   1 ;;;; compiler parts of the single stepper
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 ;;; Local stepping control: STEP binds this to T, and when forms are
  15 ;;; being skipped this is bound to NIL down the stack to prevent
  16 ;;; signalling of STEP-CONDITIONs.
  17 (defvar *step* nil)
  18
  19 ;;; Global stepping control: STEP binds this to T, and when the
  20 ;;; restart to continue without stepping is selected this is set to
  21 ;;; NIL to prevent the *STEPPER-HOOK* from being called.
  22 (defvar *stepping* nil)
  23
  24 (defun step-form (form source-path pathname)
  25   (when *step*
  26     (restart-case
  27         (signal 'step-form-condition
  28                 :form form
  29                 :source-path source-path
  30                 :pathname pathname)
  31       (step-continue ()
  32         (setf *stepping* nil))
  33       (step-next ()
  34         nil)
  35       (step-into ()
  36         t))))
  37
  38 (defun step-variable (symbol value)
  39   (when *step*
  40     (signal 'step-variable-condition :form symbol :result value))
  41   value)
  42
  43 (defun step-values (form values)
  44   (when *step*
  45     (signal 'step-values-condition :form form :result values))
  46   (values-list values))
  47
  48 (defun insert-step-conditions (form)
  49   `(locally (declare
  50              (optimize (insert-step-conditions
  51                         ,(policy *lexenv* insert-step-conditions))))
  52     ,form))
  53
  54 ;;; Flag to control instrumentation function call arguments.
  55 (defvar *step-arguments-p* nil)
  56
  57 (defun ir1-convert-step (start next result form)
  58   (let ((form-string (let ((*print-pretty* t)
  59                            (*print-readably* nil))
  60                        (prin1-to-string form))))
  61     (etypecase form
  62       (symbol
  63        (ir1-convert start next result
  64                     `(locally (declare (optimize (insert-step-conditions 0)))
  65                       (step-variable ,form-string ,form))))
  66       (list
  67        (let* ((*step-arguments-p* (and *allow-instrumenting*
  68                                        (policy *lexenv* (= insert-step-conditions 3))))
  69               (step-form `(step-form ,form-string
  70                                      ',(source-path-original-source *current-path*)
  71                                      *compile-file-pathname*))
  72               (values-form `(,(car form)
  73                              ,@(if *step-arguments-p*
  74                                    (mapcar #'insert-step-conditions (cdr form))
  75                                    (cdr form)))))
  76          (ir1-convert start next result
  77                       `(locally (declare (optimize (insert-step-conditions 0)))
  78                         ,(if *step-arguments-p*
  79                              `(let ((*step* ,step-form))
  80                                 (step-values ,form-string (multiple-value-list ,values-form)))
  81                              `(progn ,step-form ,values-form)))))))))
  82
  83 (defun step-form-p (form)
  84   #+sb-xc-host (declare (ignore form))
  85   #-sb-xc-host
  86   (flet ((step-symbol-p (symbol)
  87            (not (member (symbol-package symbol)
  88                         (load-time-value
  89                          ;; KLUDGE: packages we're not interested in stepping.
  90                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
  91     (let ((lexenv *lexenv*))
  92       (and *allow-instrumenting*
  93            (policy lexenv (>= insert-step-conditions 2))
  94            (cond ((consp form)
  95                   (let ((op (car form)))
  96                     (or (and (consp op) (eq 'lambda (car op)))
  97                         (and (symbolp op)
  98                              (not (special-operator-p op))
  99                              (member (lexenv-find op funs) '(nil functional global-var))
 100                              (not (eq :macro (info :function :kind op)))
 101                              (step-symbol-p op)))))
 102                  ((symbolp form)
 103                   (and *step-arguments-p*
 104                        *allow-instrumenting*
 105                        (policy lexenv (= insert-step-conditions 3))
 106                        (not (consp (lexenv-find form vars)))
 107                        (not (constantp form))
 108                        (step-symbol-p form))))))))