1.0.43.19: don't record source-paths for sub-parts of quoted constants

 Fixes the performance-half of lp#654289.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index fb974ef..e51dc48 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -487,16 +487,19 @@
           (trail form))
       (declare (fixnum pos))
       (macrolet ((frob ()
-                   '(progn
+                   `(progn
                       (when (atom subform) (return))
                       (let ((fm (car subform)))
-                        (if (consp fm)
-                            ;; If it's a cons, recurse
-                            (sub-find-source-paths fm (cons pos path))
-                            ;; Otherwise store the containing form. It's
-                            ;; not perfect, but better than nothing.
-                            (unless (zerop pos)
-                              (note-source-path subform pos path)))
+                        (cond ((consp fm)
+                               ;; If it's a cons, recurse.
+                               (sub-find-source-paths fm (cons pos path)))
+                              ((eq 'quote fm)
+                               ;; Don't look into quoted constants.
+                               (return))
+                              ((not (zerop pos))
+                               ;; Otherwise store the containing form. It's not
+                               ;; perfect, but better than nothing.
+                               (note-source-path subform pos path)))
                         (incf pos))
                       (setq subform (cdr subform))
                       (when (eq subform trail) (return)))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index b809242..439518e 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3559,9 +3559,26 @@
                 ((and warning (not style-warning)) ()
                   :warning)))))
 
-(with-test (:name :bug)
+(with-test (:name :bug-646796)
   (assert 42
           (funcall
            (compile nil
                     `(lambda ()
                        (load-time-value (the (values fixnum) 42)))))))
+
+(with-test (:name :bug-654289)
+  (let* ((big (labels ((make-tree (n acc)
+                         (cond ((zerop n) acc)
+                               (t (make-tree (1- n) (cons acc acc))))))
+                (make-tree 10000 nil)))
+         (small '((1) (2) (3)))
+         (t0 (get-internal-run-time))
+         (f1 (compile nil `(lambda (x) (eq x (quote ,big)))))
+         (t1 (get-internal-run-time))
+         (f2 (compile nil `(lambda (x) (eq x (quote ,small)))))
+         (t2 (get-internal-run-time)))
+    (assert (funcall f1 big))
+    (assert (funcall f2 small))
+    ;; Compile time should not explode just because there's a big constant
+    ;; object in the source.
+    (assert (> 10 (abs (- (- t1 t0) (- t2 t1)))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index a4ed179..8cba3d0 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.43.18"
+"1.0.43.19"