From 2230ea0c1765a95fd2aa0a8996b3555b93ba3745 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Sun, 28 Jun 2009 21:37:05 +0000 Subject: [PATCH] 1.0.29.54: Inline unboxed constants on x86[-64] * New build-time feature: inline-constants, which specifies that SB!C and SB!VM implement a protocol described in base-target-features.lisp-expr. Backends implementing that feature are able to load constants from code components, in a section that follows the actual executable code. * Implement the protocol on x86 and x86-64, and use it for float constants, and, on x86-64 only, mid-sized (> 2^(29-32), but still machine-sized) integers. * Use the new feature in integer and float arithmetic VOPs. * Adjust a few test cases to take newly consing situations into account. * Clean-up: - New build-time feature: float-eql-vops, which disable rewriting EQL of single and double floats in terms of foo-float*-bits. - Fix a typo (unused variable lookup) in TWO-ARG-+/- --- NEWS | 10 +- base-target-features.lisp-expr | 36 +++ make-config.sh | 3 +- package-data-list.lisp-expr | 6 + src/code/numbers.lisp | 2 +- src/compiler/codegen.lisp | 44 ++- src/compiler/early-c.lisp | 5 + src/compiler/generic/vm-macs.lisp | 2 +- src/compiler/generic/vm-tran.lisp | 4 +- src/compiler/main.lisp | 8 +- src/compiler/x86-64/arith.lisp | 238 +++++++++++----- src/compiler/x86-64/float.lisp | 556 +++++++++++++++++++++++++------------ src/compiler/x86-64/insts.lisp | 93 +++++++ src/compiler/x86-64/vm.lisp | 37 +-- src/compiler/x86/float.lisp | 13 +- src/compiler/x86/insts.lisp | 63 +++++ src/compiler/x86/vm.lisp | 31 ++- tests/arith.pure.lisp | 65 +++++ tests/compiler.impure.lisp | 6 +- tests/dynamic-extent.impure.lisp | 8 +- tests/float.pure.lisp | 17 +- version.lisp-expr | 2 +- 22 files changed, 954 insertions(+), 295 deletions(-) diff --git a/NEWS b/NEWS index 5e77bc5..5477cc3 100644 --- a/NEWS +++ b/NEWS @@ -9,8 +9,6 @@ values in other threads. * new feature: SB-INTROSPECT:ALLOCATION-INFORMATION provides information about object allocation. - * optimization: more efficient complex float and real float operations - on x86-64. * optimization: division of a real float by a complex float is implemented with a specialised code sequence. * optimization: MAKE-INSTANCE with non-constant class-argument but constant @@ -31,6 +29,14 @@ * optimization: the compiler now derives simple types for LOAD-VALUE-FORMs. * improvement: less unsafe constant folding in floating point arithmetic, especially for mixed complex/real -float operations. + * optimization: constant double and single floats are stored in native + unboxed format on x86[-64]. + * optimization: smarter code for arithmetic operations with constant floats, + complex floats, or integers on x86[-64]. + * optimization: smarter code for conjugate/multiplication of float complexes + and abs/negate of floats on x86-64. + * optimization: more efficient complex float and real float operations on + x86-64. * improvement: complex float division is slightly more stable. * improvement: DESCRIBE output has been reworked to be easier to read and contains more pertinent information. diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index f389507..50b732e 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -167,6 +167,42 @@ ;; ; :complex-float-vops + ;; Enabled automatically for platforms which implement VOPs for EQL + ;; of single and double floats. + ;; + ; :float-eql-vops + + ;; Enabled automatically for platform that can implement inline constants. + ;; + ;; Such platform must implement 5 functions, in SB!VM: + ;; * canonicalize-inline-constant: converts a constant descriptor (list) into + ;; a canonical description, to be used as a key in an EQUAL hash table + ;; and to guide the generation of the constant itself. + ;; * inline-constant-value: given a canonical constant descriptor, computes + ;; two values: + ;; 1. A label that will be used to emit the constant (usually a + ;; sb!assem:label) + ;; 2. A value that will be returned to code generators referring to + ;; the constant (on x86oids, an EA object) + ;; * sort-inline-constants: Receives a vector of unique constants; + ;; the car of each entry is the constant descriptor, and the cdr the + ;; corresponding label. Destructively returns a vector of constants + ;; sorted in emission order. It could actually perform arbitrary + ;; modifications to the vector, e.g. to fuse constants of different + ;; size. + ;; * emit-constant-segment-header: receives the vector of sorted constants + ;; and a flag (true iff speed > space). Expected to emit padding + ;; of some sort between the ELSEWHERE segment and the constants, or some + ;; metadata. + ;; * emit-inline-constant: receives a constant descriptor and its associated + ;; label. Emits the constant. + ;; + ;; Implementing this features lets VOP generators use sb!c:register-inline-constant + ;; to get handles (as returned by sb!vm:inline-constant-value) from constant + ;; descriptors. + ;; + ; :inline-constants + ;; Peter Van Eynde's increase-bulletproofness code for CMU CL ;; ;; Some of the code which was #+high-security before the fork has now diff --git a/make-config.sh b/make-config.sh index 468c79f..e3da7bc 100644 --- a/make-config.sh +++ b/make-config.sh @@ -281,7 +281,7 @@ if [ "$sbcl_arch" = "x86" ]; then printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop :raw-instance-init-vops' >> $ltf printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf - printf ' :alien-callbacks :cycle-counter' >> $ltf + printf ' :alien-callbacks :cycle-counter :inline-constants ' >> $ltf case "$sbcl_os" in linux | freebsd | netbsd | openbsd | sunos | darwin | win32) printf ' :linkage-table' >> $ltf @@ -297,6 +297,7 @@ elif [ "$sbcl_arch" = "x86-64" ]; then printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :alien-callbacks :cycle-counter :complex-float-vops' >> $ltf + printf ' :float-eql-vops :inline-constants ' >> $ltf elif [ "$sbcl_arch" = "mips" ]; then printf ' :linkage-table' >> $ltf printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a7edc0d..64f90e8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -312,6 +312,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP" "PRIMITIVE-TYPE-NAME" "PUSH-VALUES" "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING" + #!+inline-constants "REGISTER-INLINE-CONSTANT" "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE" "RETURN-MULTIPLE" "SAVE-DYNAMIC-STATE" "SB" "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" "SB-P" "SC" "SC-CASE" @@ -2521,6 +2522,11 @@ structure representations" "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER" "IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER" "IMMEDIATE-SC-NUMBER" + #!+inline-constants "CANONICALIZE-INLINE-CONSTANT" + #!+inline-constants "INLINE-CONSTANT-VALUE" + #!+inline-constants "EMIT-CONSTANT-SEGMENT-HEADER" + #!+inline-constants "SORT-INLINE-CONSTANTS" + #!+inline-constants "EMIT-INLINE-CONSTANT" "INSTANCE-HEADER-WIDETAG" "INSTANCE-POINTER-LOWTAG" "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGS" diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index b8ef200..6a2dd70 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -358,7 +358,7 @@ (bignum-cross-fixnum ,op ,big-op) (float-contagion ,op x y) - ((complex complex) + + ((complex complex) (canonical-complex (,op (realpart x) (realpart y)) (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index df6d06a..0756176 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -59,6 +59,12 @@ (defvar *code-segment* nil) (defvar *elsewhere* nil) (defvar *elsewhere-label* nil) +#!+inline-constants +(progn + (defvar *constant-segment* nil) + (defvar *constant-table* nil) + (defvar *constant-vector* nil)) + ;;;; noise to emit an instruction trace @@ -111,7 +117,16 @@ (setf *elsewhere* (sb!assem:make-segment :type :elsewhere :run-scheduler (default-segment-run-scheduler) - :inst-hook (default-segment-inst-hook))) + :inst-hook (default-segment-inst-hook) + :alignment 0)) + #!+inline-constants + (setf *constant-segment* + (sb!assem:make-segment :type :elsewhere + :run-scheduler nil + :inst-hook (default-segment-inst-hook) + :alignment 0) + *constant-table* (make-hash-table :test #'equal) + *constant-vector* (make-array 16 :adjustable t :fill-pointer 0)) (values)) (defun generate-code (component) @@ -163,6 +178,24 @@ (template-name (vop-info vop))))))) (sb!assem:append-segment *code-segment* *elsewhere*) (setf *elsewhere* nil) + #!+inline-constants + (progn + (unless (zerop (length *constant-vector*)) + (let ((constants (sb!vm:sort-inline-constants *constant-vector*))) + (assemble (*constant-segment*) + (sb!vm:emit-constant-segment-header + constants + (do-ir2-blocks (2block component nil) + (when (policy (block-last (ir2-block-block 2block)) + (> speed space)) + (return t)))) + (map nil (lambda (constant) + (sb!vm:emit-inline-constant (car constant) (cdr constant))) + constants))) + (sb!assem:append-segment *code-segment* *constant-segment*)) + (setf *constant-segment* nil + *constant-vector* nil + *constant-table* nil)) (values (sb!assem:finalize-segment *code-segment*) (nreverse *trace-table-info*) *fixup-notes*))) @@ -178,3 +211,12 @@ (label-position label-or-posn)) (index label-or-posn)))) + +#!+inline-constants +(defun register-inline-constant (&rest constant-descriptor) + (declare (dynamic-extent constant-descriptor)) + (let ((constant (sb!vm:canonicalize-inline-constant constant-descriptor))) + (or (gethash constant *constant-table*) + (multiple-value-bind (label value) (sb!vm:inline-constant-value constant) + (vector-push-extend (cons constant label) *constant-vector*) + (setf (gethash constant *constant-table*) value))))) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 7549400..736056b 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -104,6 +104,11 @@ (defvar *fixup-notes*) (defvar *in-pack*) (defvar *info-environment*) +#!+inline-constants +(progn + (defvar *constant-segment*) + (defvar *constant-table*) + (defvar *constant-vector*)) (defvar *lexenv*) (defvar *source-info*) (defvar *source-plist*) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 482bd35..8789a96 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -162,7 +162,7 @@ (in-package "SB!C") ;;; the maximum number of SCs in any implementation -(def!constant sc-number-limit 32) +(def!constant sc-number-limit 40) ;;; Modular functions diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 4614221..22f075a 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -584,11 +584,11 @@ (values))) ;;;; transforms for EQL of floating point values -#!-x86-64 +#!-float-eql-vops (deftransform eql ((x y) (single-float single-float)) '(= (single-float-bits x) (single-float-bits y))) -#!-x86-64 +#!-float-eql-vops (deftransform eql ((x y) (double-float double-float)) '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 759f06e..12d9890 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -448,7 +448,13 @@ (defun %compile-component (component) (let ((*code-segment* nil) - (*elsewhere* nil)) + (*elsewhere* nil) + #!+inline-constants + (*constant-segment* nil) + #!+inline-constants + (*constant-table* nil) + #!+inline-constants + (*constant-vector* nil)) (maybe-mumble "GTN ") (gtn-analyze component) (maybe-mumble "LTN ") diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index f615ebd..4735ce3 100644 --- a/src/compiler/x86-64/arith.lisp +++ b/src/compiler/x86-64/arith.lisp @@ -109,31 +109,38 @@ (:note "inline (signed-byte 64) arithmetic")) (define-vop (fast-fixnum-binop-c fast-safe-arith-op) - (:args (x :target r :scs (any-reg control-stack))) + (:args (x :target r :scs (any-reg) + :load-if (or (not (typep y '(signed-byte 29))) + (not (sc-is x any-reg control-stack))))) (:info y) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:arg-types tagged-num (:constant fixnum)) (:results (r :scs (any-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(signed-byte 29)))))) (:result-types tagged-num) (:note "inline fixnum arithmetic")) -;; 31 not 64 because it's hard work loading 64 bit constants, and since -;; sign-extension of immediates causes problems with 32. (define-vop (fast-unsigned-binop-c fast-safe-arith-op) - (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:args (x :target r :scs (unsigned-reg) + :load-if (or (not (typep y '(unsigned-byte 31))) + (not (sc-is x unsigned-reg unsigned-stack))))) (:info y) - (:arg-types unsigned-num (:constant (unsigned-byte 31))) + (:arg-types unsigned-num (:constant (unsigned-byte 64))) (:results (r :scs (unsigned-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(unsigned-byte 31)))))) (:result-types unsigned-num) (:note "inline (unsigned-byte 64) arithmetic")) (define-vop (fast-signed-binop-c fast-safe-arith-op) - (:args (x :target r :scs (signed-reg signed-stack))) + (:args (x :target r :scs (signed-reg) + :load-if (or (not (typep y '(signed-byte 32))) + (not (sc-is x signed-reg signed-stack))))) (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) + (:arg-types signed-num (:constant (signed-byte 64))) (:results (r :scs (signed-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(signed-byte 32)))))) (:result-types signed-num) (:note "inline (signed-byte 64) arithmetic")) @@ -150,7 +157,9 @@ (:translate ,translate) (:generator 1 (move r x) - (inst ,op r (fixnumize y)))) + (inst ,op r (if (typep y '(signed-byte 29)) + (fixnumize y) + (register-inline-constant :qword (fixnumize y)))))) (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") fast-signed-binop) (:translate ,translate) @@ -162,7 +171,9 @@ (:translate ,translate) (:generator ,untagged-penalty (move r x) - (inst ,op r y))) + (inst ,op r (if (typep y '(signed-byte 32)) + y + (register-inline-constant :qword y))))) (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") @@ -178,7 +189,9 @@ (:translate ,translate) (:generator ,untagged-penalty (move r x) - (inst ,op r y)))))) + (inst ,op r (if (typep y '(unsigned-byte 31)) + y + (register-inline-constant :qword y)))))))) ;;(define-binop + 4 add) (define-binop - 4 sub) @@ -214,19 +227,26 @@ (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) (:translate +) - (:args (x :target r :scs (any-reg control-stack))) + (:args (x :target r :scs (any-reg) + :load-if (or (not (typep y '(signed-byte 29))) + (not (sc-is x any-reg control-stack))))) (:info y) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:arg-types tagged-num (:constant fixnum)) (:results (r :scs (any-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(signed-byte 29)))))) (:result-types tagged-num) (:note "inline fixnum arithmetic") (:generator 1 - (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))) + (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)) + (typep y '(signed-byte 29))) (inst lea r (make-ea :qword :base x :disp (fixnumize y)))) + ((typep y '(signed-byte 29)) + (move r x) + (inst add r (fixnumize y))) (t (move r x) - (inst add r (fixnumize y)))))) + (inst add r (register-inline-constant :qword (fixnumize y))))))) (define-vop (fast-+/signed=>signed fast-safe-arith-op) (:translate +) @@ -266,8 +286,10 @@ (define-vop (fast-logand-c/signed-unsigned=>unsigned fast-logand-c/unsigned=>unsigned) - (:args (x :target r :scs (signed-reg signed-stack))) - (:arg-types signed-num (:constant (unsigned-byte 31)))) + (:args (x :target r :scs (signed-reg) + :load-if (or (not (typep y '(unsigned-byte 31))) + (not (sc-is r signed-reg signed-stack))))) + (:arg-types signed-num (:constant (unsigned-byte 64)))) (define-vop (fast-logand/unsigned-signed=>unsigned fast-logand/unsigned=>unsigned) @@ -282,22 +304,29 @@ (define-vop (fast-+-c/signed=>signed fast-safe-arith-op) (:translate +) - (:args (x :target r :scs (signed-reg signed-stack))) + (:args (x :target r :scs (signed-reg) + :load-if (or (not (typep y '(signed-byte 32))) + (not (sc-is r signed-reg signed-stack))))) (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) + (:arg-types signed-num (:constant (signed-byte 64))) (:results (r :scs (signed-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(signed-byte 32)))))) (:result-types signed-num) (:note "inline (signed-byte 64) arithmetic") (:generator 4 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg) - (not (location= x r))) + (not (location= x r)) + (typep y '(signed-byte 32))) (inst lea r (make-ea :qword :base x :disp y))) (t (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))))) + (cond ((= y 1) + (inst inc r)) + ((typep y '(signed-byte 32)) + (inst add r y)) + (t + (inst add r (register-inline-constant :qword y)))))))) (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) (:translate +) @@ -325,22 +354,29 @@ (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) (:translate +) - (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:args (x :target r :scs (unsigned-reg) + :load-if (or (not (typep y '(unsigned-byte 31))) + (not (sc-is x unsigned-reg unsigned-stack))))) (:info y) - (:arg-types unsigned-num (:constant (unsigned-byte 31))) + (:arg-types unsigned-num (:constant (unsigned-byte 64))) (:results (r :scs (unsigned-reg) - :load-if (not (location= x r)))) + :load-if (or (not (location= x r)) + (not (typep y '(unsigned-byte 31)))))) (:result-types unsigned-num) (:note "inline (unsigned-byte 64) arithmetic") (:generator 4 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg) - (not (location= x r))) + (not (location= x r)) + (typep y '(unsigned-byte 31))) (inst lea r (make-ea :qword :base x :disp y))) (t (move r x) - (if (= y 1) - (inst inc r) - (inst add r y)))))) + (cond ((= y 1) + (inst inc r)) + ((typep y '(unsigned-byte 31)) + (inst add r y)) + (t + (inst add r (register-inline-constant :qword y)))))))) ;;;; multiplication and division @@ -361,14 +397,20 @@ (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op) (:translate *) ;; We need different loading characteristics. - (:args (x :scs (any-reg control-stack))) + (:args (x :scs (any-reg) + :load-if (or (not (typep y '(signed-byte 32))) + (not (sc-is x any-reg control-stack))))) (:info y) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:arg-types tagged-num (:constant fixnum)) (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic") (:generator 3 - (inst imul r x y))) + (cond ((typep y '(signed-byte 32)) + (inst imul r x y)) + (t + (move r x) + (inst imul r (register-inline-constant :qword y)))))) (define-vop (fast-*/signed=>signed fast-safe-arith-op) (:translate *) @@ -386,14 +428,20 @@ (define-vop (fast-*-c/signed=>signed fast-safe-arith-op) (:translate *) ;; We need different loading characteristics. - (:args (x :scs (signed-reg signed-stack))) + (:args (x :scs (signed-reg) + :load-if (or (not (typep y '(signed-byte 32))) + (not (sc-is x signed-reg signed-stack))))) (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) + (:arg-types signed-num (:constant (signed-byte 64))) (:results (r :scs (signed-reg))) (:result-types signed-num) (:note "inline (signed-byte 64) arithmetic") (:generator 4 - (inst imul r x y))) + (cond ((typep y '(signed-byte 32)) + (inst imul r x y)) + (t + (move r x) + (inst imul r (register-inline-constant :qword y)))))) (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op) (:translate *) @@ -415,6 +463,26 @@ (inst mul eax y) (move r eax))) +(define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op) + (:translate *) + (:args (x :scs (unsigned-reg) :target eax)) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 64))) + (:temporary (:sc unsigned-reg :offset eax-offset :target r + :from (:argument 0) :to :result) eax) + (:temporary (:sc unsigned-reg :offset edx-offset + :from :eval :to :result) edx) + (:ignore edx) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 64) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (move eax x) + (inst mul eax (register-inline-constant :qword y)) + (move r eax))) + (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op) (:translate truncate) @@ -449,7 +517,7 @@ (:translate truncate) (:args (x :scs (any-reg) :target eax)) (:info y) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:arg-types tagged-num (:constant fixnum)) (:temporary (:sc signed-reg :offset eax-offset :target quo :from :argument :to (:result 0)) eax) (:temporary (:sc any-reg :offset edx-offset :target rem @@ -464,7 +532,9 @@ (:generator 30 (move eax x) (inst cqo) - (inst mov y-arg (fixnumize y)) + (if (typep y '(signed-byte 29)) + (inst mov y-arg (fixnumize y)) + (setf y-arg (register-inline-constant :qword (fixnumize y)))) (inst idiv eax y-arg) (if (location= quo eax) (inst shl eax 3) @@ -502,7 +572,7 @@ (:translate truncate) (:args (x :scs (unsigned-reg) :target eax)) (:info y) - (:arg-types unsigned-num (:constant (unsigned-byte 31))) + (:arg-types unsigned-num (:constant (unsigned-byte 64))) (:temporary (:sc unsigned-reg :offset eax-offset :target quo :from :argument :to (:result 0)) eax) (:temporary (:sc unsigned-reg :offset edx-offset :target rem @@ -517,7 +587,9 @@ (:generator 32 (move eax x) (inst xor edx edx) - (inst mov y-arg y) + (if (typep y '(unsigned-byte 31)) + (inst mov y-arg y) + (setf y-arg (register-inline-constant :qword y))) (inst div eax y-arg) (move quo eax) (move rem edx))) @@ -553,7 +625,7 @@ (:translate truncate) (:args (x :scs (signed-reg) :target eax)) (:info y) - (:arg-types signed-num (:constant (signed-byte 32))) + (:arg-types signed-num (:constant (signed-byte 64))) (:temporary (:sc signed-reg :offset eax-offset :target quo :from :argument :to (:result 0)) eax) (:temporary (:sc signed-reg :offset edx-offset :target rem @@ -568,7 +640,9 @@ (:generator 32 (move eax x) (inst cqo) - (inst mov y-arg y) + (if (typep y '(signed-byte 32)) + (inst mov y-arg y) + (setf y-arg (register-inline-constant :qword y))) (inst idiv eax y-arg) (move quo eax) (move rem edx))) @@ -1026,8 +1100,10 @@ (:note "inline fixnum comparison")) (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg control-stack))) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:args (x :scs (any-reg) + :load-if (or (not (typep y '(signed-byte 29))) + (not (sc-is x any-reg control-stack))))) + (:arg-types tagged-num (:constant fixnum)) (:info y)) (define-vop (fast-conditional/signed fast-conditional) @@ -1039,8 +1115,10 @@ (:note "inline (signed-byte 64) comparison")) (define-vop (fast-conditional-c/signed fast-conditional/signed) - (:args (x :scs (signed-reg signed-stack))) - (:arg-types signed-num (:constant (signed-byte 31))) + (:args (x :scs (signed-reg) + :load-if (or (not (typep y '(signed-byte 32))) + (not (sc-is x signed-reg signed-stack))))) + (:arg-types signed-num (:constant (signed-byte 64))) (:info y)) (define-vop (fast-conditional/unsigned fast-conditional) @@ -1052,8 +1130,10 @@ (:note "inline (unsigned-byte 64) comparison")) (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) - (:args (x :scs (unsigned-reg unsigned-stack))) - (:arg-types unsigned-num (:constant (unsigned-byte 31))) + (:args (x :scs (unsigned-reg) + :load-if (or (not (typep y '(unsigned-byte 31))) + (not (sc-is x unsigned-reg unsigned-stack))))) + (:arg-types unsigned-num (:constant (unsigned-byte 64))) (:info y)) (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned) @@ -1071,9 +1151,23 @@ (:conditional ,(if signed cond unsigned)) (:generator ,cost (inst cmp x - ,(if (eq suffix '-c/fixnum) - '(fixnumize y) - 'y))))) + ,(case suffix + (-c/fixnum + `(if (typep y '(signed-byte 29)) + (fixnumize y) + (register-inline-constant + :qword (fixnumize y)))) + (-c/signed + `(if (typep y '(signed-byte 32)) + y + (register-inline-constant + :qword y))) + (-c/unsigned + `(if (typep y '(unsigned-byte 31)) + y + (register-inline-constant + :qword y))) + (t 'y)))))) '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) ; '(/fixnum /signed /unsigned) '(4 3 6 5 6 5) @@ -1092,8 +1186,10 @@ (:generator 5 (cond ((and (sc-is x signed-reg) (zerop y)) (inst test x x)) ; smaller instruction + ((typep y '(signed-byte 32)) + (inst cmp x y)) (t - (inst cmp x y))))) + (inst cmp x (register-inline-constant :qword y)))))) (define-vop (fast-if-eql/unsigned fast-conditional/unsigned) (:translate eql) @@ -1105,8 +1201,10 @@ (:generator 5 (cond ((and (sc-is x unsigned-reg) (zerop y)) (inst test x x)) ; smaller instruction + ((typep y '(unsigned-byte 31)) + (inst cmp x y)) (t - (inst cmp x y))))) + (inst cmp x (register-inline-constant :qword y)))))) ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a ;;; known fixnum. @@ -1137,19 +1235,23 @@ (:variant-cost 7)) (define-vop (fast-eql-c/fixnum fast-conditional/fixnum) - (:args (x :scs (any-reg control-stack))) - (:arg-types tagged-num (:constant (signed-byte 29))) + (:args (x :scs (any-reg) + :load-if (or (not (typep y '(signed-byte 29))) + (not (sc-is x any-reg descriptor-reg control-stack))))) + (:arg-types tagged-num (:constant fixnum)) (:info y) (:translate eql) (:generator 2 - (cond ((and (sc-is x any-reg) (zerop y)) + (cond ((and (sc-is x any-reg descriptor-reg) (zerop y)) (inst test x x)) ; smaller instruction + ((typep y '(signed-byte 29)) + (inst cmp x (fixnumize y))) (t - (inst cmp x (fixnumize y)))))) + (inst cmp x (register-inline-constant :qword (fixnumize y))))))) (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) - (:args (x :scs (any-reg descriptor-reg control-stack))) - (:arg-types * (:constant (signed-byte 29))) + (:args (x :scs (any-reg descriptor-reg))) + (:arg-types * (:constant fixnum)) (:variant-cost 6)) ;;;; 32-bit logical operations @@ -1211,9 +1313,10 @@ (sc-is x signed-stack)) (or (sc-is r unsigned-stack) (sc-is r signed-stack)) - (location= x r))))) + (location= x r) + (typep y '(signed-byte 32)))))) (:info y) - (:arg-types untagged-num (:constant (or (unsigned-byte 31) (signed-byte 32)))) + (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64)))) (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0) :load-if (not (and (or (sc-is x unsigned-stack) (sc-is x signed-stack)) @@ -1247,8 +1350,7 @@ (define-vop (,svop61cf ,vopcf) (:translate ,sfun61)))))))) (def + t) (def - t) - ;; (no -C variant as x86 MUL instruction doesn't take an immediate) - (def * nil)) + (def * t)) (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index 286889a..40d6ade 100644 --- a/src/compiler/x86-64/float.lisp +++ b/src/compiler/x86-64/float.lisp @@ -91,6 +91,18 @@ ((single-reg complex-single-reg) (inst xorps y y)) ((double-reg complex-double-reg) (inst xorpd y y)))) +(define-move-fun (load-fp-immediate 1) (vop x y) + ((fp-single-immediate) (single-reg) + (fp-double-immediate) (double-reg) + (fp-complex-single-immediate) (complex-single-reg) + (fp-complex-double-immediate) (complex-double-reg)) + (let ((x (register-inline-constant (tn-value x)))) + (sc-case y + (single-reg (inst movss y x)) + (double-reg (inst movsd y x)) + (complex-single-reg (inst movq y x)) + (complex-double-reg (inst movapd y x))))) + (define-move-fun (load-single 2) (vop x y) ((single-stack) (single-reg)) (inst movss y (ea-for-sf-stack x))) @@ -325,57 +337,104 @@ (:vop-var vop) (:save-p :compute-only)) -(macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc) :target r) - (y :scs (,sc))) - (:results (r :scs (,sc))) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) - (frob single-float-op single-reg single-float) - (frob double-float-op double-reg double-float) - (frob complex-single-float-op complex-single-reg complex-single-float) - (frob complex-double-float-op complex-double-reg complex-double-float)) - -(macrolet ((generate (opinst commutative) +(macrolet ((frob (name comm-name sc constant-sc ptype) `(progn + (define-vop (,name float-op) + (:args (x :scs (,sc ,constant-sc) + :target r + :load-if (not (sc-is x ,constant-sc))) + (y :scs (,sc ,constant-sc) + :load-if (not (sc-is y ,constant-sc)))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)) + (define-vop (,comm-name float-op) + (:args (x :scs (,sc ,constant-sc) + :target r + :load-if (not (sc-is x ,constant-sc))) + (y :scs (,sc ,constant-sc) + :target r + :load-if (not (sc-is y ,constant-sc)))) + (:results (r :scs (,sc))) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype))))) + (frob single-float-op single-float-comm-op + single-reg fp-single-immediate single-float) + (frob double-float-op double-float-comm-op + double-reg fp-double-immediate double-float) + (frob complex-single-float-op complex-single-float-comm-op + complex-single-reg fp-complex-single-immediate + complex-single-float) + (frob complex-double-float-op complex-double-float-comm-op + complex-double-reg fp-complex-double-immediate + complex-double-float)) + +(macrolet ((generate (opinst commutative constant-sc load-inst) + `(flet ((get-constant (tn) + (register-inline-constant + ,@(and (eq constant-sc 'fp-single-immediate) + '(:aligned)) + (tn-value tn)))) + (declare (ignorable #'get-constant)) (cond ((location= x r) + (when (sc-is y ,constant-sc) + (setf y (get-constant y))) (inst ,opinst x y)) ((and ,commutative (location= y r)) + (when (sc-is x ,constant-sc) + (setf x (get-constant x))) (inst ,opinst y x)) ((not (location= r y)) - (move r x) + (if (sc-is x ,constant-sc) + (inst ,load-inst r (get-constant x)) + (move r x)) + (when (sc-is y ,constant-sc) + (setf y (get-constant y))) (inst ,opinst r y)) (t - (move tmp x) + (if (sc-is x ,constant-sc) + (inst ,load-inst r (get-constant x)) + (move tmp x)) (inst ,opinst tmp y) (move r tmp))))) (frob (op sinst sname scost dinst dname dcost commutative &optional csinst csname cscost cdinst cdname cdcost) `(progn - (define-vop (,sname single-float-op) - (:translate ,op) + (define-vop (,sname ,(if commutative + 'single-float-comm-op + 'single-float-op)) + (:translate ,op) (:temporary (:sc single-reg) tmp) (:generator ,scost - (generate ,sinst ,commutative))) - (define-vop (,dname double-float-op) + (generate ,sinst ,commutative fp-single-immediate movss))) + (define-vop (,dname ,(if commutative + 'double-float-comm-op + 'double-float-op)) (:translate ,op) (:temporary (:sc double-reg) tmp) (:generator ,dcost - (generate ,dinst ,commutative))) + (generate ,dinst ,commutative fp-double-immediate movsd))) ,(when csinst - `(define-vop (,csname complex-single-float-op) + `(define-vop (,csname + ,(if commutative + 'complex-single-float-comm-op + 'complex-single-float-op)) (:translate ,op) (:temporary (:sc complex-single-reg) tmp) (:generator ,cscost - (generate ,csinst ,commutative)))) + (generate ,csinst ,commutative + fp-complex-single-immediate movq)))) ,(when cdinst - `(define-vop (,cdname complex-double-float-op) + `(define-vop (,cdname + ,(if commutative + 'complex-double-float-comm-op + 'complex-double-float-op)) (:translate ,op) (:temporary (:sc complex-double-reg) tmp) (:generator ,cdcost - (generate ,cdinst ,commutative))))))) + (generate ,cdinst ,commutative + fp-complex-double-immediate movapd))))))) (frob + addss +/single-float 2 addsd +/double-float 2 t addps +/complex-single-float 3 addpd +/complex-double-float 3) (frob - subss -/single-float 2 subsd -/double-float 2 nil @@ -384,17 +443,29 @@ (frob / divss //single-float 12 divsd //double-float 19 nil)) (macrolet ((frob (op cost commutativep - duplicate-inst op-inst - real-sc real-type complex-sc complex-type + duplicate-inst op-inst real-move-inst complex-move-inst + real-sc real-constant-sc real-type + complex-sc complex-constant-sc complex-type real-complex-name complex-real-name) (cond ((not duplicate-inst) ; simple case - `(progn + `(flet ((load-into (r x) + (sc-case x + (,real-constant-sc + (inst ,real-move-inst r + (register-inline-constant (tn-value x)))) + (,complex-constant-sc + (inst ,complex-move-inst r + (register-inline-constant (tn-value x)))) + (t (move r x))))) ,(when real-complex-name `(define-vop (,real-complex-name float-op) (:translate ,op) - (:args (x :scs (,real-sc) :target r) - (y :scs (,complex-sc) - ,@(when commutativep '(:target r)))) + (:args (x :scs (,real-sc ,real-constant-sc) + :target r + :load-if (not (sc-is x ,real-constant-sc))) + (y :scs (,complex-sc ,complex-constant-sc) + ,@(when commutativep '(:target r)) + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,real-type ,complex-type) (:results (r :scs (,complex-sc) ,@(unless commutativep '(:from (:argument 0))))) @@ -403,15 +474,21 @@ ,(when commutativep `(when (location= y r) (rotatef x y))) - (move r x) + (load-into r x) + (when (sc-is y ,real-constant-sc ,complex-constant-sc) + (setf y (register-inline-constant + :aligned (tn-value y)))) (inst ,op-inst r y)))) ,(when complex-real-name `(define-vop (,complex-real-name float-op) (:translate ,op) - (:args (x :scs (,complex-sc) :target r) - (y :scs (,real-sc) - ,@(when commutativep '(:target r)))) + (:args (x :scs (,complex-sc ,complex-constant-sc) + :target r + :load-if (not (sc-is x ,complex-constant-sc))) + (y :scs (,real-sc ,real-constant-sc) + ,@(when commutativep '(:target r)) + :load-if (not (sc-is y ,real-constant-sc)))) (:arg-types ,complex-type ,real-type) (:results (r :scs (,complex-sc) ,@(unless commutativep '(:from (:argument 0))))) @@ -420,16 +497,23 @@ ,(when commutativep `(when (location= y r) (rotatef x y))) - (move r x) + (load-into r x) + (when (sc-is y ,real-constant-sc ,complex-constant-sc) + (setf y (register-inline-constant + :aligned (tn-value y)))) (inst ,op-inst r y)))))) (commutativep ; must duplicate, but commutative `(progn ,(when real-complex-name `(define-vop (,real-complex-name float-op) (:translate ,op) - (:args (x :scs (,real-sc) :target dup) - (y :scs (,complex-sc) :target r - :to :result)) + (:args (x :scs (,real-sc ,real-constant-sc) + :target dup + :load-if (not (sc-is x ,real-constant-sc))) + (y :scs (,complex-sc ,complex-constant-sc) + :target r + :to :result + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,real-type ,complex-type) (:temporary (:sc ,complex-sc :target r :from (:argument 0) @@ -438,20 +522,34 @@ (:results (r :scs (,complex-sc))) (:result-types ,complex-type) (:generator ,cost - (let ((real x)) - ,duplicate-inst) + (if (sc-is x ,real-constant-sc) + (inst ,complex-move-inst dup + (register-inline-constant + (complex (tn-value x) (tn-value x)))) + (let ((real x)) + ,duplicate-inst)) ;; safe: dup /= y (when (location= dup r) (rotatef dup y)) - (move r y) + (if (sc-is y ,complex-constant-sc) + (inst ,complex-move-inst r + (register-inline-constant (tn-value y))) + (move r y)) + (when (sc-is dup ,complex-constant-sc) + (setf dup (register-inline-constant + :aligned (tn-value dup)))) (inst ,op-inst r dup)))) ,(when complex-real-name `(define-vop (,complex-real-name float-op) (:translate ,op) - (:args (x :scs (,complex-sc) :target r - :to :result) - (y :scs (,real-sc) :target dup)) + (:args (x :scs (,complex-sc ,complex-constant-sc) + :target r + :to :result + :load-if (not (sc-is x ,complex-constant-sc))) + (y :scs (,real-sc ,real-constant-sc) + :target dup + :load-if (not (sc-is y ,real-constant-sc)))) (:arg-types ,complex-type ,real-type) (:temporary (:sc ,complex-sc :target r :from (:argument 1) @@ -460,43 +558,70 @@ (:results (r :scs (,complex-sc))) (:result-types ,complex-type) (:generator ,cost - (let ((real y)) - ,duplicate-inst) + (if (sc-is y ,real-constant-sc) + (inst ,complex-move-inst dup + (register-inline-constant + (complex (tn-value y) (tn-value y)))) + (let ((real y)) + ,duplicate-inst)) (when (location= dup r) (rotatef x dup)) - (move r x) + (if (sc-is x ,complex-constant-sc) + (inst ,complex-move-inst r + (register-inline-constant (tn-value x))) + (move r x)) + (when (sc-is dup ,complex-constant-sc) + (setf dup (register-inline-constant + :aligned (tn-value dup)))) (inst ,op-inst r dup)))))) (t ; duplicate, not commutative `(progn ,(when real-complex-name `(define-vop (,real-complex-name float-op) (:translate ,op) - (:args (x :scs (,real-sc) - :target r) - (y :scs (,complex-sc) :to :result)) + (:args (x :scs (,real-sc ,real-constant-sc) + :target r + :load-if (not (sc-is x ,real-constant-sc))) + (y :scs (,complex-sc ,complex-constant-sc) + :to :result + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,real-type ,complex-type) (:results (r :scs (,complex-sc) :from (:argument 0))) (:result-types ,complex-type) (:generator ,cost - (let ((real x) - (dup r)) - ,duplicate-inst) + (if (sc-is x ,real-constant-sc) + (inst ,complex-move-inst dup + (register-inline-constant + (complex (tn-value x) (tn-value x)))) + (let ((real x) + (dup r)) + ,duplicate-inst)) + (when (sc-is y ,complex-constant-sc) + (setf y (register-inline-constant + :aligned (tn-value y)))) (inst ,op-inst r y)))) ,(when complex-real-name `(define-vop (,complex-real-name float-op) (:translate ,op) - (:args (x :scs (,complex-sc) :target r + (:args (x :scs (,complex-sc) + :target r :to :eval) - (y :scs (,real-sc) :target dup)) + (y :scs (,real-sc ,real-constant-sc) + :target dup + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,complex-type ,real-type) (:temporary (:sc ,complex-sc :from (:argument 1)) dup) (:results (r :scs (,complex-sc) :from :eval)) (:result-types ,complex-type) (:generator ,cost - (let ((real y)) - ,duplicate-inst) + (if (sc-is y ,real-constant-sc) + (setf dup (register-inline-constant + :aligned (complex (tn-value y) + (tn-value y)))) + (let ((real y)) + ,duplicate-inst)) (move r x) (inst ,op-inst r dup)))))))) (def-real-complex-op (op commutativep duplicatep @@ -508,16 +633,18 @@ `(progn (move dup real) (inst unpcklps dup dup))) - ,single-inst - single-reg single-float complex-single-reg complex-single-float + ,single-inst movss movaps + single-reg fp-single-immediate single-float + complex-single-reg fp-complex-single-immediate complex-single-float ,single-real-complex-name ,single-complex-real-name) (frob ,op ,double-cost ,commutativep ,(and duplicatep `(progn (move dup real) (inst unpcklpd dup dup))) - ,double-inst - double-reg double-float complex-double-reg complex-double-float + ,double-inst movsd movapd + double-reg fp-double-immediate double-float + complex-double-reg fp-complex-double-immediate complex-double-float ,double-real-complex-name ,double-complex-real-name)))) (def-real-complex-op + t nil addps +/real-complex-single-float +/complex-real-single-float 3 @@ -534,21 +661,41 @@ (define-vop (//complex-real-single-float float-op) (:translate /) - (:args (x :scs (complex-single-reg) + (:args (x :scs (complex-single-reg fp-complex-single-immediate fp-complex-single-zero) :to (:result 0) - :target r) - (y :scs (single-reg) :target dup)) + :target r + :load-if (not (sc-is x fp-complex-single-immediate fp-complex-single-zero))) + (y :scs (single-reg fp-single-immediate fp-single-zero) + :target dup + :load-if (not (sc-is y fp-single-immediate fp-single-zero)))) (:arg-types complex-single-float single-float) (:temporary (:sc complex-single-reg :from (:argument 1)) dup) (:results (r :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 12 - (move dup y) - (inst shufps dup dup #b00000000) - (move r x) - (inst unpcklpd r r) - (inst divps r dup) - (inst movq r r))) + (flet ((duplicate (x) + (let ((word (ldb (byte 64 0) + (logior (ash (single-float-bits (imagpart x)) 32) + (ldb (byte 32 0) + (single-float-bits (realpart x))))))) + (register-inline-constant :oword (logior (ash word 64) word))))) + (sc-case y + (fp-single-immediate + (setf dup (duplicate (complex (tn-value y) (tn-value y))))) + (fp-single-zero + (inst xorps dup dup)) + (t (move dup y) + (inst shufps dup dup #b00000000))) + (sc-case x + (fp-complex-single-immediate + (inst movaps r (duplicate (tn-value x)))) + (fp-complex-single-zero + (inst xorps r r)) + (t + (move r x) + (inst unpcklpd r r))) + (inst divps r dup) + (inst movq r r)))) ;; Complex multiplication ;; r := rx * ry - ix * iy @@ -562,16 +709,16 @@ ;;+ [ix ix] * [-iy ry] ;; [r i] -(macrolet ((define-complex-* (name cost type sc &body body) +(macrolet ((define-complex-* (name cost type sc tmp-p &body body) `(define-vop (,name float-op) (:translate *) (:args (x :scs (,sc) :target r) (y :scs (,sc) :target copy-y)) (:arg-types ,type ,type) - (:temporary (:sc any-reg) hex8) (:temporary (:sc ,sc) imag) (:temporary (:sc ,sc :from :eval) copy-y) - (:temporary (:sc ,sc) xmm) + ,@(when tmp-p + `((:temporary (:sc ,sc) xmm))) (:results (r :scs (,sc) :from :eval)) (:result-types ,type) (:generator ,cost @@ -579,7 +726,8 @@ (location= y r)) (rotatef x y)) ,@body)))) - (define-complex-* */complex-single-float 20 complex-single-float complex-single-reg + (define-complex-* */complex-single-float 20 + complex-single-float complex-single-reg t (inst xorps xmm xmm) (move r x) (inst unpcklps r r) @@ -589,32 +737,26 @@ (move copy-y y) ; y == r only if y == x == r (setf y copy-y) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst rol hex8 31) - (inst movd xmm hex8) - (inst mulps r y) (inst shufps y y #b11110001) - (inst xorps y xmm) + (inst xorps y (register-inline-constant :oword (ash 1 31))) (inst mulps imag y) (inst addps r imag)) - (define-complex-* */complex-double-float 25 complex-double-float complex-double-reg + (define-complex-* */complex-double-float 25 + complex-double-float complex-double-reg nil (move imag x) (move r x) (move copy-y y) (setf y copy-y) (inst unpcklpd r r) (inst unpckhpd imag imag) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst ror hex8 1) ; #x8000000000000000 - (inst movd xmm hex8) (inst mulpd r y) (inst shufpd y y #b01) - (inst xorpd y xmm) + (inst xorpd y (register-inline-constant :oword (ash 1 63))) (inst mulpd imag y) (inst addpd r imag))) @@ -635,15 +777,12 @@ (macrolet ((frob ((name translate sc type) &body body) `(define-vop (,name) - (:args (x :scs (,sc))) + (:args (x :scs (,sc) :target y)) (:results (y :scs (,sc))) (:translate ,translate) (:policy :fast-safe) (:arg-types ,type) (:result-types ,type) - (:temporary (:sc any-reg) hex8) - (:temporary - (:sc ,sc) xmm) (:note "inline float arithmetic") (:vop-var vop) (:save-p :compute-only) @@ -655,48 +794,23 @@ (move y x) ,@body)))) (frob (%negate/double-float %negate double-reg double-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst ror hex8 1) ; #x8000000000000000 - (inst movd xmm hex8) - (inst xorpd y xmm)) + (inst xorpd y (register-inline-constant :oword (ash 1 63)))) (frob (%negate/complex-double-float %negate complex-double-reg complex-double-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst ror hex8 1) ; #x8000000000000000 - (inst movd xmm hex8) - (inst unpcklpd xmm xmm) - (inst xorpd y xmm)) + (inst xorpd y (register-inline-constant + :oword (logior (ash 1 127) (ash 1 63))))) (frob (conjugate/complex-double-float conjugate complex-double-reg complex-double-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst ror hex8 1) ; #x8000000000000000 - (inst movd xmm hex8) - (inst shufpd xmm xmm #b01) - (inst xorpd y xmm)) + (inst xorpd y (register-inline-constant :oword (ash 1 127)))) (frob (%negate/single-float %negate single-reg single-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst rol hex8 31) - (inst movd xmm hex8) - (inst xorps y xmm)) + (inst xorps y (register-inline-constant :oword (ash 1 31)))) (frob (%negate/complex-single-float %negate complex-single-reg complex-single-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst rol hex8 31) - (inst movd xmm hex8) - (inst unpcklps xmm xmm) - (inst xorps y xmm)) + (inst xorps y (register-inline-constant + :oword (logior (ash 1 31) (ash 1 63))))) (frob (conjugate/complex-single-float conjugate complex-single-reg complex-single-float) - (inst lea hex8 (make-ea :qword :disp 1)) - (inst ror hex8 1) ; #x8000000000000000 - (inst movd xmm hex8) - (inst xorpd y xmm)) + (inst xorpd y (register-inline-constant :oword (ash 1 63)))) (frob (abs/double-float abs double-reg double-float) - (inst mov hex8 -1) - (inst shr hex8 1) - (inst movd xmm hex8) - (inst andpd y xmm)) + (inst andpd y (register-inline-constant :oword (ldb (byte 63 0) -1)))) (frob (abs/single-float abs single-reg single-float) - (inst mov hex8 -1) - (inst shr hex8 33) - (inst movd xmm hex8) - (inst andps y xmm))) + (inst andps y (register-inline-constant :oword (ldb (byte 31 0) -1))))) ;;;; comparison @@ -708,71 +822,139 @@ (:note "inline float comparison")) ;;; EQL -(macrolet ((define-float-eql (name cost sc type) +(macrolet ((define-float-eql (name cost sc constant-sc type) `(define-vop (,name float-compare) (:translate eql) - (:args (x :scs (,sc) :target mask) - (y :scs (,sc) :target mask)) + (:args (x :scs (,sc ,constant-sc) + :target mask + :load-if (not (sc-is x ,constant-sc))) + (y :scs (,sc ,constant-sc) + :target mask + :load-if (not (sc-is x ,constant-sc)))) (:arg-types ,type ,type) (:temporary (:sc ,sc :from :eval) mask) (:temporary (:sc any-reg) bits) (:conditional :e) (:generator ,cost - (when (location= y mask) + (when (or (location= y mask) + (not (xmm-register-p x))) (rotatef x y)) + (aver (xmm-register-p x)) (move mask x) + (when (sc-is y ,constant-sc) + (setf y (register-inline-constant :aligned (tn-value y)))) (inst pcmpeqd mask y) (inst movmskps bits mask) (inst cmp bits #b1111))))) (define-float-eql eql/single-float 4 - single-reg single-float) + single-reg fp-single-immediate single-float) (define-float-eql eql/double-float 4 - double-reg double-float) - (define-float-eql eql/complex-double-float 5 - complex-double-reg complex-double-float) + double-reg fp-double-immediate double-float) (define-float-eql eql/complex-single-float 5 - complex-single-reg complex-single-float)) + complex-single-reg fp-complex-single-immediate complex-single-float) + (define-float-eql eql/complex-double-float 5 + complex-double-reg fp-complex-double-immediate complex-double-float)) ;;; comiss and comisd can cope with one or other arg in memory: we ;;; could (should, indeed) extend these to cope with descriptor args ;;; and stack args (define-vop (single-float-compare float-compare) - (:args (x :scs (single-reg)) (y :scs (single-reg))) + (:args (x :scs (single-reg)) + (y :scs (single-reg single-stack fp-single-immediate) + :load-if (not (sc-is y single-stack fp-single-immediate)))) (:arg-types single-float single-float)) (define-vop (double-float-compare float-compare) - (:args (x :scs (double-reg)) (y :scs (double-reg))) + (:args (x :scs (double-reg)) + (y :scs (double-reg double-stack descriptor-reg fp-double-immediate) + :load-if (not (sc-is y double-stack descriptor-reg fp-double-immediate)))) (:arg-types double-float double-float)) (define-vop (=/single-float single-float-compare) (:translate =) + (:args (x :scs (single-reg single-stack fp-single-immediate) + :target xmm + :load-if (not (sc-is x single-stack fp-single-immediate))) + (y :scs (single-reg single-stack fp-single-immediate) + :target xmm + :load-if (not (sc-is y single-stack fp-single-immediate)))) + (:temporary (:sc single-reg :from :eval) xmm) (:info) (:conditional not :p :ne) (:vop-var vop) (:generator 3 + (when (or (location= y xmm) + (and (not (xmm-register-p x)) + (xmm-register-p y))) + (rotatef x y)) + (sc-case x + (single-reg (setf xmm x)) + (single-stack (inst movss xmm (ea-for-sf-stack x))) + (fp-single-immediate + (inst movss xmm (register-inline-constant (tn-value x))))) + (sc-case y + (single-stack + (setf y (ea-for-sf-stack y))) + (fp-single-immediate + (setf y (register-inline-constant (tn-value y)))) + (t)) (note-this-location vop :internal-error) - (inst comiss x y) + (inst comiss xmm y) ;; if PF&CF, there was a NaN involved => not equal ;; otherwise, ZF => equal )) (define-vop (=/double-float double-float-compare) (:translate =) + (:args (x :scs (double-reg double-stack fp-double-immediate descriptor-reg) + :target xmm + :load-if (not (sc-is x double-stack fp-double-immediate descriptor-reg))) + (y :scs (double-reg double-stack fp-double-immediate descriptor-reg) + :target xmm + :load-if (not (sc-is y double-stack fp-double-immediate descriptor-reg)))) + (:temporary (:sc double-reg :from :eval) xmm) (:info) (:conditional not :p :ne) (:vop-var vop) (:generator 3 + (when (or (location= y xmm) + (and (not (xmm-register-p x)) + (xmm-register-p y))) + (rotatef x y)) + (sc-case x + (double-reg + (setf xmm x)) + (double-stack + (inst movsd xmm (ea-for-df-stack x))) + (fp-double-immediate + (inst movsd xmm (register-inline-constant (tn-value x)))) + (descriptor-reg + (inst movsd xmm (ea-for-df-desc x)))) + (sc-case y + (double-stack + (setf y (ea-for-df-stack y))) + (fp-double-immediate + (setf y (register-inline-constant (tn-value y)))) + (descriptor-reg + (setf y (ea-for-df-desc y))) + (t)) (note-this-location vop :internal-error) - (inst comisd x y))) + (inst comisd xmm y))) (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name - real-sc real-type complex-sc complex-type + real-sc real-constant-sc real-type + complex-sc complex-constant-sc complex-type + real-move-inst complex-move-inst cmp-inst mask-inst mask) `(progn (define-vop (,complex-complex-name float-compare) (:translate =) - (:args (x :scs (,complex-sc) :target cmp) - (y :scs (,complex-sc) :target cmp)) + (:args (x :scs (,complex-sc ,complex-constant-sc) + :target cmp + :load-if (not (sc-is x ,complex-constant-sc))) + (y :scs (,complex-sc ,complex-constant-sc) + :target cmp + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,complex-type ,complex-type) (:temporary (:sc ,complex-sc :from :eval) cmp) (:temporary (:sc unsigned-reg) bits) @@ -781,54 +963,76 @@ (:generator 3 (when (location= y cmp) (rotatef x y)) - (move cmp x) + (sc-case x + (,real-constant-sc + (inst ,real-move-inst cmp (register-inline-constant + (tn-value x)))) + (,complex-constant-sc + (inst ,complex-move-inst cmp (register-inline-constant + (tn-value x)))) + (t + (move cmp x))) + (when (sc-is y ,real-constant-sc ,complex-constant-sc) + (setf y (register-inline-constant :aligned (tn-value y)))) (note-this-location vop :internal-error) (inst ,cmp-inst :eq cmp y) (inst ,mask-inst bits cmp) (inst cmp bits ,mask))) (define-vop (,complex-real-name ,complex-complex-name) - (:args (x :scs (,complex-sc) :target cmp) - (y :scs (,real-sc) :target cmp)) + (:args (x :scs (,complex-sc ,complex-constant-sc) + :target cmp + :load-if (not (sc-is x ,complex-constant-sc))) + (y :scs (,real-sc ,real-constant-sc) + :target cmp + :load-if (not (sc-is y ,real-constant-sc)))) (:arg-types ,complex-type ,real-type)) (define-vop (,real-complex-name ,complex-complex-name) - (:args (x :scs (,real-sc) :target cmp) - (y :scs (,complex-sc) :target cmp)) + (:args (x :scs (,real-sc ,real-constant-sc) + :target cmp + :load-if (not (sc-is x ,real-constant-sc))) + (y :scs (,complex-sc ,complex-constant-sc) + :target cmp + :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,real-type ,complex-type))))) (define-complex-float-= =/complex-single-float =/complex-real-single-float =/real-complex-single-float - single-reg single-float complex-single-reg complex-single-float - cmpps movmskps #b1111) + single-reg fp-single-immediate single-float + complex-single-reg fp-complex-single-immediate complex-single-float + movss movq cmpps movmskps #b1111) (define-complex-float-= =/complex-double-float =/complex-real-double-float =/real-complex-double-float - double-reg double-float complex-double-reg complex-double-float - cmppd movmskpd #b11)) - -(define-vop (double-float double-float-compare) - (:translate >) - (:info) - (:conditional not :p :na) - (:generator 3 - (inst comisd x y))) - -(define-vop (>single-float single-float-compare) - (:translate >) - (:info) - (:conditional not :p :na) - (:generator 3 - (inst comiss x y))) + double-reg fp-double-immediate double-float + complex-double-reg fp-complex-double-immediate complex-double-float + movsd movapd cmppd movmskpd #b11)) +(macrolet ((define- (op single-name double-name &rest flags) + `(progn + (define-vop (,double-name double-float-compare) + (:translate ,op) + (:info) + (:conditional ,@flags) + (:generator 3 + (sc-case y + (double-stack + (setf y (ea-for-df-stack y))) + (descriptor-reg + (setf y (ea-for-df-desc y))) + (fp-double-immediate + (setf y (register-inline-constant (tn-value y)))) + (t)) + (inst comisd x y))) + (define-vop (,single-name single-float-compare) + (:translate ,op) + (:info) + (:conditional ,@flags) + (:generator 3 + (sc-case y + (single-stack + (setf y (ea-for-sf-stack y))) + (fp-single-immediate + (setf y (register-inline-constant (tn-value y)))) + (t)) + (inst comiss x y)))))) + (define- < > >single-float >double-float not :p :na)) ;;;; conversion diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 1f3cc0b..28ac794 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/src/compiler/x86-64/insts.lisp @@ -1460,6 +1460,11 @@ (r/m (cond (index #b100) ((null base) #b101) (t (reg-tn-encoding base))))) + (when (and (fixup-p disp) + (label-p (fixup-offset disp))) + (aver (null base)) + (aver (null index)) + (return-from emit-ea (emit-ea segment disp reg allow-constants))) (when (and (= mod 0) (= r/m #b101)) ;; this is rip-relative in amd64, so we'll use a sib instead (setf r/m #b100 scale 1)) @@ -3537,3 +3542,91 @@ (:emitter (emit-byte segment #b00001111) (emit-byte segment #b00110001))) + +;;;; Late VM definitions + +(defun canonicalize-inline-constant (constant &aux (alignedp nil)) + (let ((first (car constant))) + (when (eql first :aligned) + (setf alignedp t) + (pop constant) + (setf first (car constant))) + (typecase first + (single-float (setf constant (list :single-float first))) + (double-float (setf constant (list :double-float first))) + ((complex single-float) + (setf constant (list :complex-single-float first))) + ((complex double-float) + (setf constant (list :complex-double-float first))))) + (destructuring-bind (type value) constant + (ecase type + ((:byte :word :dword :qword) + (aver (integerp value)) + (cons type value)) + ((:base-char) + (aver (base-char-p value)) + (cons :byte (char-code value))) + ((:character) + (aver (characterp value)) + (cons :dword (char-code value))) + ((:single-float) + (aver (typep value 'single-float)) + (cons (if alignedp :oword :dword) + (ldb (byte 32 0) (single-float-bits value)))) + ((:double-float) + (aver (typep value 'double-float)) + (cons (if alignedp :oword :qword) + (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32) + (double-float-low-bits value))))) + ((:complex-single-float) + (aver (typep value '(complex single-float))) + (cons (if alignedp :oword :qword) + (ldb (byte 64 0) + (logior (ash (single-float-bits (imagpart value)) 32) + (ldb (byte 32 0) + (single-float-bits (realpart value))))))) + ((:oword :sse) + (aver (integerp value)) + (cons :oword value)) + ((:complex-double-float) + (aver (typep value '(complex double-float))) + (cons :oword + (logior (ash (double-float-high-bits (imagpart value)) 96) + (ash (double-float-low-bits (imagpart value)) 64) + (ash (ldb (byte 32 0) + (double-float-high-bits (realpart value))) + 32) + (double-float-low-bits (realpart value)))))))) + +(defun inline-constant-value (constant) + (let ((label (gen-label)) + (size (ecase (car constant) + ((:byte :word :dword :qword) (car constant)) + ((:oword) :qword)))) + (values label (make-ea size + :disp (make-fixup nil :code-object label))))) + +(defun emit-constant-segment-header (constants optimize) + (declare (ignore constants)) + (loop repeat (if optimize 64 16) do (inst byte #x90))) + +(defun size-nbyte (size) + (ecase size + (:byte 1) + (:word 2) + (:dword 4) + (:qword 8) + (:oword 16))) + +(defun sort-inline-constants (constants) + (stable-sort constants #'> :key (lambda (constant) + (size-nbyte (caar constant))))) + +(defun emit-inline-constant (constant label) + (let ((size (size-nbyte (car constant)))) + (emit-alignment (integer-length (1- size))) + (emit-label label) + (let ((val (cdr constant))) + (loop repeat size + do (inst byte (ldb (byte 8 0) val)) + (setf val (ash val -8)))))) diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp index 78c2df3..ce60198 100644 --- a/src/compiler/x86-64/vm.lisp +++ b/src/compiler/x86-64/vm.lisp @@ -220,6 +220,11 @@ (fp-complex-single-zero immediate-constant) (fp-complex-double-zero immediate-constant) + (fp-single-immediate immediate-constant) + (fp-double-immediate immediate-constant) + (fp-complex-single-immediate immediate-constant) + (fp-complex-double-immediate immediate-constant) + (immediate immediate-constant) ;; @@ -328,26 +333,26 @@ ;; non-descriptor SINGLE-FLOATs (single-reg float-registers :locations #.*float-regs* - :constant-scs (fp-single-zero) + :constant-scs (fp-single-zero fp-single-immediate) :save-p t :alternate-scs (single-stack)) ;; non-descriptor DOUBLE-FLOATs (double-reg float-registers :locations #.*float-regs* - :constant-scs (fp-double-zero) + :constant-scs (fp-double-zero fp-double-immediate) :save-p t :alternate-scs (double-stack)) (complex-single-reg float-registers :locations #.*float-regs* - :constant-scs (fp-complex-single-zero) + :constant-scs (fp-complex-single-zero fp-complex-single-immediate) :save-p t :alternate-scs (complex-single-stack)) (complex-double-reg float-registers :locations #.*float-regs* - :constant-scs (fp-complex-double-zero) + :constant-scs (fp-complex-double-zero fp-complex-double-immediate) :save-p t :alternate-scs (complex-double-stack)) @@ -426,21 +431,21 @@ (when (static-symbol-p value) (sc-number-or-lose 'immediate))) (single-float - (if (eql value 0f0) - (sc-number-or-lose 'fp-single-zero ) - nil)) + (sc-number-or-lose + (if (eql value 0f0) 'fp-single-zero 'fp-single-immediate))) (double-float - (if (eql value 0d0) - (sc-number-or-lose 'fp-double-zero ) - nil)) + (sc-number-or-lose + (if (eql value 0d0) 'fp-double-zero 'fp-double-immediate))) ((complex single-float) - (if (eql value (complex 0f0 0f0)) - (sc-number-or-lose 'fp-complex-single-zero) - nil)) + (sc-number-or-lose + (if (eql value #c(0f0 0f0)) + 'fp-complex-single-zero + 'fp-complex-single-immediate))) ((complex double-float) - (if (eql value (complex 0d0 0d0)) - (sc-number-or-lose 'fp-complex-double-zero) - nil)))) + (sc-number-or-lose + (if (eql value #c(0d0 0d0)) + 'fp-complex-double-zero + 'fp-complex-double-immediate))))) ;;;; miscellaneous function call parameters diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index c20baef..bde111a 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -187,7 +187,7 @@ #!+long-float 'long-float #!-long-float 'double-float)) (define-move-fun (load-fp-constant 2) (vop x y) ((fp-constant) (single-reg double-reg #!+long-float long-reg)) - (let ((value (sb!c::constant-value (sb!c::tn-leaf x)))) + (let ((value (tn-value x))) (with-empty-tn@fp-top(y) (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0)) (inst fldz)) @@ -209,6 +209,17 @@ ((= value (log 2e0 2.718281828459045235360287471352662e0)) (inst fldln2)) (t (warn "ignoring bogus i387 constant ~A" value)))))) + +(define-move-fun (load-fp-immediate 2) (vop x y) + ((fp-single-immediate) (single-reg) + (fp-double-immediate) (double-reg)) + (let ((value (register-inline-constant (tn-value x)))) + (with-empty-tn@fp-top(y) + (sc-case y + (single-reg + (inst fld value)) + (double-reg + (inst fldd value)))))) (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index 794c90d..6ed33ad 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -922,6 +922,11 @@ (r/m (cond (index #b100) ((null base) #b101) (t (reg-tn-encoding base))))) + (when (and (fixup-p disp) + (label-p (fixup-offset disp))) + (aver (null base)) + (aver (null index)) + (return-from emit-ea (emit-ea segment disp reg allow-constants))) (emit-mod-reg-r/m-byte segment mod reg r/m) (when (= r/m #b100) (let ((ss (1- (integer-length scale))) @@ -2990,3 +2995,61 @@ (:emitter (emit-byte segment #b00001111) (emit-byte segment #b00110001))) + +;;;; Late VM definitions +(defun canonicalize-inline-constant (constant) + (let ((first (car constant))) + (typecase first + (single-float (setf constant (list :single-float first))) + (double-float (setf constant (list :double-float first))))) + (destructuring-bind (type value) constant + (ecase type + ((:byte :word :dword) + (aver (integerp value)) + (cons type value)) + ((:base-char) + (aver (base-char-p value)) + (cons :byte (char-code value))) + ((:character) + (aver (characterp value)) + (cons :dword (char-code value))) + ((:single-float) + (aver (typep value 'single-float)) + (cons :dword (ldb (byte 32 0) (single-float-bits value)))) + ((:double-float) + (aver (typep value 'double-float)) + (cons :double-float + (ldb (byte 64 0) (logior (ash (double-float-high-bits value) 32) + (double-float-low-bits value)))))))) + +(defun inline-constant-value (constant) + (let ((label (gen-label)) + (size (ecase (car constant) + ((:byte :word :dword) (car constant)) + (:double-float :dword)))) + (values label (make-ea size + :disp (make-fixup nil :code-object label))))) + +(defun emit-constant-segment-header (constants optimize) + (declare (ignore constants)) + (loop repeat (if optimize 64 16) do (inst byte #x90))) + +(defun size-nbyte (size) + (ecase size + (:byte 1) + (:word 2) + (:dword 4) + (:double-float 8))) + +(defun sort-inline-constants (constants) + (stable-sort constants #'> :key (lambda (constant) + (size-nbyte (caar constant))))) + +(defun emit-inline-constant (constant label) + (let ((size (size-nbyte (car constant)))) + (emit-alignment (integer-length (1- size))) + (emit-label label) + (let ((val (cdr constant))) + (loop repeat size + do (inst byte (ldb (byte 8 0) val)) + (setf val (ash val -8)))))) diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 5313dc3..ae0b111 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -170,7 +170,8 @@ ;; some FP constants can be generated in the i387 silicon (fp-constant immediate-constant) - + (fp-single-immediate immediate-constant) + (fp-double-immediate immediate-constant) (immediate immediate-constant) ;; @@ -282,14 +283,14 @@ ;; non-descriptor SINGLE-FLOATs (single-reg float-registers :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) + :constant-scs (fp-constant fp-single-immediate) :save-p t :alternate-scs (single-stack)) ;; non-descriptor DOUBLE-FLOATs (double-reg float-registers :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) + :constant-scs (fp-constant fp-double-immediate) :save-p t :alternate-scs (double-stack)) @@ -390,20 +391,22 @@ (when (static-symbol-p value) (sc-number-or-lose 'immediate))) (single-float - (when (or (eql value 0f0) (eql value 1f0)) - (sc-number-or-lose 'fp-constant))) + (case value + ((0f0 1f0) (sc-number-or-lose 'fp-constant)) + (t (sc-number-or-lose 'fp-single-immediate)))) (double-float - (when (or (eql value 0d0) (eql value 1d0)) - (sc-number-or-lose 'fp-constant))) + (case value + ((0d0 1d0) (sc-number-or-lose 'fp-constant)) + (t (sc-number-or-lose 'fp-double-immediate)))) #!+long-float (long-float - (when (or (eql value 0l0) (eql value 1l0) - (eql value pi) - (eql value (log 10l0 2l0)) - (eql value (log 2.718281828459045235360287471352662L0 2l0)) - (eql value (log 2l0 10l0)) - (eql value (log 2l0 2.718281828459045235360287471352662L0))) - (sc-number-or-lose 'fp-constant))))) + (when (or (eql value 0l0) (eql value 1l0) + (eql value pi) + (eql value (log 10l0 2l0)) + (eql value (log 2.718281828459045235360287471352662L0 2l0)) + (eql value (log 2l0 10l0)) + (eql value (log 2l0 2.718281828459045235360287471352662L0))) + (sc-number-or-lose 'fp-constant))))) ;; For an immediate TN, return its value encoded for use as a literal. ;; For any other TN, return the TN. Only works for FIXNUMs, diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index aa39251..af1932c 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -294,3 +294,68 @@ ;; 1.0 had a broken ATANH on win32 (with-test (:name :atanh) (assert (= (atanh 0.9d0) 1.4722194895832204d0))) + +;; Test some cases of integer operations with constant arguments +(with-test (:name :constant-integers) + (labels ((test-forms (op x y header &rest forms) + (let ((val (funcall op x y))) + (dolist (form forms) + (let ((new-val (funcall (compile nil (append header form)) x y))) + (unless (eql val new-val) + (error "~S /= ~S: ~S ~S ~S~%" val new-val (append header form) x y)))))) + (test-case (op x y type) + (test-forms op x y `(lambda (x y &aux z) + (declare (type ,type x y) + (ignorable x y z) + (notinline identity) + (optimize speed (safety 0)))) + `((,op x ,y)) + `((setf z (,op x ,y)) + (identity x) + z) + `((values (,op x ,y) x)) + `((,op ,x y)) + `((setf z (,op ,x y)) + (identity y) + z) + `((values (,op ,x y) y)) + + `((identity x) + (,op x ,y)) + `((identity x) + (setf z (,op x ,y)) + (identity x) + z) + `((identity x) + (values (,op x ,y) x)) + `((identity y) + (,op ,x y)) + `((identity y) + (setf z (,op ,x y)) + (identity y) + z) + `((identity y) + (values (,op ,x y) y)))) + (test-op (op) + (let ((ub `(unsigned-byte ,sb-vm:n-word-bits)) + (sb `(signed-byte ,sb-vm:n-word-bits))) + (loop for (x y type) in `((2 1 fixnum) + (2 1 ,ub) + (2 1 ,sb) + (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum) + (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub) + (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb) + ,@(when (> sb-vm:n-word-bits 32) + `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum) + (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub) + (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb) + (,(ash 1 40) ,(ash 1 39) fixnum) + (,(ash 1 40) ,(ash 1 39) ,ub) + (,(ash 1 40) ,(ash 1 39) ,sb)))) + do + (test-case op x y type) + (test-case op x x type))))) + (mapc #'test-op '(+ - * truncate + < <= = >= > + eql + eq)))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 6795171..a4bc1f4 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1818,7 +1818,7 @@ ;;; check that non-trivial constants are EQ across different files: this is ;;; not something ANSI either guarantees or requires, but we want to do it ;;; anyways. -(defconstant +share-me-1+ 123.456d0) +(defconstant +share-me-1+ #-inline-constants 123.456d0 #+inline-constants nil) (defconstant +share-me-2+ "a string to share") (defconstant +share-me-3+ (vector 1 2 3)) (defconstant +share-me-4+ (* 2 most-positive-fixnum)) @@ -1826,12 +1826,12 @@ +share-me-2+ +share-me-3+ +share-me-4+ - pi))) + #-inline-constants pi))) (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+ +share-me-2+ +share-me-3+ +share-me-4+ - pi))) + #-inline-constants pi))) (flet ((test (fa fb) (mapc (lambda (a b) (assert (eq a b))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 521e0a4..4c1bf57 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -538,9 +538,11 @@ (assert-no-consing (make-array-on-stack-4)) (assert-no-consing (make-array-on-stack-5)) (assert-no-consing (vector-on-stack :x :y))) - (#+raw-instance-init-vops assert-no-consing - #-raw-instance-init-vops progn - (make-foo2-on-stack 1.24 1.23d0)) + (let (a b) + (setf a 1.24 b 1.23d0) + (#+raw-instance-init-vops assert-no-consing + #-raw-instance-init-vops progn + (make-foo2-on-stack a b))) (#+raw-instance-init-vops assert-no-consing #-raw-instance-init-vops progn (make-foo3-on-stack)) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index fee0323..552e821 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -237,7 +237,9 @@ ;; 1.0.29.44 introduces a ton of changes for complex floats ;; on x86-64. Huge test of doom to help catch weird corner ;; cases. -(with-test (:name :complex-floats) +;; Abuse the framework to also test some float arithmetic +;; changes wrt constant arguments in 1.0.29.54. +(with-test (:name :float-arithmetic) (labels ((equal-enough (x y) (cond ((eql x y)) ((or (complexp x) @@ -255,7 +257,8 @@ (complex (- (realpart x)) (imagpart x)) (- x))) (compute (x y r) - (list (+ x y) (+ r x) (+ x r) + (list (1+ x) (* 2 x) (/ x 2) (= 1 x) + (+ x y) (+ r x) (+ x r) (- x y) (- r x) (- x r) (* x y) (* x r) (* r x) (unless (zerop y) @@ -265,11 +268,16 @@ (unless (zerop x) (/ r x)) (conjugate x) (conjugate r) - (- x) + (abs r) (- r) (= 1 r) + (- x) (1+ r) (* 2 r) (/ r 2) (complex r) (complex r r) (complex 0 r) (= x y) (= r x) (= y r) (= x (complex 0 r)) + (= r (realpart x)) (= (realpart x) r) + (> r (realpart x)) (< r (realpart x)) + (> (realpart x) r) (< (realpart x) r) (eql x y) (eql x (complex r)) (eql y (complex r)) - (eql x (complex r r)) (eql y (complex 0 r)))) + (eql x (complex r r)) (eql y (complex 0 r)) + (eql r (realpart x)) (eql (realpart x) r))) (compute-all (x y r) (multiple-value-bind (x1 x2 x3 x4) (reflections x) (multiple-value-bind (y1 y2 y3 y4) (reflections y) @@ -300,6 +308,7 @@ (coerce y '(complex double-float)) (coerce r 'double-float)))) (assert (every (lambda (pos ref single double) + (declare (ignorable pos)) (every (lambda (ref single double) (or (and (equal-enough ref single) (equal-enough ref double)) diff --git a/version.lisp-expr b/version.lisp-expr index 694ce09..be4212d 100644 --- 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.29.53" +"1.0.29.54" -- 1.7.10.4