Raymond Toy pushed to branch issue-170-clean-up-x86-float-compare at cmucl / cmucl

Commits: 404e4b28 by Raymond Toy at 2023-02-27T20:18:24+00:00 Fix #168: Use positive forms for conditional jmp.

- - - - - 27979066 by Raymond Toy at 2023-02-27T20:18:27+00:00 Merge branch 'issue-168-no-negated-forms-for-jmp' into 'master'

Fix #168: Use positive forms for conditional jmp.

Closes #168

See merge request cmucl/cmucl!119 - - - - - be6a7f01 by Raymond Toy at 2023-02-28T14:39:15+00:00 Fix #169: pprint define-vop neatly

- - - - - 797e2e17 by Raymond Toy at 2023-02-28T14:39:17+00:00 Merge branch 'issue-169-pprint-define-vop' into 'master'

Fix #169: pprint define-vop neatly

Closes #169

See merge request cmucl/cmucl!120 - - - - - eb943b50 by Raymond Toy at 2023-02-28T15:50:59+00:00 Fix #167: double-float-exponent off by one

- - - - - 6ba270b2 by Raymond Toy at 2023-02-28T15:51:05+00:00 Merge branch 'issue-167-exponent-bounds-off-by-one' into 'master'

Fix #167: double-float-exponent off by one

See merge request cmucl/cmucl!121 - - - - - 9a767f26 by Raymond Toy at 2023-02-28T09:55:59-08:00 Macroize single-float-compare/double-float-compare

Use a macro to reduce duplicate code in `single-float-compare` and `double-float-compare`. Modeled after sparc and ppc code for the same.

- - - - - 2f4d8408 by Raymond Toy at 2023-02-28T09:57:17-08:00 Merge branch 'master' into issue-170-clean-up-x86-float-compare

- - - - - 7c4cecb9 by Raymond Toy at 2023-02-28T10:11:09-08:00 Use comis instead of ucomis for float compares

Made a typo when macroizing float compares. I checked; we consistently use comis, so let's use comis instead of ucomis.

- - - - - a9178e00 by Raymond Toy at 2023-02-28T10:14:49-08:00 Remove commented-out code that was macroized

- - - - -

7 changed files:

- .gitlab-ci.yml - + src/bootfiles/21d/boot-2021-07-2.lisp - src/code/pprint.lisp - src/compiler/float-tran.lisp - src/compiler/x86/float-sse2.lisp - src/compiler/x86/insts.lisp - tests/issues.lisp

Changes:

===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2021/07" version: "2021-07-x86" - bootstrap: "-B boot-2021-07-1" + bootstrap: "-B boot-2021-07-1 -B boot-2021-07-2"

stages: - install

