Changeset 9413

Timestamp:

May 9, 2008, 2:07:42 AM (17 years ago)

Author:

Gary Byers

Message:

Port rme's SBIT improvements from trunk to this branch.

Introduce *X862-FULL-SAFETY*, set it when processing encoded declaration
info. (The idea is to make the backend aware of when (optimize (safety 3))
is in effect and to avoid unsafe behavior in the backend when it is.)
Needs work to be useful, but probably the right idea.

File:

• branches/working-0711-perf/ccl/compiler/X86/x862.lisp (modified) (11 diffs)

branches/working-0711-perf/ccl/compiler/X86/x862.lisp

@@ -56 +56 @@
           (*x862-reckless* *x862-reckless*)
           (*x862-open-code-inline* *x862-open-code-inline*)
-          (*x862-trust-declarations* *x862-trust-declarations*))
+          (*x862-trust-declarations* *x862-trust-declarations*)
+          (*x862-full-safety* *x862-full-safety*))
      (x862-decls ,declsform)
      ,@body))
@@ -169 +170 @@
 (defvar *x862-tail-allow* t)
 (defvar *x862-reckless* nil)
+(defvar *x862-full-safety* nil)
 (defvar *x862-trust-declarations* nil)
 (defvar *x862-entry-vstack* nil)
@@ -500 +502 @@
            (*x862-tail-allow* t)
            (*x862-reckless* nil)
+           (*x862-full-safety* nil)
            (*x862-trust-declarations* t)
            (*x862-entry-vstack* nil)
@@ -747 +750 @@
       (setq *x862-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
             *x862-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
+            *x862-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
             *x862-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
             *x862-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
@@ -1188 +1192 @@
                         (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
                    (if (and (null vreg)
+                            (not *x862-full-safety*)
                             (%ilogbitp operator-acode-subforms-bit op)
                             (%ilogbitp operator-assignment-free-bit op))
@@ -1689 +1694 @@
              (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
                (! misc-ref-c-bit-fixnum target src index-known-fixnum)
-               (with-imm-temps
-                   () (word-index bitnum)
-                 (if index-known-fixnum
-                   (progn
-                     (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6)))
-                     (x862-lri seg bitnum (logand index-known-fixnum #x63)))
-                   (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx))
-                 (! ref-bit-vector-fixnum target bitnum src word-index))))))))
+               (with-imm-target () bitnum
+                 (if index-known-fixnum
+                   (x862-lri seg bitnum index-known-fixnum)
+                   (! scale-1bit-misc-index bitnum unscaled-idx))
+                 (! nref-bit-vector-fixnum target bitnum src))))))))
     (^)))
 
@@ -1706 +1708 @@
 (defun x862-vref (seg vreg xfer type-keyword vector index safe)
   (with-x86-local-vinsn-macros (seg vreg xfer)
+    (when *x862-full-safety*
+      (unless vreg (setq vreg x8664::arg_z)))
     (if (null vreg)
       (progn
@@ -2354 +2358 @@
                       (progn
                         (! set-constant-bit-to-variable-value src index-known-fixnum val-reg)))
-                    (with-imm-temps () (word-index bit-number)
-                      (if index-known-fixnum
-                        (progn
-                          (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6)))
-                          (x862-lri seg bit-number (logand index-known-fixnum #x63)))
-                        (! word-index-and-bitnum-from-index word-index bit-number unscaled-idx))
-                      (if constval
-                        (if (zerop constval)
-                          (! set-variable-bit-to-zero src word-index bit-number)
-                          (! set-variable-bit-to-one src word-index bit-number))
-                        (progn
-                          (! set-variable-bit-to-variable-value src word-index bit-number val-reg))))))))))
+                    (progn
+                      (if index-known-fixnum
+                        (x862-lri seg scaled-idx index-known-fixnum)
+                        (! scale-1bit-misc-index scaled-idx unscaled-idx))
+                      (if constval
+                        (if (zerop constval)
+                          (! nset-variable-bit-to-zero src scaled-idx)
+                          (! nset-variable-bit-to-one src scaled-idx))
+                        (progn
+                          (! nset-variable-bit-to-variable-value src scaled-idx val-reg))))))))))
       (when (and vreg val-reg) (<- val-reg))
       (^))))
@@ -3396 +3398 @@
          (^))))))
 
