Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler/x86-64 move.lisp,1.1.8.1,1.1.8.2 insts.lisp,1.1.8.4,1.1.8.5 vm.lisp,1.2.8.4,1.2.8.5 array.lisp,1.2,1.2.4.1
|
From: Juho S. <js...@us...> - 2004-11-08 17:51:00
|
Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14428/src/compiler/x86-64 Modified Files: Tag: x86-64-again-branch move.lisp insts.lisp vm.lisp array.lisp Log Message: 0.8.15.14.x86-64-again-branch.5: Passes first GC, but with mysterious memory corruption. ... Oops, another try on the immediate 64-bit moves. ... Float arrays use SSE instead of x87. ... Fix a typoed N-WIDETAG-BITS -> N-LOWTAG-BITS in array header generation ... Don't use DEF-FULL-DATA-VECTOR-FROBS for defining (U-B 32) / (S-B 32) vops (assumed that the element size is N-WORD-BYTES) ... Change more x86 cpp conditionals to include x86_64 ... Change more hardcoded 4s to N_WORD_BYTES Index: move.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/move.lisp,v retrieving revision 1.1.8.1 retrieving revision 1.1.8.2 diff -u -d -r1.1.8.1 -r1.1.8.2 --- move.lisp 5 Nov 2004 04:24:17 -0000 1.1.8.1 +++ move.lisp 8 Nov 2004 17:50:41 -0000 1.1.8.2 @@ -77,13 +77,13 @@ (integer (if (and (zerop val) (sc-is y any-reg descriptor-reg)) (inst xor y y) - (inst mov y (fixnumize val)))) + (move-immediate y (fixnumize val)))) (symbol (inst mov y (+ nil-value (static-symbol-offset val)))) (character (inst mov y (logior (ash (char-code val) n-widetag-bits) base-char-widetag))))) - (move y x)))) + (move y x)))) (define-move-vop move :move (any-reg descriptor-reg immediate) @@ -94,6 +94,27 @@ ;;; few of the values in a continuation to fall out. (primitive-type-vop move (:check) t) +(defun move-immediate (target val) + (multiple-value-bind (lo hi) + (dwords-for-quad val) + (cond ((zerop hi) + (inst mov target lo)) + ((< lo (expt 2 31)) + (inst mov target hi) + (inst shl target 32) + (inst or target lo)) + ;; High bit set in lower dword, need to set the high and low + ;; words of separately due to sign extension of the immediate + ;; argument to OR. + (t + (multiple-value-bind (lo-lo lo-hi) + (words-for-dword lo) + (inst mov target hi) + (inst shl target 16) + (inst or target lo-hi) + (inst shl target 16) + (inst or target lo-lo)))))) + ;;; The MOVE-ARG VOP is used for moving descriptor values into ;;; another frame for argument or known value passing. ;;; @@ -115,8 +136,10 @@ (etypecase val ((integer 0 0) (inst xor y y)) - (integer + ((or (signed-byte 29) (unsigned-byte 29)) (inst mov y (fixnumize val))) + (integer + (move-immediate y (fixnumize val))) (symbol (load-symbol y val)) (character Index: insts.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/insts.lisp,v retrieving revision 1.1.8.4 retrieving revision 1.1.8.5 diff -u -d -r1.1.8.4 -r1.1.8.5 --- insts.lisp 5 Nov 2004 04:24:17 -0000 1.1.8.4 +++ insts.lisp 8 Nov 2004 17:50:41 -0000 1.1.8.5 @@ -1028,10 +1028,6 @@ (emit-sized-immediate segment (case size (:qword :dword) (t size)) src)) - ((typep src '(or (signed-byte 64) (unsigned-byte 64))) - (emit-byte segment (+ #xb8 - (logand 8 (ash (tn-offset dst) -1)))) - (emit-sized-immediate segment :qword src t)) (t (aver nil)))) ((register-p src) Index: vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/vm.lisp,v retrieving revision 1.2.8.4 retrieving revision 1.2.8.5 diff -u -d -r1.2.8.4 -r1.2.8.5 --- vm.lisp 7 Nov 2004 05:00:53 -0000 1.2.8.4 +++ vm.lisp 8 Nov 2004 17:50:42 -0000 1.2.8.5 @@ -459,7 +459,12 @@ (defun dwords-for-quad (value) (let* ((lo (logand value (1- (ash 1 32)))) - (hi (ash (- value lo) -32))) + (hi (ash value -32))) + (values lo hi))) + +(defun words-for-dword (value) + (let* ((lo (logand value (1- (ash 1 16)))) + (hi (ash value -16))) (values lo hi))) (def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code Index: array.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/array.lisp,v retrieving revision 1.2 retrieving revision 1.2.4.1 diff -u -d -r1.2 -r1.2.4.1 --- array.lisp 10 Aug 2004 14:20:48 -0000 1.2 +++ array.lisp 8 Nov 2004 17:50:42 -0000 1.2.4.1 @@ -33,7 +33,7 @@ :disp (fixnumize (1- array-dimensions-offset)))) (inst shl header n-widetag-bits) (inst or header type) - (inst shr header (1- n-widetag-bits)) ;XXX was naked 2, am guessing + (inst shr header (1- n-lowtag-bits)) (pseudo-atomic (allocation result bytes node) (inst lea result (make-ea :qword :base result :disp other-pointer-lowtag)) @@ -140,14 +140,14 @@ ,element-type data-vector-set))) ) (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) - (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + #+nil (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num unsigned-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num unsigned-reg) (def-full-data-vector-frobs simple-array-signed-byte-61 tagged-num any-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-60 positive-fixnum any-reg) - (def-full-data-vector-frobs simple-array-signed-byte-32 + #+nil (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg) (def-full-data-vector-frobs simple-array-signed-byte-64 signed-num signed-reg) @@ -303,11 +303,10 @@ (:results (value :scs (single-reg))) (:result-types single-float) (:generator 5 - (with-empty-tn@fp-top(value) - (inst fld (make-ea :dword :base object :index index :scale 1 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag)))))) + (inst movss value (make-ea :dword :base object :index index :scale 1 + :disp (- (* vector-data-offset + n-word-bytes) + other-pointer-lowtag))))) (define-vop (data-vector-ref-c/simple-array-single-float) (:note "inline array access") @@ -319,12 +318,11 @@ (:results (value :scs (single-reg))) (:result-types single-float) (:generator 4 - (with-empty-tn@fp-top(value) - (inst fld (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 4 index)) - other-pointer-lowtag)))))) + (inst movss value (make-ea :dword :base object + :disp (- (+ (* vector-data-offset + n-word-bytes) + (* 4 index)) + other-pointer-lowtag))))) (define-vop (data-vector-set/simple-array-single-float) (:note "inline array store") @@ -337,30 +335,13 @@ (:results (result :scs (single-reg))) (:result-types single-float) (:generator 5 - (cond ((zerop (tn-offset value)) - ;; Value is in ST0. - (inst fst (make-ea :dword :base object :index index :scale 1 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) - (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fst result))) - (t - ;; Value is not in ST0. - (inst fxch value) - (inst fst (make-ea :dword :base object :index index :scale 1 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fst value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fst result)) - (inst fxch value))))))) + (inst movss (make-ea :dword :base object :index index :scale 1 + :disp (- (* vector-data-offset + n-word-bytes) + other-pointer-lowtag)) + value) + (unless (location= result value) + (inst movss result value)))) (define-vop (data-vector-set-c/simple-array-single-float) (:note "inline array store") @@ -374,32 +355,14 @@ (:results (result :scs (single-reg))) (:result-types single-float) (:generator 4 - (cond ((zerop (tn-offset value)) - ;; Value is in ST0. - (inst fst (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 4 index)) - other-pointer-lowtag))) - (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fst result))) - (t - ;; Value is not in ST0. - (inst fxch value) - (inst fst (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 4 index)) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fst value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fst result)) - (inst fxch value))))))) + (inst movss (make-ea :dword :base object + :disp (- (+ (* vector-data-offset + n-word-bytes) + (* 4 index)) + other-pointer-lowtag)) + value) + (unless (location= result value) + (inst movss result value)))) (define-vop (data-vector-ref/simple-array-double-float) (:note "inline array access") @@ -411,11 +374,10 @@ (:results (value :scs (double-reg))) (:result-types double-float) (:generator 7 - (with-empty-tn@fp-top(value) - (inst fldd (make-ea :dword :base object :index index :scale 2 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag)))))) + (inst movsd value (make-ea :dword :base object :index index :scale 2 + :disp (- (* vector-data-offset + n-word-bytes) + other-pointer-lowtag))))) (define-vop (data-vector-ref-c/simple-array-double-float) (:note "inline array access") @@ -427,12 +389,11 @@ (:results (value :scs (double-reg))) (:result-types double-float) (:generator 6 - (with-empty-tn@fp-top(value) - (inst fldd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag)))))) + (inst movsd value (make-ea :dword :base object + :disp (- (+ (* vector-data-offset + n-word-bytes) + (* 8 index)) + other-pointer-lowtag))))) (define-vop (data-vector-set/simple-array-double-float) (:note "inline array store") @@ -445,30 +406,13 @@ (:results (result :scs (double-reg))) (:result-types double-float) (:generator 20 - (cond ((zerop (tn-offset value)) - ;; Value is in ST0. - (inst fstd (make-ea :dword :base object :index index :scale 2 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) - (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fstd result))) - (t - ;; Value is not in ST0. - (inst fxch value) - (inst fstd (make-ea :dword :base object :index index :scale 2 + (inst movsd (make-ea :dword :base object :index index :scale 2 :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fstd value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fstd result)) - (inst fxch value))))))) + other-pointer-lowtag)) + value) + (unless (location= result value) + (inst movsd result value)))) (define-vop (data-vector-set-c/simple-array-double-float) (:note "inline array store") @@ -482,36 +426,17 @@ (:results (result :scs (double-reg))) (:result-types double-float) (:generator 19 - (cond ((zerop (tn-offset value)) - ;; Value is in ST0. - (inst fstd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag))) - (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fstd result))) - (t - ;; Value is not in ST0. - (inst fxch value) - (inst fstd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fstd value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fstd result)) - (inst fxch value))))))) - + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vector-data-offset + n-word-bytes) + (* 8 index)) + other-pointer-lowtag)) + value) + (unless (location= result value) + (inst movsd result value)))) -;;; complex float variants +;;; complex float variants XXX completely broken (define-vop (data-vector-ref/simple-array-complex-single-float) (:note "inline array access") @@ -990,7 +915,8 @@ (:generator 4 (inst movzxd value (make-ea :dword :base object - :disp (- (+ (* vector-data-offset n-word-bytes) (* 4 index)) + :disp (- (+ (* vector-data-offset n-word-bytes) + (* 4 index)) other-pointer-lowtag))))) (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype)) (:translate data-vector-set) |