[Git][cmucl/cmucl][master] 2 commits: Fix #170: reduce duplicated code for x86 float-compares
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed Mar 1 03:09:12 UTC 2023
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
a25354e9 by Raymond Toy at 2023-03-01T03:08:58+00:00
Fix #170: reduce duplicated code for x86 float-compares
- - - - -
68ef4c5b by Raymond Toy at 2023-03-01T03:09:00+00:00
Merge branch 'issue-170-clean-up-x86-float-compare' into 'master'
Fix #170: reduce duplicated code for x86 float-compares
Closes #170
See merge request cmucl/cmucl!122
- - - - -
1 changed file:
- src/compiler/x86/float-sse2.lisp
Changes:
=====================================
src/compiler/x86/float-sse2.lisp
=====================================
@@ -901,130 +901,80 @@
;;; 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
+(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))
-(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))
-
-(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))))))
-
-(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))))))
-
-(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))))))
-
-(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))))))
-
-(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))))))
-
-(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))))))
+(macrolet
+ ((frob (size inst)
+ (let ((ea (ecase size
+ (single
+ 'ea-for-sf-desc)
+ (double
+ 'ea-for-df-desc)))
+ (name (symbolicate "=/" size "-FLOAT"))
+ (sc-type (symbolicate size "-REG"))
+ (inherit (symbolicate size "-FLOAT-COMPARE")))
+ `(define-vop (,name ,inherit)
+ (:translate =)
+ (:info target not-p)
+ (:vop-var vop)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (sc-case y
+ (,sc-type
+ (inst ,inst x y))
+ (descriptor-reg
+ (inst ,inst x (,ea 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)))))))))
+ (frob single ucomiss)
+ (frob double ucomisd))
+(macrolet
+ ((frob (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)))))))))
+ (frob < single comiss :b :nb)
+ (frob > single comiss :a :na)
+ (frob < double comisd :b :nb)
+ (frob > double comisd :a :na))
;;;; Conversion:
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6ba270b2d4b70c37d4bd3628bedc18c14043b51a...68ef4c5b2708fd3c26e93d3f59ec2e733a9fb389
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6ba270b2d4b70c37d4bd3628bedc18c14043b51a...68ef4c5b2708fd3c26e93d3f59ec2e733a9fb389
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/20230301/0cf4e2c5/attachment-0001.html>
More information about the cmucl-cvs
mailing list