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
  42 (defun step-values (form values)
  43   (when *step*
  44     (signal 'step-values-condition :form form :result values)))
  45
  46 (defun insert-step-conditions (form)
  47   `(locally (declare
  48              (optimize (insert-step-conditions
  49                         ,(policy *lexenv* insert-step-conditions))))
  50     ,form))
  51
  52 ;;; Flag to control instrumentation function call arguments.
  53 (defvar *step-arguments-p* nil)
  54
  55 (defun known-single-value-fun-p (fun)
  56   (and (legal-fun-name-p fun)
  57        (info :function :info fun)
  58        (let ((type (info :function :type fun)))
  59          (and (and (fun-type-p type))
  60               (type-single-value-p (fun-type-returns type))))))
  61
  62 (defun ir1-convert-step (start next result form)
  63   (let ((form-string (let ((*print-pretty* t)
  64                            (*print-readably* nil))
  65                        (prin1-to-string form))))
  66     (etypecase form
  67       (symbol
  68        (let ((ctran (make-ctran))
  69              (*allow-instrumenting* nil))
  70          (ir1-convert start ctran nil `(step-variable ,form-string ,form))
  71          (ir1-convert ctran next result form)))
  72       (list
  73        (let* ((*step-arguments-p* (and *allow-instrumenting*
  74                                        (policy *lexenv* (= insert-step-conditions 3))))
  75               (step-form `(step-form ,form-string
  76                                      ',(source-path-original-source *current-path*)
  77                                      *compile-file-pathname*))
  78               (fun (car form))
  79               (values-form `(,fun
  80                              ,@(if *step-arguments-p*
  81                                    (mapcar #'insert-step-conditions (cdr form))
  82                                    (cdr form)))))
  83          (ir1-convert start next result
  84                       `(locally (declare (optimize (insert-step-conditions 0)))
  85                          ,(if *step-arguments-p*
  86                               `(let ((*step* ,step-form))
  87                                  ,(if (known-single-value-fun-p fun)
  88                                       `((lambda (value)
  89                                           (step-values ,form-string (list value))
  90                                           value)
  91                                         ,values-form)
  92                                       `(multiple-value-call
  93                                            (lambda (&rest values)
  94                                              (step-values ,form-string values)
  95                                              (values-list values))
  96                                          ,values-form)))
  97                               `(progn ,step-form ,values-form)))))))))
  98
  99 (defun step-form-p (form)
 100   #+sb-xc-host (declare (ignore form))
 101   #-sb-xc-host
 102   (flet ((step-symbol-p (symbol)
 103            (not (member (symbol-package symbol)
 104                         (load-time-value
 105                          ;; KLUDGE: packages we're not interested in stepping.
 106                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
 107     (let ((lexenv *lexenv*))
 108       (and *allow-instrumenting*
 109            (policy lexenv (>= insert-step-conditions 2))
 110            (cond ((consp form)
 111                   (let ((op (car form)))
 112                     (or (and (consp op) (eq 'lambda (car op)))
 113                         (and (symbolp op)
 114                              (not (special-operator-p op))
 115                              (member (lexenv-find op funs) '(nil functional global-var))
 116                              (not (eq :macro (info :function :kind op)))
 117                              (step-symbol-p op)))))
 118                  ((symbolp form)
 119                   (and *step-arguments-p*
 120                        *allow-instrumenting*
 121                        (policy lexenv (= insert-step-conditions 3))
 122                        (not (consp (lexenv-find form vars)))
 123                        (not (constantp form))
 124                        (step-symbol-p form))))))))