===================================== src/bootfiles/21d/boot-2021-07-2.lisp ===================================== @@ -0,0 +1,30 @@ +;; Bootstrap file for x86 to choose the non-negated forms of the +;; condition flag for conditional jumps. +;; +;; Use bin/build.sh -B boot-2021-07-2 to build this. + +(in-package :x86) + +(ext:without-package-locks + (handler-bind + ((error + (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant conditions + '((:o . 0) + (:no . 1) + (:b . 2) (:nae . 2) (:c . 2) + (:ae . 3) (:nb . 3) (:nc . 3) + (:e . 4) (:eq . 4) (:z . 4) + (:ne . 5) (:nz . 5) + (:be . 6) (:na . 6) + (:a . 7) (:nbe . 7) + (:s . 8) + (:ns . 9) + (:p . 10) (:pe . 10) + (:np . 11) (:po . 11) + (:l . 12) (:nge . 12) + (:ge . 13) (:nl . 13) + (:le . 14) (:ng . 14) + (:g . 15) (:nle . 15)))))

===================================== src/code/pprint.lisp ===================================== @@ -1837,6 +1837,89 @@ When annotations are present, invoke them at the right positions." (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>") stream list))

+(defun pprint-define-vop (stream list &rest noise) + (declare (ignore noise)) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + ;; Output "define-vop" + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + ;; Output vop name + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream) + (pprint-indent :block 0 stream) + ;; Print out each option starting on a new line + (loop + (write-char #\space stream) + (let ((vop-option (pprint-pop))) + ;; Figure out what option we have and print it neatly + (case (car vop-option) + ((:args :results) + ;; :args and :results print out each arg/result indented neatly + (pprint-logical-block (stream vop-option :prefix "(" :suffix ")") + ;; Output :args/:results + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-indent :current 0 stream) + ;; Print each value indented the same amount so the line + ;; up neatly. + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream)))) + ((:generator) + (pprint-logical-block (stream vop-option :prefix "(" :suffix ")") + ;; Output :generator + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + ;; Output cost + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + ;; Newline and then the body of the generator + (pprint-newline :mandatory stream) + (write-char #\space stream) + (pprint-indent :current 0 stream) + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream)))) + (t + ;; Everything else just get printed as usual. + (output-object vop-option stream)))) + (pprint-exit-if-list-exhausted) + (pprint-newline :linear stream)))) + +(defun pprint-sc-case (stream list &rest noise) + (declare (ignore noise)) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + ;; Output "sc-case" + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + ;; Output variable name + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + ;; Start the cases on a new line, indented. + (pprint-newline :mandatory stream) + (pprint-indent :block 0 stream) + ;; Print out each case. + (loop + (write-char #\space stream) + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") + ;; Output the case item + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream) + ;; Output everything else, starting on a new line. + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))))  ;;;; Interface seen by regular (ugly) printer and initialization routines.

@@ -1952,7 +2035,9 @@ When annotations are present, invoke them at the right positions." (vm::with-fixed-allocation pprint-with-like) (kernel::number-dispatch pprint-with-like) (stream::with-stream-class pprint-with-like) - (lisp::with-array-data pprint-with-like))) + (lisp::with-array-data pprint-with-like) + (c:define-vop pprint-define-vop) + (c:sc-case pprint-sc-case)))

(defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

===================================== src/compiler/float-tran.lisp ===================================== @@ -347,25 +347,25 @@ ;;;

(deftype single-float-exponent () - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias - vm:single-float-digits) + `(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias + vm:single-float-digits)) ,(- vm:single-float-normal-exponent-max vm:single-float-bias)))

(deftype double-float-exponent () - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias - vm:double-float-digits) + `(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias + vm:double-float-digits)) ,(- vm:double-float-normal-exponent-max vm:double-float-bias)))

(deftype single-float-int-exponent () - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias - (* vm:single-float-digits 2)) + `(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias + (* vm:single-float-digits 2))) ,(- vm:single-float-normal-exponent-max vm:single-float-bias vm:single-float-digits)))

(deftype double-float-int-exponent () - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias - (* vm:double-float-digits 2)) + `(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias + (* vm:double-float-digits 2))) ,(- vm:double-float-normal-exponent-max vm:double-float-bias vm:double-float-digits)))

===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -901,15 +901,14 @@ ;;; 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 descriptor-reg))) - (:conditional) - (:arg-types single-float single-float)) -(define-vop (double-float-compare float-compare) - (:args (x :scs (double-reg)) (y :scs (double-reg descriptor-reg))) - (:conditional) - (:arg-types double-float double-float)) +(macrolet + ((frob (name sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc descriptor-reg))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg single-float) + (frob double-float-compare double-reg double-float))

