0.9.15.36: less intrusive step instrumentation
[sbcl.git] / 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))))))))