[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.119,1.120

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19689/src/pcl

Modified Files:
	boot.lisp 
Log Message:
0.9.15.36: less intrusive step instrumentation

 * INVOKE-EFFECTIVE-METHOD was missing a binding for the
   effective-method-form, causing potential multiple evaluation and
   also creating one source of confusion when step instrumenting CLOS
   code, manifesting as:

    Asserted type (MOD 536870911) conflicts with derived type
    (VALUES (OR FUNCTION SB-PCL::METHOD-CALL SB-PCL::FAST-METHOD-CALL) 
            &OPTIONAL).

 * If the form being instrumented is a call to a known single-valued
   function we can instrument it in a way that doesn't kill the
   type-inference. This alone is enough to get rid of most warnings
   such as above.

 * Add rudimentary (B)acktrace command to the built-in stepper.


Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.119
retrieving revision 1.120
diff -u -d -r1.119 -r1.120
--- boot.lisp	15 Aug 2006 08:49:51 -0000	1.119
+++ boot.lisp	16 Aug 2006 19:05:46 -0000	1.120
@@ -964,8 +964,8 @@
      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
      (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
 
-(defmacro invoke-effective-method-function (emf restp
-                                                &rest required-args+rest-arg)
+(defmacro invoke-effective-method-function (emf-form restp
+                                            &rest required-args+rest-arg)
   (unless (constantp restp)
     (error "The RESTP argument is not constant."))
   ;; FIXME: The RESTP handling here is confusing and maybe slightly
@@ -973,49 +973,50 @@
   ;;   (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
   ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
   (setq restp (constant-form-value restp))
-  `(progn
-     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
-     (cond ((typep ,emf 'fast-method-call)
-            (invoke-fast-method-call ,emf ,@required-args+rest-arg))
-           ;; "What," you may wonder, "do these next two clauses do?"
-           ;; In that case, you are not a PCL implementor, for they
-           ;; considered this to be self-documenting.:-| Or CSR, for
-           ;; that matter, since he can also figure it out by looking
-           ;; at it without breaking stride. For the rest of us,
-           ;; though: From what the code is doing with .SLOTS. and
-           ;; whatnot, evidently it's implementing SLOT-VALUEish and
-           ;; GET-SLOT-VALUEish things. Then we can reason backwards
-           ;; and conclude that setting EMF to a FIXNUM is an
-           ;; optimized way to represent these slot access operations.
-           ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
-               `(((typep ,emf 'fixnum)
-                  (let* ((.slots. (get-slots-or-nil
-                                   ,(car required-args+rest-arg)))
-                         (value (when .slots. (clos-slots-ref .slots. ,emf))))
-                    (if (eq value +slot-unbound+)
-                        (slot-unbound-internal ,(car required-args+rest-arg)
-                                               ,emf)
-                        value)))))
-           ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
-               `(((typep ,emf 'fixnum)
-                  (let ((.new-value. ,(car required-args+rest-arg))
-                        (.slots. (get-slots-or-nil
-                                  ,(cadr required-args+rest-arg))))
-                    (when .slots.
-                      (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
-           ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
-           ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
-           ;; there was no explanation and presumably the code is 10+
-           ;; years stale, I simply deleted it. -- WHN)
-           (t
-            (etypecase ,emf
-              (method-call
-               (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
-              (function
-               ,(if restp
-                    `(apply (the function ,emf) ,@required-args+rest-arg)
-                    `(funcall (the function ,emf)
-                              ,@required-args+rest-arg))))))))
+  (with-unique-names (emf)
+    `(let ((,emf ,emf-form))
+      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
+      (cond ((typep ,emf 'fast-method-call)
+             (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+            ;; "What," you may wonder, "do these next two clauses do?"
+            ;; In that case, you are not a PCL implementor, for they
+            ;; considered this to be self-documenting.:-| Or CSR, for
+            ;; that matter, since he can also figure it out by looking
+            ;; at it without breaking stride. For the rest of us,
+            ;; though: From what the code is doing with .SLOTS. and
+            ;; whatnot, evidently it's implementing SLOT-VALUEish and
+            ;; GET-SLOT-VALUEish things. Then we can reason backwards
+            ;; and conclude that setting EMF to a FIXNUM is an
+            ;; optimized way to represent these slot access operations.
+            ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
+                    `(((typep ,emf 'fixnum)
+                       (let* ((.slots. (get-slots-or-nil
+                                        ,(car required-args+rest-arg)))
+                              (value (when .slots. (clos-slots-ref .slots. ,emf))))
+                         (if (eq value +slot-unbound+)
+                             (slot-unbound-internal ,(car required-args+rest-arg)
+                                                    ,emf)
+                             value)))))
+            ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
+                    `(((typep ,emf 'fixnum)
+                       (let ((.new-value. ,(car required-args+rest-arg))
+                             (.slots. (get-slots-or-nil
+                                       ,(cadr required-args+rest-arg))))
+                         (when .slots.
+                           (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
+            ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+            ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+            ;; there was no explanation and presumably the code is 10+
+            ;; years stale, I simply deleted it. -- WHN)
+            (t
+             (etypecase ,emf
+               (method-call
+                (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
+               (function
+                ,(if restp
+                     `(apply (the function ,emf) ,@required-args+rest-arg)
+                     `(funcall (the function ,emf)
+                               ,@required-args+rest-arg)))))))))
 
 (defun invoke-emf (emf args)
   (trace-emf-call emf t args)