(macrolet ((frob (size inst) @@ -945,50 +944,6 @@ (frob single ucomiss) (frob double ucomisd))

-#+nil -(define-vop (=/single-float single-float-compare) - (:translate =) - (:info target not-p) - (:vop-var vop) - (:generator 3 - (note-this-location vop :internal-error) - (sc-case y - (single-reg - (inst ucomiss x y)) - (descriptor-reg - (inst ucomiss x (ea-for-sf-desc y)))) - ;; if PF&CF, there was a NaN involved => not equal - ;; otherwise, ZF => equal - (cond (not-p - (inst jmp :p target) - (inst jmp :ne target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :e target) - (emit-label not-lab)))))) - -#+nil -(define-vop (=/double-float double-float-compare) - (:translate =) - (:info target not-p) - (:vop-var vop) - (:generator 3 - (note-this-location vop :internal-error) - (sc-case y - (double-reg - (inst ucomisd x y)) - (descriptor-reg - (inst ucomisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :ne target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :e target) - (emit-label not-lab)))))) - (macrolet ((frob (op size inst yep nope) (let ((ea (ecase size @@ -1016,119 +971,10 @@ (inst jmp :p not-lab) (inst jmp ,yep target) (emit-label not-lab))))))))) - (frob < single ucomiss :b :nb) - (frob < double ucomisd :b :nb) - (frob > single ucomiss :a :na) - (frob > double ucomisd :a :na)) - -#+nil -(defmacro frob-float-compare (op size inst yep nope) - (let ((ea (ecase size - (single - 'ea-for-sf-desc) - (double - 'ea-for-df-desc))) - (name (symbolicate op "/" size "-FLOAT")) - (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) - `(define-vop (,name ,inherit) - (:translate ,op) - (:info target not-p) - (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab)))))))) - -#+nil -(frob-float-compare < single ucomiss :b :nb) -#+nil -(frob-float-compare < double ucomisd :b :nb) -#+nil -(define-vop (</double-float double-float-compare) - (:translate <) - (:info target not-p) - (:generator 3 - (sc-case y - (double-reg - (inst comisd x y)) - (descriptor-reg - (inst comisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :nc target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :c target) - (emit-label not-lab)))))) - -#+nil -(define-vop (</single-float single-float-compare) - (:translate <) - (:info target not-p) - (:generator 3 - (sc-case y - (single-reg - (inst comiss x y)) - (descriptor-reg - (inst comiss x (ea-for-sf-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :nc target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :c target) - (emit-label not-lab)))))) - -#+nil -(define-vop (>/double-float double-float-compare) - (:translate >) - (:info target not-p) - (:generator 3 - (sc-case y - (double-reg - (inst comisd x y)) - (descriptor-reg - (inst comisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab)))))) - -#+nil -(define-vop (>/single-float single-float-compare) - (:translate >) - (:info target not-p) - (:generator 3 - (sc-case y - (single-reg - (inst comiss x y)) - (descriptor-reg - (inst comiss x (ea-for-sf-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab)))))) - + (frob < single comiss :b :nb) + (frob < double comisd :b :nb) + (frob > single comiss :a :na) + (frob > double comisd :a :na))

;;;; Conversion:

===================================== src/compiler/x86/insts.lisp ===================================== @@ -259,22 +259,39 @@ ;; the first one is the one that is preferred when printing the ;; condition code out. (defconstant conditions - '((:o . 0) + '( + ;; OF = 1 + (:o . 0) + ;; OF = 0 (:no . 1) + ;; Unsigned <; CF = 1 (:b . 2) (:nae . 2) (:c . 2) - (:nb . 3) (:ae . 3) (:nc . 3) + ;; Unsigned >=; CF = 0 + (:ae . 3) (:nb . 3) (:nc . 3) + ;; Equal; ZF = 1 (:e . 4) (:eq . 4) (:z . 4) + ;; Not equal; ZF = 0 (:ne . 5) (:nz . 5) + ;; Unsigned <=; CF = 1 or ZF = 1 (:be . 6) (:na . 6) - (:nbe . 7) (:a . 7) + ;; Unsigned >; CF = 1 and ZF = 0 + (:a . 7) (:nbe . 7) + ;; SF = 1 (:s . 8) + ;; SF = 0 (:ns . 9) + ;; Parity even (:p . 10) (:pe . 10) + ;; Parity odd (:np . 11) (:po . 11) + ;; Signed <; SF /= OF (:l . 12) (:nge . 12) - (:nl . 13) (:ge . 13) + ;; Signed >=; SF = OF + (:ge . 13) (:nl . 13) + ;; Signed <=; ZF = 1 or SF /= OF (:le . 14) (:ng . 14) - (:nle . 15) (:g . 15))) + ;; Signed >; ZF =0 and SF = OF + (:g . 15) (:nle . 15)))

