Index: /branches/working-0711-perf/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711-perf/ccl/compiler/X86/x862.lisp (revision 9412) +++ /branches/working-0711-perf/ccl/compiler/X86/x862.lisp (revision 9413) @@ -56,5 +56,6 @@ (*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,4 +170,5 @@ (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,4 +502,5 @@ (*x862-tail-allow* t) (*x862-reckless* nil) + (*x862-full-safety* nil) (*x862-trust-declarations* t) (*x862-entry-vstack* nil) @@ -747,4 +750,5 @@ (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,4 +1192,5 @@ (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,12 +1694,9 @@ (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,4 +1708,6 @@ (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,16 +2358,14 @@ (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,4 +3398,48 @@ (^)))))) +(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,21 +3459,23 @@ (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,5 +3487,5 @@ (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)