From d95f1e6476aa63695e018a7769a1ae9e002fca36 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Sun, 11 Jan 2009 18:39:07 +0000 Subject: [PATCH] 1.0.24.35: Flag-setting VOPs on x86[-64] and conditional moves * Most :CONDITIONAL VOPs only specify which condition flags they set * GENERIC-{EQL,=,<,>} are :CONDITIONAL VOPs, but don't show up as calls anymore * Values may be selected with CMOVcc if applicable (and :CMOV is in *backend-subfeatures*, for x86): - Values that are represented, unboxed, in GPRs are CMOVed using custom VOPs - Unboxed float and complex types aren't converted - Other types are assumed to be boxed and CMOVed as descriptors * A test to try and to cover an interesting cross-section of flags and values to move conditionally. --- src/assembly/x86-64/arith.lisp | 215 +++++++++++++++++++++------------- src/assembly/x86/arith.lisp | 230 ++++++++++++++++++++++--------------- src/compiler/x86-64/arith.lisp | 49 +++----- src/compiler/x86-64/cell.lisp | 12 +- src/compiler/x86-64/char.lisp | 26 ++--- src/compiler/x86-64/float.lisp | 81 +++---------- src/compiler/x86-64/pred.lisp | 185 +++++++++++++++++++++++++++-- src/compiler/x86-64/type-vops.lisp | 5 +- src/compiler/x86/arith.lisp | 78 ++++++------- src/compiler/x86/cell.lisp | 12 +- src/compiler/x86/char.lisp | 25 ++-- src/compiler/x86/float.lisp | 50 +++----- src/compiler/x86/pred.lisp | 145 +++++++++++++++++++++-- src/compiler/x86/type-vops.lisp | 5 +- tests/compiler.pure.lisp | 139 ++++++++++++++++++++++ tests/step.impure.lisp | 134 ++++++++++++++------- version.lisp-expr | 2 +- 17 files changed, 937 insertions(+), 456 deletions(-) diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp index 3e8399237..d47b7206d 100644 --- a/src/assembly/x86-64/arith.lisp +++ b/src/assembly/x86-64/arith.lisp @@ -151,64 +151,79 @@ ;;;; comparison (macrolet ((define-cond-assem-rtn (name translate static-fn test) + (declare (ignorable translate static-fn)) + #+sb-assembling `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) + (:return-style :none)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset)) + (:temp rcx unsigned-reg rcx-offset)) - (inst mov ecx x) - (inst or ecx y) - (inst test ecx fixnum-tag-mask) + (inst mov rcx x) + (inst or rcx y) + (inst test rcx fixnum-tag-mask) (inst jmp :nz DO-STATIC-FUN) (inst cmp x y) - (load-symbol res t) - (inst mov eax nil-value) - (inst cmov ,test res eax) - (inst clc) ; single-value return (inst ret) DO-STATIC-FUN - (inst pop eax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword - :base rsp-tn - :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) - (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and - ; SINGLE-FLOAT-BITS are parallel, - ; should be named parallelly. - (inst jmp (make-ea :qword - :disp (+ nil-value - (static-fun-offset ',static-fn))))))) - - (define-cond-assem-rtn generic-< < two-arg-< :ge) - (define-cond-assem-rtn generic-> > two-arg-> :le)) - + (move rcx rsp-tn) + (inst sub rsp-tn (fixnumize 3)) + (inst mov (make-ea :qword + :base rcx + :disp (fixnumize -1)) + rbp-tn) + (move rbp-tn rcx) + (inst mov rcx (fixnumize 2)) + (inst call (make-ea :qword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + ;; HACK: We depend on NIL having the lowest address of all + ;; static symbols (including T) + ,@(ecase test + (:l `((inst mov y (1+ nil-value)) + (inst cmp y x))) + (:g `((inst cmp x (1+ nil-value))))) + (inst ret)) + #-sb-assembling + `(define-vop (,name) + (:translate ,translate) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional ,test) + (:generator 10 + (move rdx x) + (move rdi y) + (inst lea rcx (make-ea :qword + :disp (make-fixup ',name :assembly-routine))) + (inst call rcx))))) + + (define-cond-assem-rtn generic-< < two-arg-< :l) + (define-cond-assem-rtn generic-> > two-arg-> :g)) + +#+sb-assembling (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) + (:return-style :none)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) rdi-offset) - (:res res descriptor-reg rdx-offset) - - (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) + (inst mov rcx x) (inst and rcx y) (inst test rcx fixnum-tag-mask) @@ -216,34 +231,55 @@ ;; At least one fixnum (inst cmp x y) - (load-symbol res t) - (inst mov rax nil-value) - (inst cmov :ne res rax) - (inst clc) (inst ret) DO-STATIC-FUN - (inst pop rax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push rax) + (move rcx rsp-tn) + (inst sub rsp-tn (fixnumize 3)) + (inst mov (make-ea :qword + :base rcx + :disp (fixnumize -1)) + rbp-tn) + (move rbp-tn rcx) (inst mov rcx (fixnumize 2)) - (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'eql))))) - + (inst call (make-ea :qword + :disp (+ nil-value (static-fun-offset 'eql)))) + (load-symbol y t) + (inst cmp x y) + (inst ret)) + +#-sb-assembling +(define-vop (generic-eql) + (:translate eql) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional :e) + (:generator 10 + (move rdx x) + (move rdi y) + (inst lea rcx (make-ea :qword + :disp (make-fixup 'generic-eql :assembly-routine))) + (inst call rcx))) + +#+sb-assembling (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) + (:return-style :none)) ((:arg x (descriptor-reg any-reg) rdx-offset) (:arg y (descriptor-reg any-reg) rdi-offset) - (:res res descriptor-reg rdx-offset) - - (:temp rax unsigned-reg rax-offset) (:temp rcx unsigned-reg rcx-offset)) (inst mov rcx x) (inst or rcx y) @@ -252,20 +288,45 @@ ;; Both fixnums (inst cmp x y) - (load-symbol res t) - (inst mov rax nil-value) - (inst cmov :ne res rax) - (inst clc) (inst ret) DO-STATIC-FUN - (inst pop rax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push rax) + (move rcx rsp-tn) + (inst sub rsp-tn (fixnumize 3)) + (inst mov (make-ea :qword + :base rcx + :disp (fixnumize -1)) + rbp-tn) + (move rbp-tn rcx) (inst mov rcx (fixnumize 2)) - (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'two-arg-=))))) - - + (inst call (make-ea :qword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + (load-symbol y t) + (inst cmp x y) + (inst ret)) + +#-sb-assembling +(define-vop (generic-=) + (:translate =) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target rdx) + (y :scs (descriptor-reg any-reg) :target rdi)) + + (:temporary (:sc unsigned-reg :offset rdx-offset + :from (:argument 0)) + rdx) + (:temporary (:sc unsigned-reg :offset rdi-offset + :from (:argument 1)) + rdi) + + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval) + rcx) + (:conditional :e) + (:generator 10 + (move rdx x) + (move rdi y) + (inst lea rcx (make-ea :qword + :disp (make-fixup 'generic-= :assembly-routine))) + (inst call rcx))) diff --git a/src/assembly/x86/arith.lisp b/src/assembly/x86/arith.lisp index 535e02375..f3081f824 100644 --- a/src/assembly/x86/arith.lisp +++ b/src/assembly/x86/arith.lisp @@ -154,18 +154,12 @@ ;;;; comparison (macrolet ((define-cond-assem-rtn (name translate static-fn test) + #+sb-assembling `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) + (:return-style :none)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst mov ecx x) @@ -174,120 +168,174 @@ (inst jmp :nz DO-STATIC-FUN) ; are both fixnums? (inst cmp x y) - (cond ((member :cmov *backend-subfeatures*) - (load-symbol res t) - (inst mov eax nil-value) - (inst cmov ,test res eax)) - (t - (inst mov res nil-value) - (inst jmp ,test RETURN) - (load-symbol res t))) - RETURN - (inst clc) ; single-value return (inst ret) DO-STATIC-FUN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword - :base esp-tn - :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) - (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and - ; SINGLE-FLOAT-BITS are parallel, - ; should be named parallelly. - (inst jmp (make-ea :dword - :disp (+ nil-value - (static-fun-offset ',static-fn))))))) - - (define-cond-assem-rtn generic-< < two-arg-< :ge) - (define-cond-assem-rtn generic-> > two-arg-> :le)) - + (move ecx esp-tn) + (inst sub esp-tn (fixnumize 3)) + (inst mov (make-ea :dword + :base ecx :disp (fixnumize -1)) + ebp-tn) + (move ebp-tn ecx) + (inst mov ecx (fixnumize 2)) + (inst call (make-ea :dword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + ;; HACK: We depend on NIL having the lowest address of all + ;; static symbols (including T) + ,@(ecase test + (:l `((inst mov y (1+ nil-value)) + (inst cmp y x))) + (:g `((inst cmp x (1+ nil-value))))) + (inst ret)) + #-sb-assembling + `(define-vop (,name) + (:translate ,translate) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target edx) + (y :scs (descriptor-reg any-reg) :target edi)) + + (:temporary (:sc unsigned-reg :offset edx-offset + :from (:argument 0)) + edx) + (:temporary (:sc unsigned-reg :offset edi-offset + :from (:argument 1)) + edi) + + (:temporary (:sc unsigned-reg :offset ecx-offset + :from :eval) + ecx) + (:conditional ,test) + (:generator 10 + (move edx x) + (move edi y) + (inst lea ecx (make-ea :dword + :disp (make-fixup ',name :assembly-routine))) + (inst call ecx))))) + + (define-cond-assem-rtn generic-< < two-arg-< :l) + (define-cond-assem-rtn generic-> > two-arg-> :g)) + +#+sb-assembling (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) + (:return-style :none)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst mov ecx x) (inst and ecx y) - (inst test ecx fixnum-tag-mask) - (inst jmp :nz DO-STATIC-FUN) + (inst and ecx lowtag-mask) + (inst cmp ecx other-pointer-lowtag) + (inst jmp :e DO-STATIC-FUN) - ;; At least one fixnum + ;; Not both other pointers (inst cmp x y) - (load-symbol res t) - (cond ((member :cmov *backend-subfeatures*) - (inst mov eax nil-value) - (inst cmov :ne res eax)) - (t - (inst jmp :e RETURN) - (inst mov res nil-value))) - RETURN - (inst clc) + RET (inst ret) - ;; FIXME: We could handle all non-numbers here easily enough: go to - ;; TWO-ARG-EQL only if lowtags and widetags match, lowtag is - ;; other-pointer-lowtag and widetag is < code-header-widetag. DO-STATIC-FUN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) + ;; Might as well fast path that... + (inst cmp x y) + (inst jmp :e RET) + + (move ecx esp-tn) + (inst sub esp-tn (fixnumize 3)) + (inst mov (make-ea :dword + :base ecx + :disp (fixnumize -1)) + ebp-tn) + (move ebp-tn ecx) (inst mov ecx (fixnumize 2)) - (inst jmp (make-ea :dword - :disp (+ nil-value (static-fun-offset 'eql))))) + (inst call (make-ea :dword + :disp (+ nil-value (static-fun-offset 'eql)))) + (load-symbol y t) + (inst cmp x y) + (inst ret)) +#-sb-assembling +(define-vop (generic-eql) + (:translate eql) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target edx) + (y :scs (descriptor-reg any-reg) :target edi)) + + (:temporary (:sc unsigned-reg :offset edx-offset + :from (:argument 0)) + edx) + (:temporary (:sc unsigned-reg :offset edi-offset + :from (:argument 1)) + edi) + + (:temporary (:sc unsigned-reg :offset ecx-offset + :from :eval) + ecx) + (:conditional :e) + (:generator 10 + (move edx x) + (move edi y) + (inst lea ecx (make-ea :dword + :disp (make-fixup 'generic-eql :assembly-routine))) + (inst call ecx))) + +#+sb-assembling (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) + (:return-style :none)) ((:arg x (descriptor-reg any-reg) edx-offset) (:arg y (descriptor-reg any-reg) edi-offset) - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) (:temp ecx unsigned-reg ecx-offset)) (inst mov ecx x) (inst or ecx y) - (inst test ecx fixnum-tag-mask) ; both fixnums? + (inst test ecx fixnum-tag-mask) (inst jmp :nz DO-STATIC-FUN) + ;; Both fixnums (inst cmp x y) - (load-symbol res t) - (cond ((member :cmov *backend-subfeatures*) - (inst mov eax nil-value) - (inst cmov :ne res eax)) - (t - (inst jmp :e RETURN) - (inst mov res nil-value))) - RETURN - (inst clc) (inst ret) DO-STATIC-FUN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) + (move ecx esp-tn) + (inst sub esp-tn (fixnumize 3)) + (inst mov (make-ea :dword + :base ecx + :disp (fixnumize -1)) + ebp-tn) + (move ebp-tn ecx) (inst mov ecx (fixnumize 2)) - (inst jmp (make-ea :dword - :disp (+ nil-value (static-fun-offset 'two-arg-=))))) + (inst call (make-ea :dword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + (load-symbol y t) + (inst cmp x y) + (inst ret)) + +#-sb-assembling +(define-vop (generic-=) + (:translate =) + (:policy :safe) + (:save-p t) + (:args (x :scs (descriptor-reg any-reg) :target edx) + (y :scs (descriptor-reg any-reg) :target edi)) + + (:temporary (:sc unsigned-reg :offset edx-offset + :from (:argument 0)) + edx) + (:temporary (:sc unsigned-reg :offset edi-offset + :from (:argument 1)) + edi) + + (:temporary (:sc unsigned-reg :offset ecx-offset + :from :eval) + ecx) + (:conditional :e) + (:generator 10 + (move edx x) + (move edi y) + (inst lea ecx (make-ea :dword + :disp (make-fixup 'generic-= :assembly-routine))) + (inst call ecx))) ;;; Support for the Mersenne Twister, MT19937, random number generator diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index d0436d5d9..9e145501e 100644 --- a/src/compiler/x86-64/arith.lisp +++ b/src/compiler/x86-64/arith.lisp @@ -1008,8 +1008,8 @@ ;;;; binary conditional VOPs (define-vop (fast-conditional) - (:conditional) - (:info target not-p) + (:conditional :e) + (:info) (:effects) (:affected) (:policy :fast-safe)) @@ -1028,7 +1028,7 @@ (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant (signed-byte 29))) - (:info target not-p y)) + (:info y)) (define-vop (fast-conditional/signed fast-conditional) (:args (x :scs (signed-reg) @@ -1041,7 +1041,7 @@ (define-vop (fast-conditional-c/signed fast-conditional/signed) (:args (x :scs (signed-reg signed-stack))) (:arg-types signed-num (:constant (signed-byte 31))) - (:info target not-p y)) + (:info y)) (define-vop (fast-conditional/unsigned fast-conditional) (:args (x :scs (unsigned-reg) @@ -1054,7 +1054,7 @@ (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) (:args (x :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num (:constant (unsigned-byte 31))) - (:info target not-p y)) + (:info y)) (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned) `(progn @@ -1068,19 +1068,12 @@ (format nil "~:@(FAST-CONDITIONAL~A~)" suffix))) (:translate ,tran) + (:conditional ,(if signed cond unsigned)) (:generator ,cost (inst cmp x ,(if (eq suffix '-c/fixnum) '(fixnumize y) - 'y)) - (inst jmp (if not-p - ,(if signed - not-cond - not-unsigned) - ,(if signed - cond - unsigned)) - target)))) + 'y))))) '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) ; '(/fixnum /signed /unsigned) '(4 3 6 5 6 5) @@ -1092,8 +1085,7 @@ (define-vop (fast-if-eql/signed fast-conditional/signed) (:translate eql) (:generator 6 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) (define-vop (fast-if-eql-c/signed fast-conditional-c/signed) (:translate eql) @@ -1101,14 +1093,12 @@ (cond ((and (sc-is x signed-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x y))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))))) (define-vop (fast-if-eql/unsigned fast-conditional/unsigned) (:translate eql) (:generator 6 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) (:translate eql) @@ -1116,8 +1106,7 @@ (cond ((and (sc-is x unsigned-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x y))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))))) ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a ;;; known fixnum. @@ -1137,8 +1126,8 @@ (:note "inline fixnum comparison") (:translate eql) (:generator 4 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) + (define-vop (generic-eql/fixnum fast-eql/fixnum) (:args (x :scs (any-reg descriptor-reg) :load-if (not (and (sc-is x control-stack) @@ -1147,18 +1136,16 @@ (:arg-types * tagged-num) (:variant-cost 7)) - (define-vop (fast-eql-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant (signed-byte 29))) - (:info target not-p y) + (:info y) (:translate eql) (:generator 2 (cond ((and (sc-is x any-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x (fixnumize y)))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x (fixnumize y)))))) (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) (:args (x :scs (any-reg descriptor-reg control-stack))) @@ -1413,11 +1400,9 @@ (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) - (:conditional) - (:info target not-p) + (:conditional :ns) (:generator 3 - (inst or digit digit) - (inst jmp (if not-p :s :ns) target))) + (inst or digit digit))) ;;; For add and sub with carry the sc of carry argument is any-reg so diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index d90f81b8d..e82cdd472 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -221,8 +221,7 @@ (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 (let ((check-unbound-label (gen-label))) @@ -233,21 +232,18 @@ (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target)))) + (inst cmp value unbound-marker-widetag)))) #!-sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:generator 9 (inst cmp (make-ea-for-object-slot object symbol-value-slot other-pointer-lowtag) - unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target))) + unbound-marker-widetag))) (define-vop (symbol-hash) diff --git a/src/compiler/x86-64/char.lisp b/src/compiler/x86-64/char.lisp index f7ef50271..8e92290db 100644 --- a/src/compiler/x86-64/char.lisp +++ b/src/compiler/x86-64/char.lisp @@ -174,47 +174,41 @@ :load-if (not (and (sc-is x character-reg) (sc-is y character-stack))))) (:arg-types character character) - (:conditional) - (:info target not-p) + (:info) (:policy :fast-safe) (:note "inline comparison") - (:variant-vars condition not-condition) (:generator 3 - (inst cmp x y) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x y))) (define-vop (fast-char=/character character-compare) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character character-compare) (:translate char>) - (:variant :a :na)) + (:conditional :a)) (define-vop (character-compare/c) (:args (x :scs (character-reg character-stack))) (:arg-types character (:constant character)) - (:conditional) - (:info target not-p y) + (:info y) (:policy :fast-safe) (:note "inline constant comparison") - (:variant-vars condition not-condition) (:generator 2 - (inst cmp x (sb!xc:char-code y)) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x (sb!xc:char-code y)))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character/c character-compare/c) (:translate char>) - (:variant :a :na)) + (:conditional :a)) diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index f1b7f4175..b642b5ccb 100644 --- a/src/compiler/x86-64/float.lisp +++ b/src/compiler/x86-64/float.lisp @@ -498,8 +498,6 @@ ;;;; comparison (define-vop (float-compare) - (:conditional) - (:info target not-p) (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only) @@ -511,102 +509,59 @@ (define-vop (single-float-compare float-compare) (:args (x :scs (single-reg)) (y :scs (single-reg))) - (:conditional) (:arg-types single-float single-float)) (define-vop (double-float-compare float-compare) (:args (x :scs (double-reg)) (y :scs (double-reg))) - (:conditional) (:arg-types double-float double-float)) (define-vop (=/single-float single-float-compare) (:translate =) - (:info target not-p) + (:info) + (:conditional not :p :ne) (:vop-var vop) (:generator 3 (note-this-location vop :internal-error) (inst comiss x 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) + (:info) + (:conditional not :p :ne) (:vop-var vop) (:generator 3 (note-this-location vop :internal-error) - (inst comisd x 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)))))) + (inst comisd x y))) (define-vop (double-float double-float-compare) (:translate >) - (:info target not-p) + (:info) + (:conditional not :p :na) (:generator 3 - (inst comisd x 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)))))) + (inst comisd x y))) (define-vop (>single-float single-float-compare) (:translate >) - (:info target not-p) + (:info) + (:conditional not :p :na) (:generator 3 - (inst comiss x 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)))))) + (inst comiss x y))) diff --git a/src/compiler/x86-64/pred.lisp b/src/compiler/x86-64/pred.lisp index 23c932eae..c74ed6012 100644 --- a/src/compiler/x86-64/pred.lisp +++ b/src/compiler/x86-64/pred.lisp @@ -25,17 +25,187 @@ ;;; The generic conditional branch, emitted immediately after test ;;; VOPs that only set flags. +;;; +;;; FLAGS is a list of condition descriptors. If the first descriptor +;;; is CL:NOT, the test was true if all the remaining conditions are +;;; false. Otherwise, the test was true if any of the conditions is. +;;; +;;; NOT-P flips the meaning of the test, as with regular :CONDITIONAL +;;; VOP. If NOT-P is true, the code must branch to dest if the test was +;;; false. Otherwise, the code must branch to dest if the test was true. (define-vop (branch-if) (:info dest flags not-p) - (:ignore dest flags not-p) (:generator 0 - (error "BRANCH-IF not yet implemented"))) + (when (eq (car flags) 'not) + (pop flags) + (setf not-p (not not-p))) + (flet ((negate-condition (name) + (let ((code (logxor 1 (conditional-opcode name)))) + (aref *condition-name-vec* code)))) + (cond ((null (rest flags)) + (inst jmp + (if not-p + (negate-condition (first flags)) + (first flags)) + dest)) + (not-p + (let ((not-lab (gen-label)) + (last (car (last flags)))) + (dolist (flag (butlast flags)) + (inst jmp flag not-lab)) + (inst jmp (negate-condition last) dest) + (emit-label not-lab))) + (t + (dolist (flag flags) + (inst jmp flag dest))))))) + +(defvar *cmov-ptype-representation-vop* + (mapcan (lambda (entry) + (destructuring-bind (ptypes &optional sc vop) + entry + (unless (listp ptypes) + (setf ptypes (list ptypes))) + (mapcar (if (and vop sc) + (lambda (ptype) + (list ptype sc vop)) + #'list) + ptypes))) + '((t descriptor-reg move-if/t) + + ((fixnum positive-fixnum) + any-reg move-if/fx) + ((unsigned-byte-64 unsigned-byte-63) + unsigned-reg move-if/unsigned) + (signed-byte-64 signed-reg move-if/signed) + (character character-reg move-if/char) + + ((single-float complex-single-float + double-float complex-double-float)) + + (system-area-pointer sap-reg move-if/sap))) + "Alist of primitive type -> (storage-class-name VOP-name) + if values of such a type should be cmoved, and NIL otherwise. + + storage-class-name is the name of the storage class to use for + the values, and VOP-name the name of the VOP that will be used + to execute the conditional move.") (!def-vm-support-routine convert-conditional-move-p (node dst-tn x-tn y-tn) - (declare (ignore node dst-tn x-tn y-tn)) - nil) + (declare (ignore node)) + (let* ((ptype (sb!c::tn-primitive-type dst-tn)) + (name (sb!c::primitive-type-name ptype)) + (param (cdr (or (assoc name *cmov-ptype-representation-vop*) + '(t descriptor-reg move-if/t))))) + (when param + (destructuring-bind (representation vop) param + (let ((scn (sc-number-or-lose representation))) + (labels ((make-tn () + (make-representation-tn ptype scn)) + (immediate-tn-p (tn) + (and (eq (sb!c::tn-kind tn) :constant) + (eq (sb!c::immediate-constant-sc (tn-value tn)) + (sc-number-or-lose 'immediate)))) + (frob-tn (tn) + (if (immediate-tn-p tn) + tn + (make-tn)))) + (values vop + (frob-tn x-tn) (frob-tn y-tn) + (make-tn) + nil))))))) + +(define-vop (move-if) + (:args (then) (else)) + (:results (res)) + (:info flags) + (:generator 0 + (let ((not-p (eq (first flags) 'not))) + (when not-p (pop flags)) + (flet ((negate-condition (name) + (let ((code (logxor 1 (conditional-opcode name)))) + (aref *condition-name-vec* code))) + (load-immediate (dst constant-tn + &optional (sc (sc-name (tn-sc dst)))) + (let ((val (tn-value constant-tn))) + (etypecase val + (integer + (if (memq sc '(any-reg descriptor-reg)) + (inst mov dst (fixnumize val)) + (inst mov dst val))) + (symbol + (aver (eq sc 'descriptor-reg)) + (load-symbol dst val)) + (character + (if (eq sc 'descriptor-reg) + (inst mov dst (logior (ash (char-code val) n-widetag-bits) + character-widetag)) + (inst mov dst (char-code val)))))))) + (cond ((null (rest flags)) + (if (sc-is else immediate) + (load-immediate res else) + (move res else)) + (when (sc-is then immediate) + (load-immediate temp-reg-tn then (sc-name (tn-sc res))) + (setf then temp-reg-tn)) + (inst cmov (if not-p + (negate-condition (first flags)) + (first flags)) + res + then)) + (not-p + (cond ((sc-is then immediate) + (when (location= else res) + (inst mov temp-reg-tn else) + (setf else temp-reg-tn)) + (load-immediate res then)) + ((location= else res) + (inst xchg else then) + (rotatef else then)) + (t + (move res then))) + (when (sc-is else immediate) + (load-immediate temp-reg-tn else (sc-name (tn-sc res))) + (setf else temp-reg-tn)) + (dolist (flag flags) + (inst cmov flag res else))) + (t + (if (sc-is else immediate) + (load-immediate res else) + (move res else)) + (when (sc-is then immediate) + (load-immediate temp-reg-tn then (sc-name (tn-sc res))) + (setf then temp-reg-tn)) + (dolist (flag flags) + (inst cmov flag res then)))))))) + +(macrolet ((def-move-if (name type reg &optional stack) + (when stack (setf stack (list stack))) + + `(define-vop (,name move-if) + (:args (then :scs (immediate ,reg ,@stack) :to :eval + :load-if (not (or (sc-is then immediate) + (and (sc-is then ,@stack) + (not (location= else res)))))) + (else :scs (immediate ,reg ,@stack) :target res + :load-if (not (sc-is else immediate ,@stack)))) + (:arg-types ,type ,type) + (:results (res :scs (,reg) + :from (:argument 1))) + (:result-types ,type)))) + (def-move-if move-if/t + t descriptor-reg control-stack) + (def-move-if move-if/fx + tagged-num any-reg control-stack) + (def-move-if move-if/unsigned + unsigned-num unsigned-reg unsigned-stack) + (def-move-if move-if/signed + signed-num signed-reg signed-stack) + (def-move-if move-if/char + character character-reg character-stack) + (def-move-if move-if/sap + system-area-pointer sap-reg sap-stack)) ;;;; conditional VOPs @@ -51,8 +221,7 @@ :load-if (not (and (sc-is x any-reg descriptor-reg immediate) (sc-is y control-stack constant))))) (:temporary (:sc descriptor-reg) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:translate eq) (:generator 3 @@ -95,6 +264,4 @@ (inst cmp y (logior (ash (char-code val) n-widetag-bits) character-widetag)))))) (t - (inst cmp x y))) - - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))))) diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index 450a6a494..491444ed9 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/src/compiler/x86-64/type-vops.lisp @@ -184,10 +184,11 @@ (:arg-types unsigned-num) (:translate fixnump) (:temporary (:sc unsigned-reg) tmp) + (:info) + (:conditional :z) (:generator 5 (inst mov tmp value) - (inst shr tmp n-positive-fixnum-bits) - (inst jmp (if not-p :nz :z) target))) + (inst shr tmp n-positive-fixnum-bits))) ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with ;;; exactly one digit. diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 4731c2653..d557048a2 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1009,8 +1009,7 @@ ;;;; binary conditional VOPs (define-vop (fast-conditional) - (:conditional) - (:info target not-p) + (:conditional :e) (:effects) (:affected) (:policy :fast-safe)) @@ -1026,7 +1025,7 @@ (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant (signed-byte 30))) - (:info target not-p y)) + (:info y)) (define-vop (fast-conditional/signed fast-conditional) (:args (x :scs (signed-reg) @@ -1039,7 +1038,7 @@ (define-vop (fast-conditional-c/signed fast-conditional/signed) (:args (x :scs (signed-reg signed-stack))) (:arg-types signed-num (:constant (signed-byte 32))) - (:info target not-p y)) + (:info y)) (define-vop (fast-conditional/unsigned fast-conditional) (:args (x :scs (unsigned-reg) @@ -1052,7 +1051,7 @@ (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) (:args (x :scs (unsigned-reg unsigned-stack))) (:arg-types unsigned-num (:constant (unsigned-byte 32))) - (:info target not-p y)) + (:info y)) (macrolet ((define-logtest-vops () `(progn @@ -1064,12 +1063,12 @@ `(define-vop (,(symbolicate "FAST-LOGTEST" suffix) ,(symbolicate "FAST-CONDITIONAL" suffix)) (:translate logtest) + (:conditional :ne) (:generator ,cost (emit-optimized-test-inst x ,(if (eq suffix '-c/fixnum) '(fixnumize y) - 'y)) - (inst jmp (if not-p :e :ne) target))))))) + 'y)))))))) (define-logtest-vops)) (defknown %logbitp (integer unsigned-byte) boolean @@ -1082,42 +1081,42 @@ ;;; too much work to do the non-constant case (maybe?) (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum) (:translate %logbitp) + (:conditional :c) (:arg-types tagged-num (:constant (integer 0 29))) (:generator 4 - (inst bt x (+ y n-fixnum-tag-bits)) - (inst jmp (if not-p :nc :c) target))) + (inst bt x (+ y n-fixnum-tag-bits)))) (define-vop (fast-logbitp/signed fast-conditional/signed) (:args (x :scs (signed-reg signed-stack)) (y :scs (signed-reg))) (:translate %logbitp) + (:conditional :c) (:generator 6 - (inst bt x y) - (inst jmp (if not-p :nc :c) target))) + (inst bt x y))) (define-vop (fast-logbitp-c/signed fast-conditional-c/signed) (:translate %logbitp) + (:conditional :c) (:arg-types signed-num (:constant (integer 0 31))) (:generator 5 - (inst bt x y) - (inst jmp (if not-p :nc :c) target))) + (inst bt x y))) (define-vop (fast-logbitp/unsigned fast-conditional/unsigned) (:args (x :scs (unsigned-reg unsigned-stack)) (y :scs (unsigned-reg))) (:translate %logbitp) + (:conditional :c) (:generator 6 - (inst bt x y) - (inst jmp (if not-p :nc :c) target))) + (inst bt x y))) (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned) (:translate %logbitp) + (:conditional :c) (:arg-types unsigned-num (:constant (integer 0 31))) (:generator 5 - (inst bt x y) - (inst jmp (if not-p :nc :c) target))) + (inst bt x y))) -(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned) +(macrolet ((define-conditional-vop (tran cond unsigned) `(progn ,@(mapcar (lambda (suffix cost signed) @@ -1129,31 +1128,25 @@ (format nil "~:@(FAST-CONDITIONAL~A~)" suffix))) (:translate ,tran) + (:conditional ,(if signed + cond + unsigned)) (:generator ,cost (inst cmp x ,(if (eq suffix '-c/fixnum) '(fixnumize y) - 'y)) - (inst jmp (if not-p - ,(if signed - not-cond - not-unsigned) - ,(if signed - cond - unsigned)) - target)))) + 'y))))) '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) '(4 3 6 5 6 5) '(t t t t nil nil))))) - (define-conditional-vop < :l :b :ge :ae) - (define-conditional-vop > :g :a :le :be)) + (define-conditional-vop < :l :b) + (define-conditional-vop > :g :a)) (define-vop (fast-if-eql/signed fast-conditional/signed) (:translate eql) (:generator 6 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) (define-vop (fast-if-eql-c/signed fast-conditional-c/signed) (:translate eql) @@ -1161,14 +1154,12 @@ (cond ((and (sc-is x signed-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x y))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))))) (define-vop (fast-if-eql/unsigned fast-conditional/unsigned) (:translate eql) (:generator 6 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) (:translate eql) @@ -1176,8 +1167,7 @@ (cond ((and (sc-is x unsigned-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x y))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))))) ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a ;;; known fixnum. @@ -1197,8 +1187,7 @@ (:note "inline fixnum comparison") (:translate eql) (:generator 4 - (inst cmp x y) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x y))) (define-vop (generic-eql/fixnum fast-eql/fixnum) (:args (x :scs (any-reg descriptor-reg) :load-if (not (and (sc-is x control-stack) @@ -1210,14 +1199,13 @@ (define-vop (fast-eql-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg control-stack))) (:arg-types tagged-num (:constant (signed-byte 30))) - (:info target not-p y) + (:info y) (:translate eql) (:generator 2 (cond ((and (sc-is x any-reg) (zerop y)) (inst test x x)) ; smaller instruction (t - (inst cmp x (fixnumize y)))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp x (fixnumize y)))))) (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) (:args (x :scs (any-reg descriptor-reg control-stack))) (:arg-types * (:constant (signed-byte 30))) @@ -1478,11 +1466,9 @@ (:policy :fast-safe) (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) - (:conditional) - (:info target not-p) + (:conditional :ns) (:generator 3 - (inst or digit digit) - (inst jmp (if not-p :s :ns) target))) + (inst or digit digit))) ;;; For add and sub with carry the sc of carry argument is any-reg so diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index a049fcdaf..1fa2dcb85 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -196,8 +196,7 @@ (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 (let ((check-unbound-label (gen-label))) @@ -207,21 +206,18 @@ (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target)))) + (inst cmp value unbound-marker-widetag)))) #!-sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:generator 9 (inst cmp (make-ea-for-object-slot object symbol-value-slot other-pointer-lowtag) - unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target))) + unbound-marker-widetag))) (define-vop (symbol-hash) diff --git a/src/compiler/x86/char.lisp b/src/compiler/x86/char.lisp index 39cb78a1f..023067891 100644 --- a/src/compiler/x86/char.lisp +++ b/src/compiler/x86/char.lisp @@ -163,47 +163,40 @@ :load-if (not (and (sc-is x character-reg) (sc-is y character-stack))))) (:arg-types character character) - (:conditional) - (:info target not-p) (:policy :fast-safe) (:note "inline comparison") - (:variant-vars condition not-condition) (:generator 3 - (inst cmp x y) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x y))) (define-vop (fast-char=/character character-compare) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character character-compare) (:translate char>) - (:variant :a :na)) + (:conditional :a)) (define-vop (character-compare/c) (:args (x :scs (character-reg character-stack))) (:arg-types character (:constant character)) - (:conditional) - (:info target not-p y) + (:info y) (:policy :fast-safe) (:note "inline constant comparison") - (:variant-vars condition not-condition) (:generator 2 - (inst cmp x (sb!xc:char-code y)) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x (sb!xc:char-code y)))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character/c character-compare/c) (:translate char>) - (:variant :a :na)) + (:conditional :a)) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index fd69f80bf..9e10b3c9c 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -1182,8 +1182,7 @@ (define-vop (=/float) (:args (x) (y)) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only) @@ -1210,8 +1209,7 @@ (inst fxch x))) (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 - (inst cmp ah-tn #x40) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn #x40))) (define-vop (=/single-float =/float) (:translate =) @@ -1239,8 +1237,7 @@ (:arg-types single-float single-float) (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1280,8 +1277,7 @@ (inst fcom (ea-for-sf-desc y))))) (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 - (inst cmp ah-tn #x01))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn #x01))))) (define-vop (single-float) (:translate >) @@ -1376,8 +1369,7 @@ (:arg-types single-float single-float) (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1417,8 +1409,7 @@ (inst fcom (ea-for-sf-stack y)) (inst fcom (ea-for-sf-desc y))))) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) (define-vop (>double-float) (:translate >) @@ -1427,8 +1418,7 @@ (:arg-types double-float double-float) (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1468,8 +1458,7 @@ (inst fcomd (ea-for-df-stack y)) (inst fcomd (ea-for-df-desc y))))) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) #!+long-float (define-vop (>long-float) @@ -1478,8 +1467,7 @@ (y :scs (long-reg))) (:arg-types long-float long-float) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1503,16 +1491,15 @@ (inst fcomd y) (inst fxch x) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) ;;; Comparisons with 0 can use the FTST instruction. (define-vop (float-test) (:args (x)) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p y) + (:conditional :e) + (:info y) (:variant-vars code) (:policy :fast-safe) (:vop-var vop) @@ -1533,8 +1520,7 @@ (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 (unless (zerop code) - (inst cmp ah-tn code)) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn code)))) (define-vop (=0/single-float float-test) (:translate =) diff --git a/src/compiler/x86/pred.lisp b/src/compiler/x86/pred.lisp index e756b3b37..ce13f2b50 100644 --- a/src/compiler/x86/pred.lisp +++ b/src/compiler/x86/pred.lisp @@ -25,17 +25,146 @@ ;;; The generic conditional branch, emitted immediately after test ;;; VOPs that only set flags. +;;; +;;; FLAGS is a list of condition descriptors. If the first descriptor +;;; is CL:NOT, the test was true if all the remaining conditions are +;;; false. Otherwise, the test was true if any of the conditions is. +;;; +;;; NOT-P flips the meaning of the test, as with regular :CONDITIONAL +;;; VOP. If NOT-P is true, the code must branch to dest if the test was +;;; false. Otherwise, the code must branch to dest if the test was true. (define-vop (branch-if) (:info dest flags not-p) - (:ignore dest flags not-p) (:generator 0 - (error "BRANCH-IF not yet implemented"))) + (flet ((negate-condition (name) + (let ((code (logxor 1 (conditional-opcode name)))) + (aref *condition-name-vec* code)))) + (aver (null (rest flags))) + (inst jmp + (if not-p + (negate-condition (first flags)) + (first flags)) + dest)))) + +(defvar *cmov-ptype-representation-vop* + (mapcan (lambda (entry) + (destructuring-bind (ptypes &optional sc vop) + entry + (unless (listp ptypes) + (setf ptypes (list ptypes))) + (mapcar (if (and vop sc) + (lambda (ptype) + (list ptype sc vop)) + #'list) + ptypes))) + '((t descriptor-reg move-if/t) + + ((fixnum positive-fixnum) + any-reg move-if/fx) + ((unsigned-byte-32 unsigned-byte-31) + unsigned-reg move-if/unsigned) + (signed-byte-32 signed-reg move-if/signed) + (character character-reg move-if/char) + + ((single-float complex-single-float + double-float complex-double-float)) + + (system-area-pointer sap-reg move-if/sap))) + "Alist of primitive type -> (storage-class-name VOP-name) + if values of such a type should be cmoved, and NIL otherwise. + + storage-class-name is the name of the storage class to use for + the values, and VOP-name the name of the VOP that will be used + to execute the conditional move.") (!def-vm-support-routine convert-conditional-move-p (node dst-tn x-tn y-tn) - (declare (ignore node dst-tn x-tn y-tn)) - nil) + (declare (ignore node)) + (let* ((ptype (sb!c::tn-primitive-type dst-tn)) + (name (sb!c::primitive-type-name ptype)) + (param (and (memq :cmov *backend-subfeatures*) + (cdr (or (assoc name *cmov-ptype-representation-vop*) + '(t descriptor-reg move-if/t)))))) + (when param + (destructuring-bind (representation vop) param + (let ((scn (sc-number-or-lose representation))) + (labels ((make-tn () + (make-representation-tn ptype scn)) + (immediate-tn-p (tn) + (and (eq (sb!c::tn-kind tn) :constant) + (eq (sb!c::immediate-constant-sc (tn-value tn)) + (sc-number-or-lose 'immediate)))) + (frob-tn (tn) + (if (immediate-tn-p tn) + tn + (make-tn)))) + (values vop + (frob-tn x-tn) (frob-tn y-tn) + (make-tn) + nil))))))) + +(define-vop (move-if) + (:args (then) (else)) + (:temporary (:sc unsigned-reg :from :eval) temp) + (:results (res)) + (:info flags) + (:generator 0 + (flet ((load-immediate (dst constant-tn + &optional (sc (sc-name (tn-sc dst)))) + (let ((val (tn-value constant-tn))) + (etypecase val + (integer + (if (memq sc '(any-reg descriptor-reg)) + (inst mov dst (fixnumize val)) + (inst mov dst val))) + (symbol + (aver (eq sc 'descriptor-reg)) + (load-symbol dst val)) + (character + (cond ((memq sc '(any-reg descriptor-reg)) + (inst mov dst + (logior (ash (char-code val) n-widetag-bits) + character-widetag))) + (t + (aver (eq sc 'character-reg)) + (inst mov dst (char-code val))))))))) + (aver (null (rest flags))) + (if (sc-is else immediate) + (load-immediate res else) + (move res else)) + (when (sc-is then immediate) + (load-immediate temp then (sc-name (tn-sc res))) + (setf then temp)) + (inst cmov (first flags) res then)))) + +(macrolet ((def-move-if (name type reg &optional stack) + (when stack (setf stack (list stack))) + + `(define-vop (,name move-if) + (:args (then :scs (immediate ,reg ,@stack) :to :eval + :target temp + :load-if (not (or (sc-is then immediate) + (and (sc-is then ,@stack) + (not (location= else res)))))) + (else :scs (immediate ,reg ,@stack) :target res + :load-if (not (sc-is else immediate ,@stack)))) + (:arg-types ,type ,type) + (:results (res :scs (,reg) + :from (:argument 1))) + (:result-types ,type)))) + (def-move-if move-if/t + t descriptor-reg control-stack) + (def-move-if move-if/fx + tagged-num any-reg control-stack) + (def-move-if move-if/unsigned + unsigned-num unsigned-reg unsigned-stack) + (def-move-if move-if/signed + signed-num signed-reg signed-stack) + (def-move-if move-if/char + character character-reg character-stack) + (def-move-if move-if/sap + system-area-pointer sap-reg sap-stack)) ;;;; conditional VOPs @@ -50,8 +179,8 @@ (y :scs (any-reg descriptor-reg immediate) :load-if (not (and (sc-is x any-reg descriptor-reg immediate) (sc-is y control-stack constant))))) - (:conditional) - (:info target not-p) + (:conditional :e) + (:info) (:policy :fast-safe) (:translate eq) (:generator 3 @@ -65,6 +194,4 @@ ;; An encoded value (literal integer) has to be the second argument. ((sc-is x immediate) (inst cmp y x-val)) - (t (inst cmp x y-val)))) - - (inst jmp (if not-p :ne :e) target))) + (t (inst cmp x y-val)))))) diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index d0e5f0e41..9d53fe955 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -207,11 +207,12 @@ (define-vop (fixnump/unsigned-byte-32 simple-type-predicate) (:args (value :scs (unsigned-reg))) + (:info) + (:conditional :be) (:arg-types unsigned-num) (:translate fixnump) (:generator 5 - (inst cmp value #.sb!xc:most-positive-fixnum) - (inst jmp (if not-p :a :be) target))) + (inst cmp value #.sb!xc:most-positive-fixnum))) ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 7dcc18356..165c17bf9 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2690,3 +2690,142 @@ (typep ch 'base-char)) t) t))) + +;;; Attempt to test a decent cross section of conditions +;;; and values types to move conditionally. +(macrolet + ((test-comparison (comparator type x y) + `(progn + ,@(loop for (result-type a b) + in '((nil t nil) + (nil 0 1) + (nil 0.0 1.0) + (nil 0d0 0d0) + (nil 0.0 0d0) + (nil #c(1.0 1.0) #c(2.0 2.0)) + + (t t nil) + (fixnum 0 1) + ((unsigned-byte #.sb-vm:n-word-bits) + (1+ most-positive-fixnum) + (+ 2 most-positive-fixnum)) + ((signed-byte #.sb-vm:n-word-bits) + -1 (* 2 most-negative-fixnum)) + (single-float 0.0 1.0) + (double-float 0d0 1d0)) + for lambda = (if result-type + `(lambda (x y a b) + (declare (,type x y) + (,result-type a b)) + (if (,comparator x y) + a b)) + `(lambda (x y) + (declare (,type x y)) + (if (,comparator x y) + ,a ,b))) + for args = `(,x ,y ,@(and result-type + `(,a ,b))) + collect + `(progn + (eql (funcall (compile nil ',lambda) + ,@args) + (eval '(,lambda ,@args)))))))) + (sb-vm::with-float-traps-masked + (:divide-by-zero :overflow :inexact :invalid) + (let ((sb-ext:*evaluator-mode* :interpret)) + (declare (sb-ext:muffle-conditions style-warning)) + (test-comparison eql t t nil) + (test-comparison eql t t t) + + (test-comparison = t 1 0) + (test-comparison = t 1 1) + (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison = fixnum 1 0) + (test-comparison = fixnum 0 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison = single-float 0.0 1.0) + (test-comparison = single-float 1.0 1.0) + (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison = single-float (/ 1.0 0.0) 1.0) + (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison = single-float (/ 0.0 0.0) 0.0) + + (test-comparison = double-float 0d0 1d0) + (test-comparison = double-float 1d0 1d0) + (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison = double-float (/ 1d0 0d0) 1d0) + (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison = double-float (/ 0d0 0d0) 0d0) + + (test-comparison < t 1 0) + (test-comparison < t 0 1) + (test-comparison < t 1 1) + (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison < fixnum 1 0) + (test-comparison < fixnum 0 1) + (test-comparison < fixnum 0 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison < single-float 0.0 1.0) + (test-comparison < single-float 1.0 0.0) + (test-comparison < single-float 1.0 1.0) + (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison < single-float (/ 1.0 0.0) 1.0) + (test-comparison < single-float 1.0 (/ 1.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) 0.0) + + (test-comparison < double-float 0d0 1d0) + (test-comparison < double-float 1d0 0d0) + (test-comparison < double-float 1d0 1d0) + (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison < double-float (/ 1d0 0d0) 1d0) + (test-comparison < double-float 1d0 (/ 1d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) 0d0) + (test-comparison < double-float 0d0 (/ 0d0 0d0)) + + (test-comparison > t 1 0) + (test-comparison > t 0 1) + (test-comparison > t 1 1) + (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison > fixnum 1 0) + (test-comparison > fixnum 0 1) + (test-comparison > fixnum 0 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison > single-float 0.0 1.0) + (test-comparison > single-float 1.0 0.0) + (test-comparison > single-float 1.0 1.0) + (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison > single-float (/ 1.0 0.0) 1.0) + (test-comparison > single-float 1.0 (/ 1.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) 0.0) + + (test-comparison > double-float 0d0 1d0) + (test-comparison > double-float 1d0 0d0) + (test-comparison > double-float 1d0 1d0) + (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison > double-float (/ 1d0 0d0) 1d0) + (test-comparison > double-float 1d0 (/ 1d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) 0d0) + (test-comparison > double-float 0d0 (/ 0d0 0d0))))) + diff --git a/tests/step.impure.lisp b/tests/step.impure.lisp index ef42033bb..0f5e874be 100644 --- a/tests/step.impure.lisp +++ b/tests/step.impure.lisp @@ -52,21 +52,35 @@ (defun test-step-into () (let* ((results nil) - (expected '(("(< X 2)" :unknown) - ("(- X 1)" :unknown) - ("(FIB (1- X))" (2)) - ("(< X 2)" :unknown) - ("(- X 1)" :unknown) - ("(FIB (1- X))" (1)) - ("(< X 2)" :unknown) - ("(- X 2)" :unknown) - ("(FIB (- X 2))" (0)) - ("(< X 2)" :unknown) - ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) - ("(- X 2)" :unknown) - ("(FIB (- X 2))" (1)) - ("(< X 2)" :unknown) - ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) + ;; The generic-< VOP on x86oids doesn't emit a full call + (expected + #-(or x86 x86-64) + '(("(< X 2)" :unknown) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(< X 2)" :unknown) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (1)) + ("(< X 2)" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (0)) + ("(< X 2)" :unknown) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(< X 2)" :unknown) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)) + #+(or x86 x86-64) + '(("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (1)) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (0)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (*stepper-hook* (lambda (condition) (typecase condition (step-form-condition @@ -79,18 +93,31 @@ (defun test-step-next () (let* ((results nil) - (expected '(("(< X 2)" :unknown) - ("(- X 1)" :unknown) - ("(FIB (1- X))" (2)) - ("(< X 2)" :unknown) - ("(- X 1)" :unknown) - ("(FIB (1- X))" (1)) - ("(- X 2)" :unknown) - ("(FIB (- X 2))" (0)) - ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) - ("(- X 2)" :unknown) - ("(FIB (- X 2))" (1)) - ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) + (expected + #-(or x86 x86-64) + '(("(< X 2)" :unknown) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(< X 2)" :unknown) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (1)) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (0)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)) + #+(or x86 x86-64) + '(("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (1)) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (0)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition @@ -106,14 +133,24 @@ (defun test-step-out () (let* ((results nil) - (expected '(("(< X 2)" :unknown) - ("(- X 1)" :unknown) - ("(FIB (1- X))" (2)) - ("(< X 2)" :unknown) - ("(- X 2)" :unknown) - ("(FIB (- X 2))" (1)) - ("(< X 2)" :unknown) - ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) + (expected + #-(or x86 x86-64) + '(("(< X 2)" :unknown) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(< X 2)" :unknown) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(< X 2)" :unknown) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)) + #+(or x86 x86-64) + '(("(- X 1)" :unknown) + ("(FIB (1- X))" (2)) + ("(- X 1)" :unknown) + ("(FIB (1- X))" (1)) + ("(- X 2)" :unknown) + ("(FIB (- X 2))" (1)) + ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition @@ -129,14 +166,23 @@ (defun test-step-start-from-break () (let* ((results nil) - (expected '(("(- X 2)" :unknown) - ("(FIB-BREAK (- X 2))" (0)) - ("(< X 2)" :unknown) - ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown) - ("(- X 2)" :unknown) - ("(FIB-BREAK (- X 2))" (1)) - ("(< X 2)" :unknown) - ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))) + (expected + #-(or x86 x86-64) + '(("(- X 2)" :unknown) + ("(FIB-BREAK (- X 2))" (0)) + ("(< X 2)" :unknown) + ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB-BREAK (- X 2))" (1)) + ("(< X 2)" :unknown) + ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)) + #+(or x86 x86-64) + '(("(- X 2)" :unknown) + ("(FIB-BREAK (- X 2))" (0)) + ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown) + ("(- X 2)" :unknown) + ("(FIB-BREAK (- X 2))" (1)) + ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))) (count 0) (*stepper-hook* (lambda (condition) (typecase condition @@ -165,7 +211,7 @@ (incf count) (invoke-restart 'step-next))))))) (step (fib 3)) - (assert (= count 6)))) + (assert (= count #-(or x86 x86-64) 6 #+(or x86 x86-64) 5)))) (defun test-step-backtrace () (let* ((*stepper-hook* (lambda (condition) diff --git a/version.lisp-expr b/version.lisp-expr index 63330b310..263560b1c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.24.33" +"1.0.24.35" -- 2.11.4.GIT