[Git][cmucl/cmucl][issue-170-clean-up-x86-float-compare] 10 commits: Fix #168: Use positive forms for conditional jmp.
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Tue Feb 28 18:25:58 UTC 2023
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/16c9e027291273ac7fb5e5b6b600571d88fd1946...a9178e0072535dc04b5f8541922cb7cbbef1fd65
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/16c9e027291273ac7fb5e5b6b600571d88fd1946...a9178e0072535dc04b5f8541922cb7cbbef1fd65
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230228/67035b18/attachment-0001.html>
More information about the cmucl-cvs
mailing list