| ... |
... |
@@ -901,130 +901,80 @@ |
|
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
|
+(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))
|
|
904
|
912
|
|
|
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))
|
|
913
|
|
-
|
|
914
|
|
-(define-vop (=/single-float single-float-compare)
|
|
915
|
|
- (:translate =)
|
|
916
|
|
- (:info target not-p)
|
|
917
|
|
- (:vop-var vop)
|
|
918
|
|
- (:generator 3
|
|
919
|
|
- (note-this-location vop :internal-error)
|
|
920
|
|
- (sc-case y
|
|
921
|
|
- (single-reg
|
|
922
|
|
- (inst ucomiss x y))
|
|
923
|
|
- (descriptor-reg
|
|
924
|
|
- (inst ucomiss x (ea-for-sf-desc y))))
|
|
925
|
|
- ;; if PF&CF, there was a NaN involved => not equal
|
|
926
|
|
- ;; otherwise, ZF => equal
|
|
927
|
|
- (cond (not-p
|
|
928
|
|
- (inst jmp :p target)
|
|
929
|
|
- (inst jmp :ne target))
|
|
930
|
|
- (t
|
|
931
|
|
- (let ((not-lab (gen-label)))
|
|
932
|
|
- (inst jmp :p not-lab)
|
|
933
|
|
- (inst jmp :e target)
|
|
934
|
|
- (emit-label not-lab))))))
|
|
935
|
|
-
|
|
936
|
|
-(define-vop (=/double-float double-float-compare)
|
|
937
|
|
- (:translate =)
|
|
938
|
|
- (:info target not-p)
|
|
939
|
|
- (:vop-var vop)
|
|
940
|
|
- (:generator 3
|
|
941
|
|
- (note-this-location vop :internal-error)
|
|
942
|
|
- (sc-case y
|
|
943
|
|
- (double-reg
|
|
944
|
|
- (inst ucomisd x y))
|
|
945
|
|
- (descriptor-reg
|
|
946
|
|
- (inst ucomisd x (ea-for-df-desc y))))
|
|
947
|
|
- (cond (not-p
|
|
948
|
|
- (inst jmp :p target)
|
|
949
|
|
- (inst jmp :ne target))
|
|
950
|
|
- (t
|
|
951
|
|
- (let ((not-lab (gen-label)))
|
|
952
|
|
- (inst jmp :p not-lab)
|
|
953
|
|
- (inst jmp :e target)
|
|
954
|
|
- (emit-label not-lab))))))
|
|
955
|
|
-
|
|
956
|
|
-(define-vop (</double-float double-float-compare)
|
|
957
|
|
- (:translate <)
|
|
958
|
|
- (:info target not-p)
|
|
959
|
|
- (:generator 3
|
|
960
|
|
- (sc-case y
|
|
961
|
|
- (double-reg
|
|
962
|
|
- (inst comisd x y))
|
|
963
|
|
- (descriptor-reg
|
|
964
|
|
- (inst comisd x (ea-for-df-desc y))))
|
|
965
|
|
- (cond (not-p
|
|
966
|
|
- (inst jmp :p target)
|
|
967
|
|
- (inst jmp :nc target))
|
|
968
|
|
- (t
|
|
969
|
|
- (let ((not-lab (gen-label)))
|
|
970
|
|
- (inst jmp :p not-lab)
|
|
971
|
|
- (inst jmp :c target)
|
|
972
|
|
- (emit-label not-lab))))))
|
|
973
|
|
-
|
|
974
|
|
-(define-vop (</single-float single-float-compare)
|
|
975
|
|
- (:translate <)
|
|
976
|
|
- (:info target not-p)
|
|
977
|
|
- (:generator 3
|
|
978
|
|
- (sc-case y
|
|
979
|
|
- (single-reg
|
|
980
|
|
- (inst comiss x y))
|
|
981
|
|
- (descriptor-reg
|
|
982
|
|
- (inst comiss x (ea-for-sf-desc y))))
|
|
983
|
|
- (cond (not-p
|
|
984
|
|
- (inst jmp :p target)
|
|
985
|
|
- (inst jmp :nc target))
|
|
986
|
|
- (t
|
|
987
|
|
- (let ((not-lab (gen-label)))
|
|
988
|
|
- (inst jmp :p not-lab)
|
|
989
|
|
- (inst jmp :c target)
|
|
990
|
|
- (emit-label not-lab))))))
|
|
991
|
|
-
|
|
992
|
|
-(define-vop (>/double-float double-float-compare)
|
|
993
|
|
- (:translate >)
|
|
994
|
|
- (:info target not-p)
|
|
995
|
|
- (:generator 3
|
|
996
|
|
- (sc-case y
|
|
997
|
|
- (double-reg
|
|
998
|
|
- (inst comisd x y))
|
|
999
|
|
- (descriptor-reg
|
|
1000
|
|
- (inst comisd x (ea-for-df-desc y))))
|
|
1001
|
|
- (cond (not-p
|
|
1002
|
|
- (inst jmp :p target)
|
|
1003
|
|
- (inst jmp :na target))
|
|
1004
|
|
- (t
|
|
1005
|
|
- (let ((not-lab (gen-label)))
|
|
1006
|
|
- (inst jmp :p not-lab)
|
|
1007
|
|
- (inst jmp :a target)
|
|
1008
|
|
- (emit-label not-lab))))))
|
|
1009
|
|
-
|
|
1010
|
|
-(define-vop (>/single-float single-float-compare)
|
|
1011
|
|
- (:translate >)
|
|
1012
|
|
- (:info target not-p)
|
|
1013
|
|
- (:generator 3
|
|
1014
|
|
- (sc-case y
|
|
1015
|
|
- (single-reg
|
|
1016
|
|
- (inst comiss x y))
|
|
1017
|
|
- (descriptor-reg
|
|
1018
|
|
- (inst comiss x (ea-for-sf-desc y))))
|
|
1019
|
|
- (cond (not-p
|
|
1020
|
|
- (inst jmp :p target)
|
|
1021
|
|
- (inst jmp :na target))
|
|
1022
|
|
- (t
|
|
1023
|
|
- (let ((not-lab (gen-label)))
|
|
1024
|
|
- (inst jmp :p not-lab)
|
|
1025
|
|
- (inst jmp :a target)
|
|
1026
|
|
- (emit-label not-lab))))))
|
|
|
913
|
+(macrolet
|
|
|
914
|
+ ((frob (size inst)
|
|
|
915
|
+ (let ((ea (ecase size
|
|
|
916
|
+ (single
|
|
|
917
|
+ 'ea-for-sf-desc)
|
|
|
918
|
+ (double
|
|
|
919
|
+ 'ea-for-df-desc)))
|
|
|
920
|
+ (name (symbolicate "=/" size "-FLOAT"))
|
|
|
921
|
+ (sc-type (symbolicate size "-REG"))
|
|
|
922
|
+ (inherit (symbolicate size "-FLOAT-COMPARE")))
|
|
|
923
|
+ `(define-vop (,name ,inherit)
|
|
|
924
|
+ (:translate =)
|
|
|
925
|
+ (:info target not-p)
|
|
|
926
|
+ (:vop-var vop)
|
|
|
927
|
+ (:generator 3
|
|
|
928
|
+ (note-this-location vop :internal-error)
|
|
|
929
|
+ (sc-case y
|
|
|
930
|
+ (,sc-type
|
|
|
931
|
+ (inst ,inst x y))
|
|
|
932
|
+ (descriptor-reg
|
|
|
933
|
+ (inst ,inst x (,ea y))))
|
|
|
934
|
+ ;; if PF&CF, there was a NaN involved => not equal
|
|
|
935
|
+ ;; otherwise, ZF => equal
|
|
|
936
|
+ (cond (not-p
|
|
|
937
|
+ (inst jmp :p target)
|
|
|
938
|
+ (inst jmp :ne target))
|
|
|
939
|
+ (t
|
|
|
940
|
+ (let ((not-lab (gen-label)))
|
|
|
941
|
+ (inst jmp :p not-lab)
|
|
|
942
|
+ (inst jmp :e target)
|
|
|
943
|
+ (emit-label not-lab)))))))))
|
|
|
944
|
+ (frob single ucomiss)
|
|
|
945
|
+ (frob double ucomisd))
|
|
1027
|
946
|
|
|
|
947
|
+(macrolet
|
|
|
948
|
+ ((frob (op size inst yep nope)
|
|
|
949
|
+ (let ((ea (ecase size
|
|
|
950
|
+ (single
|
|
|
951
|
+ 'ea-for-sf-desc)
|
|
|
952
|
+ (double
|
|
|
953
|
+ 'ea-for-df-desc)))
|
|
|
954
|
+ (name (symbolicate op "/" size "-FLOAT"))
|
|
|
955
|
+ (sc-type (symbolicate size "-REG"))
|
|
|
956
|
+ (inherit (symbolicate size "-FLOAT-COMPARE")))
|
|
|
957
|
+ `(define-vop (,name ,inherit)
|
|
|
958
|
+ (:translate ,op)
|
|
|
959
|
+ (:info target not-p)
|
|
|
960
|
+ (:generator 3
|
|
|
961
|
+ (sc-case y
|
|
|
962
|
+ (,sc-type
|
|
|
963
|
+ (inst ,inst x y))
|
|
|
964
|
+ (descriptor-reg
|
|
|
965
|
+ (inst ,inst x (,ea y))))
|
|
|
966
|
+ (cond (not-p
|
|
|
967
|
+ (inst jmp :p target)
|
|
|
968
|
+ (inst jmp ,nope target))
|
|
|
969
|
+ (t
|
|
|
970
|
+ (let ((not-lab (gen-label)))
|
|
|
971
|
+ (inst jmp :p not-lab)
|
|
|
972
|
+ (inst jmp ,yep target)
|
|
|
973
|
+ (emit-label not-lab)))))))))
|
|
|
974
|
+ (frob < single comiss :b :nb)
|
|
|
975
|
+ (frob > single comiss :a :na)
|
|
|
976
|
+ (frob < double comisd :b :nb)
|
|
|
977
|
+ (frob > double comisd :a :na))
|
|
1028
|
978
|
|
|
1029
|
979
|
|
|
1030
|
980
|
;;;; Conversion:
|