+(defun x862-coalesce-fixnum-boolean-comparison (seg vreg xfer fixnum form cr-bit true-p fixnum-was-first)
+  (declare (ignorable  fixnum-was-first))
+  (let* ((form (nx-untyped-form form)))
+    (cond ((and (acode-p form)
+                (eql (acode-operator form) (%nx1-operator %typed-uvref))
+                (eq (x862-immediate-operand (cadr form)) :bit-vector)
+                (or (eql fixnum 0) (eql fixnum (ash 1 *x862-target-fixnum-shift*)))
+                (eql cr-bit x86::x86-e-bits))
+           (with-x86-local-vinsn-macros (seg vreg xfer)
+             (destructuring-bind (vector index) (cddr form)
+               (let* ((safe (not *x862-reckless*))
+                      (arch (backend-target-arch *target-backend*))
+                      (index-known-fixnum (acode-fixnum-form-p index))
+                      (unscaled-idx nil)
+                      (src nil))
+                 (if (or safe (not index-known-fixnum))
+                   (multiple-value-setq (src unscaled-idx)
+                     (x862-two-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z))
+                   (setq src (x862-one-untargeted-reg-form seg vector x8664::arg_z)))
+                 (when safe
+                   (! trap-unless-typecode= src (nx-lookup-target-uvector-subtag :bit-vector))
+                   (unless index-known-fixnum
+                     (! trap-unless-fixnum unscaled-idx))
+                   (! check-misc-bound unscaled-idx src))
+                 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
+                   (! misc-ref-c-bit-flags  src index-known-fixnum)
+                   (with-imm-target () bitnum
+                     (if index-known-fixnum
+                       (x862-lri seg bitnum index-known-fixnum)
+                       (! scale-1bit-misc-index bitnum unscaled-idx))
+                     (! nref-bit-vector-flags bitnum src)))
+                 (setq true-p (eq (not (eql fixnum 0)) (not (null true-p)))
+                       cr-bit x86::x86-b-bits)
+                 (if (backend-crf-p vreg)
+                   (^ x86::x86-b-bits true-p)
+                   (progn
+                     (ensuring-node-target (target vreg)
+                       (if (not true-p)
+                         (setq cr-bit (logxor 1 cr-bit)))
+                       (! cr-bit->boolean target cr-bit))
+                     (^))))))
+           t)
+          (t nil))))
+
 ;;; There are other cases involving constants that are worth exploiting.
 (defun x862-compare (seg vreg xfer i j cr-bit true-p)
@@ -3413 +3459 @@
         (if u8-operator
           (x862-compare-u8 seg vreg xfer u8-operand u8 (if (and iu8 (not (eq cr-bit x86::x86-e-bits))) (logxor 1 cr-bit) cr-bit) true-p u8-operator)
-          (if (and boolean (or js32 is32))
-            (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) x8664::arg_z))
-                   (constant (or js32 is32)))
-              (if (zerop constant)
-                (! compare-reg-to-zero reg)
-                (! compare-s32-constant reg (or js32 is32)))
-              (unless (or js32 (eq cr-bit x86::x86-e-bits))
-                (setq cr-bit (x862-reverse-cr-bit cr-bit)))
-              (^ cr-bit true-p))
-            (if (and ;(eq cr-bit x86::x86-e-bits) 
+          (or (and (or js32 is32)
+                   (x862-coalesce-fixnum-boolean-comparison seg vreg xfer (or is32 js32) (if is32 j i) cr-bit true-p is32))
+              (if (and boolean (or js32 is32))
+                (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) x8664::arg_z))
+                       (constant (or js32 is32)))
+                  (if (zerop constant)
+                    (! compare-reg-to-zero reg)
+                    (! compare-s32-constant reg (or js32 is32)))
+                  (unless (or js32 (eq cr-bit x86::x86-e-bits))
+                    (setq cr-bit (x862-reverse-cr-bit cr-bit)))
+                  (^ cr-bit true-p))
+                (if (and ;(eq cr-bit x86::x86-e-bits) 
                      (or js32 is32))
-              (progn
-                (unless (or js32 (eq cr-bit x86::x86-e-bits))
-                  (setq cr-bit (x862-reverse-cr-bit cr-bit)))
-              (x862-test-reg-%izerop
-               seg 
-               vreg 
+                  (progn
+                    (unless (or js32 (eq cr-bit x86::x86-e-bits))
+                      (setq cr-bit (x862-reverse-cr-bit cr-bit)))
+                    (x862-test-reg-%izerop
+                     seg 
+                     vreg 
                xfer 
                (x862-one-untargeted-reg-form 
@@ -3439 +3487 @@
                (or js32 is32)))
               (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i x8664::arg_y j x8664::arg_z)
-                (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))))
+                (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p))))))))))
 
 (defun x862-natural-compare (seg vreg xfer i j cr-bit true-p)