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* (policy *lexenv* (= insert-step-conditions 3)))
  68               (step-form `(step-form ,form-string
  69                                      ',(source-path-original-source *current-path*)
  70                                      *compile-file-pathname*))
  71               (values-form `(,(car form)
  72                              ,@(if *step-arguments-p*
  73                                    (mapcar #'insert-step-conditions (cdr form))
  74                                    (cdr form)))))
  75          (ir1-convert start next result
  76                       `(locally (declare (optimize (insert-step-conditions 0)))
  77                         ,(if *step-arguments-p*
  78                              `(let ((*step* ,step-form))
  79                                 (step-values ,form-string (multiple-value-list ,values-form)))
  80                              `(progn ,step-form ,values-form)))))))))
  81
  82 (defun step-form-p (form)
  83   #+sb-xc-host (declare (ignore form))
  84   #-sb-xc-host
  85   (flet ((step-symbol-p (symbol)
  86            (not (member (symbol-package symbol)
  87                         (load-time-value
  88                          ;; KLUDGE: packages we're not interested in stepping.
  89                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
  90     (let ((lexenv *lexenv*))
  91       (and (policy lexenv (>= insert-step-conditions 2))
  92            (cond ((consp form)
  93                   (let ((op (car form)))
  94                     (or (and (consp op) (eq 'lambda (car op)))
  95                         (and (symbolp op)
  96                              (not (special-operator-p op))
  97                              (member (lexenv-find op funs) '(nil functional global-var))
  98                              (not (eq :macro (info :function :kind op)))
  99                              (step-symbol-p op)))))
 100                  ((symbolp form)
 101                   (and *step-arguments-p*
 102                        (policy lexenv (= insert-step-conditions 3))
 103                        (not (consp (lexenv-find form vars)))
 104                        (not (constantp form))
 105                        (step-symbol-p form))))))))