1.0.1.35: propagate (EQL X Y) constraints symmetrically

[sbcl.git] / src / compiler / ir1tran-lambda.lisp

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 2a92b98..2486661 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -537,6 +537,12 @@
         (arg-vals n-context)
         (arg-vals n-count))
 
+      ;; The reason for all the noise with
+      ;; STACK-GROWS-DOWNWARD-NOT-UPWARD is to enable generation of
+      ;; slightly more efficient code on x86oid processors.  (We can
+      ;; hoist the negation of the index outside the main parsing loop
+      ;; and take advantage of the base+index+displacement addressing
+      ;; mode on x86oids.)
       (when (optional-dispatch-keyp res)
         (let ((n-index (gensym "N-INDEX-"))
               (n-key (gensym "N-KEY-"))
@@ -547,8 +553,15 @@
                           (policy *lexenv* (zerop safety))))
               (found-allow-p nil))
 
-          (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
-          (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
+          (temps #!-stack-grows-downward-not-upward
+                 `(,n-index (1- ,n-count))
+                 #!+stack-grows-downward-not-upward
+                 `(,n-index (- (1- ,n-count)))
+                 #!-stack-grows-downward-not-upward n-value-temp
+                 #!-stack-grows-downward-not-upward n-key)
+          (body `(declare (fixnum ,n-index)
+                          #!-stack-grows-downward-not-upward
+                          (ignorable ,n-value-temp ,n-key)))
 
           (collect ((tests))
             (dolist (key keys)
@@ -589,6 +602,7 @@
                 (%odd-key-args-error)))
 
             (body
+             #!-stack-grows-downward-not-upward
              `(locally
                 (declare (optimize (safety 0)))
                 (loop
@@ -597,7 +611,16 @@
                   (decf ,n-index)
                   (setq ,n-key (%more-arg ,n-context ,n-index))
                   (decf ,n-index)
-                  (cond ,@(tests)))))
+                  (cond ,@(tests))))
+             #!+stack-grows-downward-not-upward
+             `(locally (declare (optimize (safety 0)))
+                (loop
+                  (when (plusp ,n-index) (return))
+                  (multiple-value-bind (,n-value-temp ,n-key)
+                      (%more-kw-arg ,n-context ,n-index)
+                    (declare (ignorable ,n-value-temp ,n-key))
+                    (incf ,n-index 2)
+                    (cond ,@(tests))))))
 
             (unless allowp
               (body `(when (and ,n-losep (not ,n-allowp))
@@ -862,7 +885,7 @@
 
 ;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
 (defun ir1-convert-lambda (form &key (source-name '.anonymous.)
-                           debug-name)
+                           debug-name maybe-add-debug-catch)
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"
                     (type-of form)
@@ -883,14 +906,10 @@
       (binding* (((*lexenv* result-type post-binding-lexenv)
                   (process-decls decls (append aux-vars vars) nil
                                  :binding-form-p t))
-                 (forms (if (and *allow-instrumenting*
+                 (forms (if (and maybe-add-debug-catch
+                                 *allow-instrumenting*
                                  (policy *lexenv* (>= insert-debug-catch 2)))
-                            `((catch (locally
-                                         (declare (optimize (insert-step-conditions 0)))
-                                       ;; Using MAKE-SYMBOL would lead
-                                       ;; to recursive disaster.
-                                       (%make-symbol "SB-DEBUG-CATCH-TAG"))
-                                ,@forms))
+                            (wrap-forms-in-debug-catch forms)
                             forms))
                  (forms (if (eq result-type *wild-type*)
                             forms
@@ -912,6 +931,29 @@
         (setf (functional-arg-documentation res) (cadr form))
         res))))
 
+(defun wrap-forms-in-debug-catch (forms)
+  `( ;; Normally, we'll return from this block with the below RETURN-FROM.
+    (block
+        return-value-tag
+      ;; If DEBUG-CATCH-TAG is thrown (with a thunk as the value) the
+      ;; RETURN-FROM is elided and we funcall the thunk instead. That
+      ;; thunk might either return a value (for a RETURN-FROM-FRAME)
+      ;; or call this same function again (for a RESTART-FRAME).
+      ;; -- JES, 2007-01-09
+      (funcall
+       (the function
+         ;; Use a constant catch tag instead of consing a new one for every
+         ;; entry to this block. The uniquencess of the catch tags is
+         ;; ensured when the tag is throw by the debugger. It'll allocate a
+         ;; new tag, and modify the reference this tag in the proper
+         ;; catch-block structure to refer to that new tag. This
+         ;; significantly decreases the runtime cost of high debug levels.
+         ;;  -- JES, 2007-01-09
+         (catch 'debug-catch-tag
+           (return-from return-value-tag
+             (progn
+               ,@forms))))))))
+
 ;;; helper for LAMBDA-like things, to massage them into a form
 ;;; suitable for IR1-CONVERT-LAMBDA.
 (defun ir1-convert-lambdalike (thing
@@ -921,6 +963,7 @@
   (ecase (car thing)
     ((lambda)
      (ir1-convert-lambda thing
+                         :maybe-add-debug-catch t
                          :source-name source-name
                          :debug-name debug-name))
     ((instance-lambda)
@@ -934,6 +977,7 @@
        (if (legal-fun-name-p name)
            (let ((defined-fun-res (get-defined-fun name))
                  (res (ir1-convert-lambda lambda-expression
+                                          :maybe-add-debug-catch t
                                           :source-name name)))
              (assert-global-function-definition-type name res)
              (setf (defined-fun-functional defined-fun-res) res)
@@ -943,7 +987,9 @@
                   (policy ref (> recognize-self-calls 0)))
                 res defined-fun-res))
              res)
-           (ir1-convert-lambda lambda-expression :debug-name name))))
+           (ir1-convert-lambda lambda-expression
+                               :maybe-add-debug-catch t
+                               :debug-name name))))
     ((lambda-with-lexenv)
      (ir1-convert-inline-lambda thing
                                 :source-name source-name