1.0.3.44: x86-64 print vop preserves 16-byte stack alignment

[sbcl.git] / src / compiler / ir1-step.lisp

diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp
index 2ca4af6..023a265 100644 (file)
--- a/src/compiler/ir1-step.lisp
+++ b/src/compiler/ir1-step.lisp
@@ -32,63 +32,81 @@
         (setf *stepping* nil))
       (step-next ()
         nil)
         (setf *stepping* nil))
       (step-next ()
         nil)

-      (step-into () 
+      (step-into ()

         t))))
 
 (defun step-variable (symbol value)
   (when *step*
         t))))
 
 (defun step-variable (symbol value)
   (when *step*

-    (signal 'step-variable-condition :form symbol :result value))
-  value)
+    (signal 'step-variable-condition :form symbol :result value)))

 
 (defun step-values (form values)
   (when *step*
 
 (defun step-values (form values)
   (when *step*

-    (signal 'step-values-condition :form form :result values))
-  (values-list values))
+    (signal 'step-values-condition :form form :result values)))

 
 (defun insert-step-conditions (form)
   `(locally (declare
 
 (defun insert-step-conditions (form)
   `(locally (declare

-            (optimize (insert-step-conditions
-                       ,(policy *lexenv* insert-step-conditions))))
+             (optimize (insert-step-conditions
+                        ,(policy *lexenv* insert-step-conditions))))

     ,form))
 
 ;;; Flag to control instrumentation function call arguments.
 (defvar *step-arguments-p* nil)
 
     ,form))
 
 ;;; Flag to control instrumentation function call arguments.
 (defvar *step-arguments-p* nil)
 

+(defun known-single-value-fun-p (fun)
+  (and (legal-fun-name-p fun)
+       (info :function :info fun)
+       (let ((type (info :function :type fun)))
+         (and (and (fun-type-p type))
+              (type-single-value-p (fun-type-returns type))))))
+

 (defun ir1-convert-step (start next result form)
   (let ((form-string (let ((*print-pretty* t)
                            (*print-readably* nil))
                        (prin1-to-string form))))
     (etypecase form
       (symbol
 (defun ir1-convert-step (start next result form)
   (let ((form-string (let ((*print-pretty* t)
                            (*print-readably* nil))
                        (prin1-to-string form))))
     (etypecase form
       (symbol

-       (ir1-convert start next result
-                    `(locally (declare (optimize (insert-step-conditions 0)))
-                      (step-variable ,form-string ,form))))
+       (let ((ctran (make-ctran))
+             (*allow-instrumenting* nil))
+         (ir1-convert start ctran nil `(step-variable ,form-string ,form))
+         (ir1-convert ctran next result form)))

       (list
       (list

-       (let* ((*step-arguments-p* (policy *lexenv* (= insert-step-conditions 3)))
+       (let* ((*step-arguments-p* (and *allow-instrumenting*
+                                       (policy *lexenv* (= insert-step-conditions 3))))

               (step-form `(step-form ,form-string
                                      ',(source-path-original-source *current-path*)
                                      *compile-file-pathname*))
               (step-form `(step-form ,form-string
                                      ',(source-path-original-source *current-path*)
                                      *compile-file-pathname*))

-              (values-form `(,(car form)
+              (fun (car form))
+              (values-form `(,fun

                              ,@(if *step-arguments-p*
                                    (mapcar #'insert-step-conditions (cdr form))
                                    (cdr form)))))
          (ir1-convert start next result
                       `(locally (declare (optimize (insert-step-conditions 0)))
                              ,@(if *step-arguments-p*
                                    (mapcar #'insert-step-conditions (cdr form))
                                    (cdr form)))))
          (ir1-convert start next result
                       `(locally (declare (optimize (insert-step-conditions 0)))

-                        ,(if *step-arguments-p*
-                             `(let ((*step* ,step-form))
-                                (step-values ,form-string (multiple-value-list ,values-form)))
-                             `(progn ,step-form ,values-form)))))))))
+                         ,(if *step-arguments-p*
+                              `(let ((*step* ,step-form))
+                                 ,(if (known-single-value-fun-p fun)
+                                      `((lambda (value)
+                                          (step-values ,form-string (list value))
+                                          value)
+                                        ,values-form)
+                                      `(multiple-value-call
+                                           (lambda (&rest values)
+                                             (step-values ,form-string values)
+                                             (values-list values))
+                                         ,values-form)))
+                              `(progn ,step-form ,values-form)))))))))

 
 (defun step-form-p (form)
   #+sb-xc-host (declare (ignore form))
   #-sb-xc-host
   (flet ((step-symbol-p (symbol)
 
 (defun step-form-p (form)
   #+sb-xc-host (declare (ignore form))
   #-sb-xc-host
   (flet ((step-symbol-p (symbol)

-           (not (member (symbol-package symbol) 
-                        (load-time-value 
+           (not (member (symbol-package symbol)
+                        (load-time-value

                          ;; KLUDGE: packages we're not interested in stepping.
                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
     (let ((lexenv *lexenv*))
                          ;; KLUDGE: packages we're not interested in stepping.
                          (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
     (let ((lexenv *lexenv*))

-      (and (policy lexenv (>= insert-step-conditions 2))
+      (and *allow-instrumenting*
+           (policy lexenv (>= insert-step-conditions 2))

            (cond ((consp form)
                   (let ((op (car form)))
                     (or (and (consp op) (eq 'lambda (car op)))
            (cond ((consp form)
                   (let ((op (car form)))
                     (or (and (consp op) (eq 'lambda (car op)))

@@ -99,6 +117,7 @@
                              (step-symbol-p op)))))
                  ((symbolp form)
                   (and *step-arguments-p*
                              (step-symbol-p op)))))
                  ((symbolp form)
                   (and *step-arguments-p*

+                       *allow-instrumenting*

                        (policy lexenv (= insert-step-conditions 3))
                        (not (consp (lexenv-find form vars)))
                        (not (constantp form))
                        (policy lexenv (= insert-step-conditions 3))
                        (not (consp (lexenv-find form vars)))
                        (not (constantp form))