0.9.10.26
[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   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))))))))