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
-
27979066
by Raymond Toy at 2023-02-27T20:18:27+00:00
-
be6a7f01
by Raymond Toy at 2023-02-28T14:39:15+00:00
-
797e2e17
by Raymond Toy at 2023-02-28T14:39:17+00:00
-
eb943b50
by Raymond Toy at 2023-02-28T15:50:59+00:00
-
6ba270b2
by Raymond Toy at 2023-02-28T15:51:05+00:00
-
9a767f26
by Raymond Toy at 2023-02-28T09:55:59-08:00
-
2f4d8408
by Raymond Toy at 2023-02-28T09:57:17-08:00
-
7c4cecb9
by Raymond Toy at 2023-02-28T10:11:09-08:00
-
a9178e00
by Raymond Toy at 2023-02-28T10:14:49-08:00
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:
| 1 | 1 | variables:
|
| 2 | 2 | download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2021/07"
|
| 3 | 3 | version: "2021-07-x86"
|
| 4 | - bootstrap: "-B boot-2021-07-1"
|
|
| 4 | + bootstrap: "-B boot-2021-07-1 -B boot-2021-07-2"
|
|
| 5 | 5 | |
| 6 | 6 | stages:
|
| 7 | 7 | - install
|
| 1 | +;; Bootstrap file for x86 to choose the non-negated forms of the
|
|
| 2 | +;; condition flag for conditional jumps.
|
|
| 3 | +;;
|
|
| 4 | +;; Use bin/build.sh -B boot-2021-07-2 to build this.
|
|
| 5 | + |
|
| 6 | +(in-package :x86)
|
|
| 7 | + |
|
| 8 | +(ext:without-package-locks
|
|
| 9 | + (handler-bind
|
|
| 10 | + ((error
|
|
| 11 | + (lambda (c)
|
|
| 12 | + (declare (ignore c))
|
|
| 13 | + (invoke-restart 'continue))))
|
|
| 14 | + (defconstant conditions
|
|
| 15 | + '((:o . 0)
|
|
| 16 | + (:no . 1)
|
|
| 17 | + (:b . 2) (:nae . 2) (:c . 2)
|
|
| 18 | + (:ae . 3) (:nb . 3) (:nc . 3)
|
|
| 19 | + (:e . 4) (:eq . 4) (:z . 4)
|
|
| 20 | + (:ne . 5) (:nz . 5)
|
|
| 21 | + (:be . 6) (:na . 6)
|
|
| 22 | + (:a . 7) (:nbe . 7)
|
|
| 23 | + (:s . 8)
|
|
| 24 | + (:ns . 9)
|
|
| 25 | + (:p . 10) (:pe . 10)
|
|
| 26 | + (:np . 11) (:po . 11)
|
|
| 27 | + (:l . 12) (:nge . 12)
|
|
| 28 | + (:ge . 13) (:nl . 13)
|
|
| 29 | + (:le . 14) (:ng . 14)
|
|
| 30 | + (:g . 15) (:nle . 15))))) |
| ... | ... | @@ -1837,6 +1837,89 @@ When annotations are present, invoke them at the right positions." |
| 1837 | 1837 | (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>")
|
| 1838 | 1838 | stream list))
|
| 1839 | 1839 | |
| 1840 | +(defun pprint-define-vop (stream list &rest noise)
|
|
| 1841 | + (declare (ignore noise))
|
|
| 1842 | + (pprint-logical-block (stream list :prefix "(" :suffix ")")
|
|
| 1843 | + ;; Output "define-vop"
|
|
| 1844 | + (output-object (pprint-pop) stream)
|
|
| 1845 | + (pprint-exit-if-list-exhausted)
|
|
| 1846 | + (write-char #\space stream)
|
|
| 1847 | + ;; Output vop name
|
|
| 1848 | + (output-object (pprint-pop) stream)
|
|
| 1849 | + (pprint-exit-if-list-exhausted)
|
|
| 1850 | + (pprint-newline :mandatory stream)
|
|
| 1851 | + (pprint-indent :block 0 stream)
|
|
| 1852 | + ;; Print out each option starting on a new line
|
|
| 1853 | + (loop
|
|
| 1854 | + (write-char #\space stream)
|
|
| 1855 | + (let ((vop-option (pprint-pop)))
|
|
| 1856 | + ;; Figure out what option we have and print it neatly
|
|
| 1857 | + (case (car vop-option)
|
|
| 1858 | + ((:args :results)
|
|
| 1859 | + ;; :args and :results print out each arg/result indented neatly
|
|
| 1860 | + (pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
|
|
| 1861 | + ;; Output :args/:results
|
|
| 1862 | + (output-object (pprint-pop) stream)
|
|
| 1863 | + (pprint-exit-if-list-exhausted)
|
|
| 1864 | + (write-char #\space stream)
|
|
| 1865 | + (pprint-indent :current 0 stream)
|
|
| 1866 | + ;; Print each value indented the same amount so the line
|
|
| 1867 | + ;; up neatly.
|
|
| 1868 | + (loop
|
|
| 1869 | + (output-object (pprint-pop) stream)
|
|
| 1870 | + (pprint-exit-if-list-exhausted)
|
|
| 1871 | + (pprint-newline :mandatory stream))))
|
|
| 1872 | + ((:generator)
|
|
| 1873 | + (pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
|
|
| 1874 | + ;; Output :generator
|
|
| 1875 | + (output-object (pprint-pop) stream)
|
|
| 1876 | + (pprint-exit-if-list-exhausted)
|
|
| 1877 | + (write-char #\space stream)
|
|
| 1878 | + ;; Output cost
|
|
| 1879 | + (output-object (pprint-pop) stream)
|
|
| 1880 | + (pprint-exit-if-list-exhausted)
|
|
| 1881 | + ;; Newline and then the body of the generator
|
|
| 1882 | + (pprint-newline :mandatory stream)
|
|
| 1883 | + (write-char #\space stream)
|
|
| 1884 | + (pprint-indent :current 0 stream)
|
|
| 1885 | + (loop
|
|
| 1886 | + (output-object (pprint-pop) stream)
|
|
| 1887 | + (pprint-exit-if-list-exhausted)
|
|
| 1888 | + (pprint-newline :mandatory stream))))
|
|
| 1889 | + (t
|
|
| 1890 | + ;; Everything else just get printed as usual.
|
|
| 1891 | + (output-object vop-option stream))))
|
|
| 1892 | + (pprint-exit-if-list-exhausted)
|
|
| 1893 | + (pprint-newline :linear stream))))
|
|
| 1894 | + |
|
| 1895 | +(defun pprint-sc-case (stream list &rest noise)
|
|
| 1896 | + (declare (ignore noise))
|
|
| 1897 | + (pprint-logical-block (stream list :prefix "(" :suffix ")")
|
|
| 1898 | + ;; Output "sc-case"
|
|
| 1899 | + (output-object (pprint-pop) stream)
|
|
| 1900 | + (pprint-exit-if-list-exhausted)
|
|
| 1901 | + (write-char #\space stream)
|
|
| 1902 | + ;; Output variable name
|
|
| 1903 | + (output-object (pprint-pop) stream)
|
|
| 1904 | + (pprint-exit-if-list-exhausted)
|
|
| 1905 | + ;; Start the cases on a new line, indented.
|
|
| 1906 | + (pprint-newline :mandatory stream)
|
|
| 1907 | + (pprint-indent :block 0 stream)
|
|
| 1908 | + ;; Print out each case.
|
|
| 1909 | + (loop
|
|
| 1910 | + (write-char #\space stream)
|
|
| 1911 | + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
|
|
| 1912 | + ;; Output the case item
|
|
| 1913 | + (output-object (pprint-pop) stream)
|
|
| 1914 | + (pprint-exit-if-list-exhausted)
|
|
| 1915 | + (pprint-newline :mandatory stream)
|
|
| 1916 | + ;; Output everything else, starting on a new line.
|
|
| 1917 | + (loop
|
|
| 1918 | + (output-object (pprint-pop) stream)
|
|
| 1919 | + (pprint-exit-if-list-exhausted)
|
|
| 1920 | + (pprint-newline :mandatory stream)))
|
|
| 1921 | + (pprint-exit-if-list-exhausted)
|
|
| 1922 | + (pprint-newline :mandatory stream))))
|
|
| 1840 | 1923 | |
| 1841 | 1924 | ;;;; Interface seen by regular (ugly) printer and initialization routines.
|
| 1842 | 1925 | |
| ... | ... | @@ -1952,7 +2035,9 @@ When annotations are present, invoke them at the right positions." |
| 1952 | 2035 | (vm::with-fixed-allocation pprint-with-like)
|
| 1953 | 2036 | (kernel::number-dispatch pprint-with-like)
|
| 1954 | 2037 | (stream::with-stream-class pprint-with-like)
|
| 1955 | - (lisp::with-array-data pprint-with-like)))
|
|
| 2038 | + (lisp::with-array-data pprint-with-like)
|
|
| 2039 | + (c:define-vop pprint-define-vop)
|
|
| 2040 | + (c:sc-case pprint-sc-case)))
|
|
| 1956 | 2041 | |
| 1957 | 2042 | (defun pprint-init ()
|
| 1958 | 2043 | (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
|
| ... | ... | @@ -347,25 +347,25 @@ |
| 347 | 347 | ;;;
|
| 348 | 348 | |
| 349 | 349 | (deftype single-float-exponent ()
|
| 350 | - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
|
|
| 351 | - vm:single-float-digits)
|
|
| 350 | + `(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias
|
|
| 351 | + vm:single-float-digits))
|
|
| 352 | 352 | ,(- vm:single-float-normal-exponent-max vm:single-float-bias)))
|
| 353 | 353 | |
| 354 | 354 | (deftype double-float-exponent ()
|
| 355 | - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
|
|
| 356 | - vm:double-float-digits)
|
|
| 355 | + `(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias
|
|
| 356 | + vm:double-float-digits))
|
|
| 357 | 357 | ,(- vm:double-float-normal-exponent-max vm:double-float-bias)))
|
| 358 | 358 | |
| 359 | 359 | |
| 360 | 360 | (deftype single-float-int-exponent ()
|
| 361 | - `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
|
|
| 362 | - (* vm:single-float-digits 2))
|
|
| 361 | + `(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias
|
|
| 362 | + (* vm:single-float-digits 2)))
|
|
| 363 | 363 | ,(- vm:single-float-normal-exponent-max vm:single-float-bias
|
| 364 | 364 | vm:single-float-digits)))
|
| 365 | 365 | |
| 366 | 366 | (deftype double-float-int-exponent ()
|
| 367 | - `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
|
|
| 368 | - (* vm:double-float-digits 2))
|
|
| 367 | + `(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias
|
|
| 368 | + (* vm:double-float-digits 2)))
|
|
| 369 | 369 | ,(- vm:double-float-normal-exponent-max vm:double-float-bias
|
| 370 | 370 | vm:double-float-digits)))
|
| 371 | 371 |
| ... | ... | @@ -901,15 +901,14 @@ |
| 901 | 901 | ;;; comiss and comisd can cope with one or other arg in memory: we
|
| 902 | 902 | ;;; could (should, indeed) extend these to cope with descriptor args
|
| 903 | 903 | ;;; and stack args
|
| 904 | - |
|
| 905 | -(define-vop (single-float-compare float-compare)
|
|
| 906 | - (:args (x :scs (single-reg)) (y :scs (single-reg descriptor-reg)))
|
|
| 907 | - (:conditional)
|
|
| 908 | - (:arg-types single-float single-float))
|
|
| 909 | -(define-vop (double-float-compare float-compare)
|
|
| 910 | - (:args (x :scs (double-reg)) (y :scs (double-reg descriptor-reg)))
|
|
| 911 | - (:conditional)
|
|
| 912 | - (:arg-types double-float double-float))
|
|
| 904 | +(macrolet
|
|
| 905 | + ((frob (name sc ptype)
|
|
| 906 | + `(define-vop (,name float-compare)
|
|
| 907 | + (:args (x :scs (,sc))
|
|
| 908 | + (y :scs (,sc descriptor-reg)))
|
|
| 909 | + (:arg-types ,ptype ,ptype))))
|
|
| 910 | + (frob single-float-compare single-reg single-float)
|
|
| 911 | + (frob double-float-compare double-reg double-float))
|
|
| 913 | 912 | |
| 914 | 913 | (macrolet
|
| 915 | 914 | ((frob (size inst)
|
| ... | ... | @@ -945,50 +944,6 @@ |
| 945 | 944 | (frob single ucomiss)
|
| 946 | 945 | (frob double ucomisd))
|
| 947 | 946 | |
| 948 | -#+nil
|
|
| 949 | -(define-vop (=/single-float single-float-compare)
|
|
| 950 | - (:translate =)
|
|
| 951 | - (:info target not-p)
|
|
| 952 | - (:vop-var vop)
|
|
| 953 | - (:generator 3
|
|
| 954 | - (note-this-location vop :internal-error)
|
|
| 955 | - (sc-case y
|
|
| 956 | - (single-reg
|
|
| 957 | - (inst ucomiss x y))
|
|
| 958 | - (descriptor-reg
|
|
| 959 | - (inst ucomiss x (ea-for-sf-desc y))))
|
|
| 960 | - ;; if PF&CF, there was a NaN involved => not equal
|
|
| 961 | - ;; otherwise, ZF => equal
|
|
| 962 | - (cond (not-p
|
|
| 963 | - (inst jmp :p target)
|
|
| 964 | - (inst jmp :ne target))
|
|
| 965 | - (t
|
|
| 966 | - (let ((not-lab (gen-label)))
|
|
| 967 | - (inst jmp :p not-lab)
|
|
| 968 | - (inst jmp :e target)
|
|
| 969 | - (emit-label not-lab))))))
|
|
| 970 | - |
|
| 971 | -#+nil
|
|
| 972 | -(define-vop (=/double-float double-float-compare)
|
|
| 973 | - (:translate =)
|
|
| 974 | - (:info target not-p)
|
|
| 975 | - (:vop-var vop)
|
|
| 976 | - (:generator 3
|
|
| 977 | - (note-this-location vop :internal-error)
|
|
| 978 | - (sc-case y
|
|
| 979 | - (double-reg
|
|
| 980 | - (inst ucomisd x y))
|
|
| 981 | - (descriptor-reg
|
|
| 982 | - (inst ucomisd x (ea-for-df-desc y))))
|
|
| 983 | - (cond (not-p
|
|
| 984 | - (inst jmp :p target)
|
|
| 985 | - (inst jmp :ne target))
|
|
| 986 | - (t
|
|
| 987 | - (let ((not-lab (gen-label)))
|
|
| 988 | - (inst jmp :p not-lab)
|
|
| 989 | - (inst jmp :e target)
|
|
| 990 | - (emit-label not-lab))))))
|
|
| 991 | - |
|
| 992 | 947 | (macrolet
|
| 993 | 948 | ((frob (op size inst yep nope)
|
| 994 | 949 | (let ((ea (ecase size
|
| ... | ... | @@ -1016,119 +971,10 @@ |
| 1016 | 971 | (inst jmp :p not-lab)
|
| 1017 | 972 | (inst jmp ,yep target)
|
| 1018 | 973 | (emit-label not-lab)))))))))
|
| 1019 | - (frob < single ucomiss :b :nb)
|
|
| 1020 | - (frob < double ucomisd :b :nb)
|
|
| 1021 | - (frob > single ucomiss :a :na)
|
|
| 1022 | - (frob > double ucomisd :a :na))
|
|
| 1023 | - |
|
| 1024 | -#+nil
|
|
| 1025 | -(defmacro frob-float-compare (op size inst yep nope)
|
|
| 1026 | - (let ((ea (ecase size
|
|
| 1027 | - (single
|
|
| 1028 | - 'ea-for-sf-desc)
|
|
| 1029 | - (double
|
|
| 1030 | - 'ea-for-df-desc)))
|
|
| 1031 | - (name (symbolicate op "/" size "-FLOAT"))
|
|
| 1032 | - (sc-type (symbolicate size "-REG"))
|
|
| 1033 | - (inherit (symbolicate size "-FLOAT-COMPARE")))
|
|
| 1034 | - `(define-vop (,name ,inherit)
|
|
| 1035 | - (:translate ,op)
|
|
| 1036 | - (:info target not-p)
|
|
| 1037 | - (:generator 3
|
|
| 1038 | - (sc-case y
|
|
| 1039 | - (,sc-type
|
|
| 1040 | - (inst ,inst x y))
|
|
| 1041 | - (descriptor-reg
|
|
| 1042 | - (inst ,inst x (,ea y))))
|
|
| 1043 | - (cond (not-p
|
|
| 1044 | - (inst jmp :p target)
|
|
| 1045 | - (inst jmp ,nope target))
|
|
| 1046 | - (t
|
|
| 1047 | - (let ((not-lab (gen-label)))
|
|
| 1048 | - (inst jmp :p not-lab)
|
|
| 1049 | - (inst jmp ,yep target)
|
|
| 1050 | - (emit-label not-lab))))))))
|
|
| 1051 | - |
|
| 1052 | -#+nil
|
|
| 1053 | -(frob-float-compare < single ucomiss :b :nb)
|
|
| 1054 | -#+nil
|
|
| 1055 | -(frob-float-compare < double ucomisd :b :nb)
|
|
| 1056 | -#+nil
|
|
| 1057 | -(define-vop (</double-float double-float-compare)
|
|
| 1058 | - (:translate <)
|
|
| 1059 | - (:info target not-p)
|
|
| 1060 | - (:generator 3
|
|
| 1061 | - (sc-case y
|
|
| 1062 | - (double-reg
|
|
| 1063 | - (inst comisd x y))
|
|
| 1064 | - (descriptor-reg
|
|
| 1065 | - (inst comisd x (ea-for-df-desc y))))
|
|
| 1066 | - (cond (not-p
|
|
| 1067 | - (inst jmp :p target)
|
|
| 1068 | - (inst jmp :nc target))
|
|
| 1069 | - (t
|
|
| 1070 | - (let ((not-lab (gen-label)))
|
|
| 1071 | - (inst jmp :p not-lab)
|
|
| 1072 | - (inst jmp :c target)
|
|
| 1073 | - (emit-label not-lab))))))
|
|
| 1074 | - |
|
| 1075 | -#+nil
|
|
| 1076 | -(define-vop (</single-float single-float-compare)
|
|
| 1077 | - (:translate <)
|
|
| 1078 | - (:info target not-p)
|
|
| 1079 | - (:generator 3
|
|
| 1080 | - (sc-case y
|
|
| 1081 | - (single-reg
|
|
| 1082 | - (inst comiss x y))
|
|
| 1083 | - (descriptor-reg
|
|
| 1084 | - (inst comiss x (ea-for-sf-desc y))))
|
|
| 1085 | - (cond (not-p
|
|
| 1086 | - (inst jmp :p target)
|
|
| 1087 | - (inst jmp :nc target))
|
|
| 1088 | - (t
|
|
| 1089 | - (let ((not-lab (gen-label)))
|
|
| 1090 | - (inst jmp :p not-lab)
|
|
| 1091 | - (inst jmp :c target)
|
|
| 1092 | - (emit-label not-lab))))))
|
|
| 1093 | - |
|
| 1094 | -#+nil
|
|
| 1095 | -(define-vop (>/double-float double-float-compare)
|
|
| 1096 | - (:translate >)
|
|
| 1097 | - (:info target not-p)
|
|
| 1098 | - (:generator 3
|
|
| 1099 | - (sc-case y
|
|
| 1100 | - (double-reg
|
|
| 1101 | - (inst comisd x y))
|
|
| 1102 | - (descriptor-reg
|
|
| 1103 | - (inst comisd x (ea-for-df-desc y))))
|
|
| 1104 | - (cond (not-p
|
|
| 1105 | - (inst jmp :p target)
|
|
| 1106 | - (inst jmp :na target))
|
|
| 1107 | - (t
|
|
| 1108 | - (let ((not-lab (gen-label)))
|
|
| 1109 | - (inst jmp :p not-lab)
|
|
| 1110 | - (inst jmp :a target)
|
|
| 1111 | - (emit-label not-lab))))))
|
|
| 1112 | - |
|
| 1113 | -#+nil
|
|
| 1114 | -(define-vop (>/single-float single-float-compare)
|
|
| 1115 | - (:translate >)
|
|
| 1116 | - (:info target not-p)
|
|
| 1117 | - (:generator 3
|
|
| 1118 | - (sc-case y
|
|
| 1119 | - (single-reg
|
|
| 1120 | - (inst comiss x y))
|
|
| 1121 | - (descriptor-reg
|
|
| 1122 | - (inst comiss x (ea-for-sf-desc y))))
|
|
| 1123 | - (cond (not-p
|
|
| 1124 | - (inst jmp :p target)
|
|
| 1125 | - (inst jmp :na target))
|
|
| 1126 | - (t
|
|
| 1127 | - (let ((not-lab (gen-label)))
|
|
| 1128 | - (inst jmp :p not-lab)
|
|
| 1129 | - (inst jmp :a target)
|
|
| 1130 | - (emit-label not-lab))))))
|
|
| 1131 | - |
|
| 974 | + (frob < single comiss :b :nb)
|
|
| 975 | + (frob < double comisd :b :nb)
|
|
| 976 | + (frob > single comiss :a :na)
|
|
| 977 | + (frob > double comisd :a :na))
|
|
| 1132 | 978 | |
| 1133 | 979 | |
| 1134 | 980 | ;;;; Conversion:
|
| ... | ... | @@ -259,22 +259,39 @@ |
| 259 | 259 | ;; the first one is the one that is preferred when printing the
|
| 260 | 260 | ;; condition code out.
|
| 261 | 261 | (defconstant conditions
|
| 262 | - '((:o . 0)
|
|
| 262 | + '(
|
|
| 263 | + ;; OF = 1
|
|
| 264 | + (:o . 0)
|
|
| 265 | + ;; OF = 0
|
|
| 263 | 266 | (:no . 1)
|
| 267 | + ;; Unsigned <; CF = 1
|
|
| 264 | 268 | (:b . 2) (:nae . 2) (:c . 2)
|
| 265 | - (:nb . 3) (:ae . 3) (:nc . 3)
|
|
| 269 | + ;; Unsigned >=; CF = 0
|
|
| 270 | + (:ae . 3) (:nb . 3) (:nc . 3)
|
|
| 271 | + ;; Equal; ZF = 1
|
|
| 266 | 272 | (:e . 4) (:eq . 4) (:z . 4)
|
| 273 | + ;; Not equal; ZF = 0
|
|
| 267 | 274 | (:ne . 5) (:nz . 5)
|
| 275 | + ;; Unsigned <=; CF = 1 or ZF = 1
|
|
| 268 | 276 | (:be . 6) (:na . 6)
|
| 269 | - (:nbe . 7) (:a . 7)
|
|
| 277 | + ;; Unsigned >; CF = 1 and ZF = 0
|
|
| 278 | + (:a . 7) (:nbe . 7)
|
|
| 279 | + ;; SF = 1
|
|
| 270 | 280 | (:s . 8)
|
| 281 | + ;; SF = 0
|
|
| 271 | 282 | (:ns . 9)
|
| 283 | + ;; Parity even
|
|
| 272 | 284 | (:p . 10) (:pe . 10)
|
| 285 | + ;; Parity odd
|
|
| 273 | 286 | (:np . 11) (:po . 11)
|
| 287 | + ;; Signed <; SF /= OF
|
|
| 274 | 288 | (:l . 12) (:nge . 12)
|
| 275 | - (:nl . 13) (:ge . 13)
|
|
| 289 | + ;; Signed >=; SF = OF
|
|
| 290 | + (:ge . 13) (:nl . 13)
|
|
| 291 | + ;; Signed <=; ZF = 1 or SF /= OF
|
|
| 276 | 292 | (:le . 14) (:ng . 14)
|
| 277 | - (:nle . 15) (:g . 15)))
|
|
| 293 | + ;; Signed >; ZF =0 and SF = OF
|
|
| 294 | + (:g . 15) (:nle . 15)))
|
|
| 278 | 295 | |
| 279 | 296 | (defun conditional-opcode (condition)
|
| 280 | 297 | (cdr (assoc condition conditions :test #'eq))))
|
| ... | ... | @@ -840,3 +840,60 @@ |
| 840 | 840 | (let ((f (compile nil #'(lambda ()
|
| 841 | 841 | (nth-value 1 (integer-decode-float least-positive-double-float))))))
|
| 842 | 842 | (assert-equal -1126 (funcall f))))
|
| 843 | + |
|
| 844 | + |
|
| 845 | + |
|
| 846 | +(define-test issue.167.single
|
|
| 847 | + (:tag :issues)
|
|
| 848 | + (let ((df-min-expo (nth-value 1 (decode-float least-positive-single-float)))
|
|
| 849 | + (df-max-expo (nth-value 1 (decode-float most-positive-single-float))))
|
|
| 850 | + ;; Verify that the min exponent for kernel:single-float-exponent
|
|
| 851 | + ;; is the actual min exponent from decode-float.
|
|
| 852 | + (assert-true (typep df-min-expo 'kernel:single-float-exponent))
|
|
| 853 | + (assert-true (typep (1+ df-min-expo) 'kernel:single-float-exponent))
|
|
| 854 | + (assert-false (typep (1- df-min-expo) 'kernel:single-float-exponent))
|
|
| 855 | + |
|
| 856 | + ;; Verify that the max exponent for kernel:single-float-exponent
|
|
| 857 | + ;; is the actual max exponent from decode-float.
|
|
| 858 | + (assert-true (typep df-max-expo 'kernel:single-float-exponent))
|
|
| 859 | + (assert-true (typep (1- df-max-expo) 'kernel:single-float-exponent))
|
|
| 860 | + (assert-false (typep (1+ df-max-expo) 'kernel:single-float-exponent)))
|
|
| 861 | + |
|
| 862 | + ;; Same as for decode-float, but for integer-decode-float.
|
|
| 863 | + (let ((idf-min-expo (nth-value 1 (integer-decode-float least-positive-single-float)))
|
|
| 864 | + (idf-max-expo (nth-value 1 (integer-decode-float most-positive-single-float))))
|
|
| 865 | + (assert-true (typep idf-min-expo 'kernel:single-float-int-exponent))
|
|
| 866 | + (assert-true (typep (1+ idf-min-expo) 'kernel:single-float-int-exponent))
|
|
| 867 | + (assert-false (typep (1- idf-min-expo) 'kernel:single-float-int-exponent))
|
|
| 868 | + |
|
| 869 | + (assert-true (typep idf-max-expo 'kernel:single-float-int-exponent))
|
|
| 870 | + (assert-true (typep (1- idf-max-expo) 'kernel:single-float-int-exponent))
|
|
| 871 | + (assert-false (typep (1+ idf-max-expo) 'kernel:single-float-int-exponent))))
|
|
| 872 | + |
|
| 873 | +(define-test issue.167.double
|
|
| 874 | + (:tag :issues)
|
|
| 875 | + (let ((df-min-expo (nth-value 1 (decode-float least-positive-double-float)))
|
|
| 876 | + (df-max-expo (nth-value 1 (decode-float most-positive-double-float))))
|
|
| 877 | + ;; Verify that the min exponent for kernel:double-float-exponent
|
|
| 878 | + ;; is the actual min exponent from decode-float.
|
|
| 879 | + (assert-true (typep df-min-expo 'kernel:double-float-exponent))
|
|
| 880 | + (assert-true (typep (1+ df-min-expo) 'kernel:double-float-exponent))
|
|
| 881 | + (assert-false (typep (1- df-min-expo) 'kernel:double-float-exponent))
|
|
| 882 | + |
|
| 883 | + ;; Verify that the max exponent for kernel:double-float-exponent
|
|
| 884 | + ;; is the actual max exponent from decode-float.
|
|
| 885 | + (assert-true (typep df-max-expo 'kernel:double-float-exponent))
|
|
| 886 | + (assert-true (typep (1- df-max-expo) 'kernel:double-float-exponent))
|
|
| 887 | + (assert-false (typep (1+ df-max-expo) 'kernel:double-float-exponent)))
|
|
| 888 | + |
|
| 889 | + ;; Same as for decode-float, but for integer-decode-float.
|
|
| 890 | + (let ((idf-min-expo (nth-value 1 (integer-decode-float least-positive-double-float)))
|
|
| 891 | + (idf-max-expo (nth-value 1 (integer-decode-float most-positive-double-float))))
|
|
| 892 | + (assert-true (typep idf-min-expo 'kernel:double-float-int-exponent))
|
|
| 893 | + (assert-true (typep (1+ idf-min-expo) 'kernel:double-float-int-exponent))
|
|
| 894 | + (assert-false (typep (1- idf-min-expo) 'kernel:double-float-int-exponent))
|
|
| 895 | + |
|
| 896 | + (assert-true (typep idf-max-expo 'kernel:double-float-int-exponent))
|
|
| 897 | + (assert-true (typep (1- idf-max-expo) 'kernel:double-float-int-exponent))
|
|
| 898 | + (assert-false (typep (1+ idf-max-expo) 'kernel:double-float-int-exponent))))
|
|
| 899 | + |