X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-step.lisp;h=023a265542d8221a24a9753bca2ddbb855b473a6;hb=1ac136852028fcd4d5568e996ebc612136c26b4f;hp=8f852fe6f376db9d3cb4daf26248f0f4998100cc;hpb=28dcf682ef2a3c80b7bcdda00787dbb5e3893abe;p=sbcl.git

diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp
index 8f852fe..023a265 100644
--- a/src/compiler/ir1-step.lisp
+++ b/src/compiler/ir1-step.lisp
@@ -32,60 +32,76 @@
         (setf *stepping* nil))
       (step-next ()
         nil)
-      (step-into () 
+      (step-into ()
         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*
-    (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
-	     (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)
 
+(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
-       (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
        (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*))
-              (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*
-                             `(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)
-           (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*))