(defun conditional-opcode (condition) (cdr (assoc condition conditions :test #'eq))))

===================================== tests/issues.lisp ===================================== @@ -840,3 +840,60 @@ (let ((f (compile nil #'(lambda () (nth-value 1 (integer-decode-float least-positive-double-float)))))) (assert-equal -1126 (funcall f)))) + + + +(define-test issue.167.single + (:tag :issues) + (let ((df-min-expo (nth-value 1 (decode-float least-positive-single-float))) + (df-max-expo (nth-value 1 (decode-float most-positive-single-float)))) + ;; Verify that the min exponent for kernel:single-float-exponent + ;; is the actual min exponent from decode-float. + (assert-true (typep df-min-expo 'kernel:single-float-exponent)) + (assert-true (typep (1+ df-min-expo) 'kernel:single-float-exponent)) + (assert-false (typep (1- df-min-expo) 'kernel:single-float-exponent)) + + ;; Verify that the max exponent for kernel:single-float-exponent + ;; is the actual max exponent from decode-float. + (assert-true (typep df-max-expo 'kernel:single-float-exponent)) + (assert-true (typep (1- df-max-expo) 'kernel:single-float-exponent)) + (assert-false (typep (1+ df-max-expo) 'kernel:single-float-exponent))) + + ;; Same as for decode-float, but for integer-decode-float. + (let ((idf-min-expo (nth-value 1 (integer-decode-float least-positive-single-float))) + (idf-max-expo (nth-value 1 (integer-decode-float most-positive-single-float)))) + (assert-true (typep idf-min-expo 'kernel:single-float-int-exponent)) + (assert-true (typep (1+ idf-min-expo) 'kernel:single-float-int-exponent)) + (assert-false (typep (1- idf-min-expo) 'kernel:single-float-int-exponent)) + + (assert-true (typep idf-max-expo 'kernel:single-float-int-exponent)) + (assert-true (typep (1- idf-max-expo) 'kernel:single-float-int-exponent)) + (assert-false (typep (1+ idf-max-expo) 'kernel:single-float-int-exponent)))) + +(define-test issue.167.double + (:tag :issues) + (let ((df-min-expo (nth-value 1 (decode-float least-positive-double-float))) + (df-max-expo (nth-value 1 (decode-float most-positive-double-float)))) + ;; Verify that the min exponent for kernel:double-float-exponent + ;; is the actual min exponent from decode-float. + (assert-true (typep df-min-expo 'kernel:double-float-exponent)) + (assert-true (typep (1+ df-min-expo) 'kernel:double-float-exponent)) + (assert-false (typep (1- df-min-expo) 'kernel:double-float-exponent)) + + ;; Verify that the max exponent for kernel:double-float-exponent + ;; is the actual max exponent from decode-float. + (assert-true (typep df-max-expo 'kernel:double-float-exponent)) + (assert-true (typep (1- df-max-expo) 'kernel:double-float-exponent)) + (assert-false (typep (1+ df-max-expo) 'kernel:double-float-exponent))) + + ;; Same as for decode-float, but for integer-decode-float. + (let ((idf-min-expo (nth-value 1 (integer-decode-float least-positive-double-float))) + (idf-max-expo (nth-value 1 (integer-decode-float most-positive-double-float)))) + (assert-true (typep idf-min-expo 'kernel:double-float-int-exponent)) + (assert-true (typep (1+ idf-min-expo) 'kernel:double-float-int-exponent)) + (assert-false (typep (1- idf-min-expo) 'kernel:double-float-int-exponent)) + + (assert-true (typep idf-max-expo 'kernel:double-float-int-exponent)) + (assert-true (typep (1- idf-max-expo) 'kernel:double-float-int-exponent)) + (assert-false (typep (1+ idf-max-expo) 'kernel:double-float-int-exponent)))) +

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/16c9e027291273ac7fb5e5b...