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/6ba270b2d4b70c37d4bd362...