From 51e63f301624e39febdd85b5feba19b7c980f307 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Sat, 27 Jan 2007 03:45:45 +0000 Subject: [PATCH] 1.0.2.1: DATA-VECTOR-{REF,SET}-WITH-OFFSET for the x86 Compile calls of (AREF FOO (+ INDEX ) more efficiently: ... turn DATA-VECTOR-{REF,SET} into DATA-VECTOR-{REF,SET}-WITH-OFFSET when the element type of FOO is at least 8 bits wide; ... introduce general mechanism for optimization of such calls; ... redo the x86 DATA-VECTOR-FOO VOPs, reducing the number of such VOPs in the process; ... do the same for BIGNUM-REF and SAP-REF-FOO. Upshot: 5-10% increase in performance on array-heavy code such as Ironclad; a 20% increase in performance has been observed on cellular automata codes. Some restrictions apply; see the KLUDGE in src/compiler/generic/vm-tran for an example. --- NEWS | 6 + package-data-list.lisp-expr | 10 +- src/code/bignum.lisp | 2 +- src/code/early-extensions.lisp | 24 + src/compiler/aliencomp.lisp | 4 +- src/compiler/array-tran.lisp | 6 + src/compiler/fndb.lisp | 6 + src/compiler/generic/utils.lisp | 10 + src/compiler/generic/vm-fndb.lisp | 7 + src/compiler/generic/vm-tran.lisp | 130 ++++- src/compiler/ir1opt.lisp | 17 +- src/compiler/ir1util.lisp | 18 +- src/compiler/saptran.lisp | 213 ++++---- src/compiler/x86/arith.lisp | 4 +- src/compiler/x86/array.lisp | 1003 ++++++++----------------------------- src/compiler/x86/macros.lisp | 70 ++- src/compiler/x86/parms.lisp | 6 + src/compiler/x86/sap.lisp | 221 ++++---- version.lisp-expr | 2 +- 19 files changed, 739 insertions(+), 1020 deletions(-) diff --git a/NEWS b/NEWS index 475452a..f04d285 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,10 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.3 relative to sbcl-1.0.2: + * optimization: calls of the form (AREF FOO (+ INDEX )) now + produce more efficient code on the x86 if the compiler can determine + that (+ INDEX ) does not require a bounds check and FOO + has an element type at least 8 bits wide. + changes in sbcl-1.0.2 relative to sbcl-1.0.1: * improvement: experimental support for mach exception handling on x86/macos. requires building with :MACH-EXCEPTION-HANDLER feature diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 580b77f..66adb49 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -159,7 +159,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" :use ("CL" "SB!KERNEL" "SB!INT" "SB!EXT") :export ("%ADD-WITH-CARRY" "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR" - "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-SET" + "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-REF-WITH-OFFSET" + "%BIGNUM-SET" "%BIGNUM-SET-WITH-OFFSET" "%BIGNUM-SET-LENGTH" "%DIGIT-0-OR-PLUSP" "%DIGIT-LOGICAL-SHIFT-RIGHT" "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT" @@ -929,6 +930,7 @@ possibly temporariliy, because it might be used internally." "SIGNED-BYTE-WITH-A-BITE-OUT" "UNSIGNED-BYTE-WITH-A-BITE-OUT" "SFUNCTION" "UNSIGNED-BYTE*" + "CONSTANT-DISPLACEMENT" ;; ..and type predicates "INSTANCEP" "DOUBLE-FLOAT-P" @@ -1222,8 +1224,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "CONTROL-STACK-POINTER-SAP" "COPY-BYTE-VECTOR-TO-SYSTEM-AREA" "CSUBTYPEP" "CTYPE" "TYPE-HASH-VALUE" "CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP" - "CURRENT-DYNAMIC-SPACE-START" "DATA-VECTOR-REF" - "DATA-VECTOR-SET" "DECLARATION-TYPE-CONFLICT-ERROR" + "CURRENT-DYNAMIC-SPACE-START" + "DATA-VECTOR-REF" "DATA-VECTOR-REF-WITH-OFFSET" + "DATA-VECTOR-SET" "DATA-VECTOR-SET-WITH-OFFSET" + "DECLARATION-TYPE-CONFLICT-ERROR" "DECODE-DOUBLE-FLOAT" #!+long-float "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index c07fc19..29a69bc 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -2315,7 +2315,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;;; %FLOOR for machines with a 32x32 divider. -#!-sb-fluid +#!+(and 32x16-divide (not sb-fluid)) (declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry 32x16-divide 32x16-multiply 32x16-multiply-split)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 01bfd6f..2c6263a 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -65,6 +65,30 @@ (* max-offset sb!vm:n-word-bytes)) scale))) +#!+x86 +(defun displacement-bounds (lowtag element-size data-offset) + (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag)) + (bytes-per-element (ceiling element-size sb!vm:n-byte-bits)) + (min (truncate (+ sb!vm::minimum-immediate-offset adjustment) + bytes-per-element)) + (max (truncate (+ sb!vm::maximum-immediate-offset adjustment) + bytes-per-element))) + (values min max))) + +#!+x86 +(def!type constant-displacement (lowtag element-size data-offset) + (flet ((integerify (x) + (etypecase x + (integer x) + (symbol (symbol-value x))))) + (let ((lowtag (integerify lowtag)) + (element-size (integerify element-size)) + (data-offset (integerify data-offset))) + (multiple-value-bind (min max) (displacement-bounds lowtag + element-size + data-offset) + `(integer ,min ,max))))) + ;;; Similar to FUNCTION, but the result type is "exactly" specified: ;;; if it is an object type, then the function returns exactly one ;;; value, if it is a short form of VALUES, then this short form diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 03de07c..cde6288 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -469,7 +469,7 @@ (let ((alien-node (lvar-uses alien))) (typecase alien-node (combination - (extract-fun-args alien '%sap-alien 2) + (splice-fun-args alien '%sap-alien 2) '(lambda (sap type) (declare (ignore type)) sap)) @@ -590,7 +590,7 @@ (unless (and (constant-lvar-p inside-amount) (not (minusp (lvar-value inside-amount)))) (give-up-ir1-transform))) - (extract-fun-args value inside-fun-name 2) + (splice-fun-args value inside-fun-name 2) (if width `(lambda (value amount1 amount2) (logand (ash value (+ amount1 amount2)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index ee40d89..05df30b 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -116,9 +116,15 @@ (extract-upgraded-element-type array)) (defoptimizer (data-vector-ref derive-type) ((array index)) (extract-upgraded-element-type array)) +#!+x86 +(defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset)) + (extract-upgraded-element-type array)) (defoptimizer (data-vector-set derive-type) ((array index new-value)) (assert-new-value-type new-value array)) +#!+x86 +(defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value)) + (assert-new-value-type new-value array)) (defoptimizer (hairy-data-vector-set derive-type) ((array index new-value)) (assert-new-value-type new-value array)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index cbd728e..a902977 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1431,8 +1431,14 @@ (defknown %check-bound (array index fixnum) index (movable foldable flushable)) (defknown data-vector-ref (simple-array index) t (foldable explicit-check always-translatable)) +#!+x86 +(defknown data-vector-ref-with-offset (simple-array index fixnum) t + (foldable explicit-check always-translatable)) (defknown data-vector-set (array index t) t (unsafe explicit-check always-translatable)) +#!+x86 +(defknown data-vector-set-with-offset (array index fixnum t) t + (unsafe explicit-check always-translatable)) (defknown hairy-data-vector-ref (array index) t (foldable explicit-check)) (defknown hairy-data-vector-set (array index t) t (unsafe explicit-check)) diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp index 7095f61..1ebf85d 100644 --- a/src/compiler/generic/utils.lisp +++ b/src/compiler/generic/utils.lisp @@ -17,6 +17,16 @@ (if (fixnump num) (ash num (1- n-lowtag-bits)) (error "~W is too big for a fixnum." num))) + +;;; Determining whether a constant offset fits in an addressing mode. +#!+x86 +(defun foldable-constant-offset-p (element-size lowtag data-offset offset) + (if (< element-size n-byte-bits) + nil + (multiple-value-bind (min max) + (sb!impl::displacement-bounds lowtag element-size data-offset) + (<= min offset max)))) + ;;;; routines for dealing with static symbols diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index f3e5f19..8db4fe6 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -284,10 +284,17 @@ (defknown %bignum-ref (bignum-type bignum-index) bignum-element-type (flushable)) +#!+x86 +(defknown %bignum-ref-with-offset (bignum-type bignum-index (signed-byte 24)) + bignum-element-type (flushable always-translatable)) (defknown %bignum-set (bignum-type bignum-index bignum-element-type) bignum-element-type (unsafe)) +#!+x86 +(defknown %bignum-set-with-offset + (bignum-type bignum-index (signed-byte 24) bignum-element-type) + bignum-element-type (unsafe always-translatable)) (defknown %digit-0-or-plusp (bignum-element-type) boolean (foldable flushable movable)) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index b4b1adb..d616f09 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -32,6 +32,48 @@ (deftransform abs ((x) (rational)) '(if (< x 0) (- x) x)) +;;; We don't want to clutter the bignum code. +#!+x86 +(define-source-transform sb!bignum:%bignum-ref (bignum index) + ;; KLUDGE: We use TRULY-THE here because even though the bignum code + ;; is (currently) compiled with (SAFETY 0), the compiler insists on + ;; inserting CAST nodes to ensure that INDEX is of the correct type. + ;; These CAST nodes do not generate any type checks, but they do + ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below. + ;; This scenario is a problem for the more user-visible case of + ;; folding as well. --njf, 2006-12-01 + `(sb!bignum:%bignum-ref-with-offset ,bignum + (truly-the bignum-index ,index) 0)) + +#!+x86 +(defun fold-index-addressing (fun-name element-size lowtag data-offset + index offset &optional setter-p) + (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2) + (destructuring-bind (x constant) index-args + (declare (ignorable x)) + (unless (constant-lvar-p constant) + (give-up-ir1-transform)) + (let ((value (lvar-value constant))) + (unless (and (integerp value) + (sb!vm::foldable-constant-offset-p + element-size lowtag data-offset + (funcall func value (lvar-value offset)))) + (give-up-ir1-transform "constant is too large for inlining")) + (splice-fun-args index func 2) + (format t "preparing to transform with ~A ~D~%" func value) + `(lambda (thing index off1 off2 ,@(when setter-p + '(value))) + (,fun-name thing index (,func off2 off1) ,@(when setter-p + '(value)))))))) + +#!+x86 +(deftransform sb!bignum:%bignum-ref-with-offset + ((bignum index offset) * * :node node) + (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset + sb!vm:n-word-bits sb!vm:other-pointer-lowtag + sb!vm:bignum-digits-offset + index offset)) + ;;; The layout is stored in slot 0. (define-source-transform %instance-layout (x) `(truly-the layout (%instance-ref ,x 0))) @@ -57,10 +99,13 @@ ;; the other transform will kick in, so that's OK (give-up-ir1-transform) `(etypecase string - ((simple-array character (*)) (data-vector-ref string index)) + ((simple-array character (*)) + (data-vector-ref string index)) #!+sb-unicode - ((simple-array base-char (*)) (data-vector-ref string index)) - ((simple-array nil (*)) (data-vector-ref string index)))))) + ((simple-array base-char (*)) + (data-vector-ref string index)) + ((simple-array nil (*)) + (data-vector-ref string index)))))) (deftransform hairy-data-vector-ref ((array index) (array t) *) "avoid runtime dispatch on array element type" @@ -74,7 +119,7 @@ ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a ;; macro, and macros aren't expanded in transform output, we have ;; to hand-expand it ourselves.) - (let ((element-type-specifier (type-specifier element-ctype))) + (let* ((element-type-specifier (type-specifier element-ctype))) `(multiple-value-bind (array index) (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) @@ -86,8 +131,7 @@ ;;; Transform multi-dimensional array to one dimensional data vector ;;; access. -(deftransform data-vector-ref ((array index) - (simple-array t)) +(deftransform data-vector-ref ((array index) (simple-array t)) (let ((array-type (lvar-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) @@ -103,6 +147,42 @@ (%array-data-vector array)) index))))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. +#!+x86 +(deftransform data-vector-ref ((array index) ((or simple-unboxed-array + simple-vector) + t)) + (let ((array-type (lvar-type array))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) + (saetp (find element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) + (give-up-ir1-transform)) + `(data-vector-ref-with-offset array index 0)))) + +#!+x86 +(deftransform data-vector-ref-with-offset ((array index offset) + ((or simple-unboxed-array + simple-vector) + t t)) + (let ((array-type (lvar-type array))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) + (saetp (find element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (fold-index-addressing 'data-vector-ref-with-offset + (sb!vm:saetp-n-bits saetp) + sb!vm:other-pointer-lowtag + sb!vm:vector-data-offset + index offset)))) + (deftransform hairy-data-vector-set ((string index new-value) (simple-string t t)) (let ((ctype (lvar-type string))) @@ -140,6 +220,8 @@ (the ,(type-specifier declared-element-ctype) new-value)))))))) +;;; Transform multi-dimensional array to one dimensional data vector +;;; access. (deftransform data-vector-set ((array index new-value) (simple-array t t)) (let ((array-type (lvar-type array))) @@ -158,6 +240,42 @@ index new-value))))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. +#!+x86 +(deftransform data-vector-set ((array index new-value) + ((or simple-unboxed-array simple-vector) + t t)) + (let ((array-type (lvar-type array))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) + (saetp (find element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) + (give-up-ir1-transform)) + `(data-vector-set-with-offset array index 0 new-value)))) + +#!+x86 +(deftransform data-vector-set-with-offset ((array index offset new-value) + ((or simple-unboxed-array + simple-vector) + t t t)) + (let ((array-type (lvar-type array))) + (unless (array-type-p array-type) + (give-up-ir1-transform)) + (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) + (saetp (find element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (fold-index-addressing 'data-vector-set-with-offset + (sb!vm:saetp-n-bits saetp) + sb!vm:other-pointer-lowtag + sb!vm:vector-data-offset + index offset t)))) + (defoptimizer (%data-vector-and-index derive-type) ((array index)) (let ((atype (lvar-type array))) (when (array-type-p atype) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index e820b58..314bb79 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1830,6 +1830,17 @@ ;;; TODO: ;;; - CAST chains; +(defun delete-cast (cast) + (declare (type cast cast)) + (let ((value (cast-value cast)) + (lvar (node-lvar cast))) + (delete-filter cast lvar value) + (when lvar + (reoptimize-lvar lvar) + (when (lvar-single-value-p lvar) + (note-single-valuified-lvar lvar))) + (values))) + (defun ir1-optimize-cast (cast &optional do-not-optimize) (declare (type cast cast)) (let ((value (cast-value cast)) @@ -1838,11 +1849,7 @@ (let ((lvar (node-lvar cast))) (when (values-subtypep (lvar-derived-type value) (cast-asserted-type cast)) - (delete-filter cast lvar value) - (when lvar - (reoptimize-lvar lvar) - (when (lvar-single-value-p lvar) - (note-single-valuified-lvar lvar))) + (delete-cast cast) (return-from ir1-optimize-cast t)) (when (and (listp (lvar-uses value)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index bd6357e..9658ac8 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1425,7 +1425,7 @@ ;;; of arguments changes, the transform must be prepared to return a ;;; lambda with a new lambda-list with the correct number of ;;; arguments. -(defun extract-fun-args (lvar fun num-args) +(defun splice-fun-args (lvar fun num-args) #!+sb-doc "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed directly to the LVAR-DEST of LVAR, which must be a @@ -1462,6 +1462,22 @@ (flush-dest lvar) (values)))))) +(defun extract-fun-args (lvar fun num-args) + (declare (type lvar lvar) + (type (or symbol list) fun) + (type index num-args)) + (let ((fun (if (listp fun) fun (list fun)))) + (let ((inside (lvar-uses lvar))) + (unless (combination-p inside) + (give-up-ir1-transform)) + (let ((inside-fun (combination-fun inside))) + (unless (member (lvar-fun-name inside-fun) fun) + (give-up-ir1-transform)) + (let ((inside-args (combination-args inside))) + (unless (= (length inside-args) num-args) + (give-up-ir1-transform)) + (values (lvar-fun-name inside-fun) inside-args)))))) + (defun flush-combination (combination) (declare (type combination combination)) (flush-dest (combination-fun combination)) diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 9f2c643..5ed9b8d 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -52,97 +52,39 @@ (defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits)) system-area-pointer (movable)) -(defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8) - (flushable)) -(defknown %set-sap-ref-8 (system-area-pointer fixnum (unsigned-byte 8)) - (unsigned-byte 8) - ()) +(macrolet ((defsapref (fun value-type) + (let (#!+x86 + (with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))) + (set-fun (intern (format nil "%SET-~A" fun))) + #!+x86 + (set-with-offset-fun (intern (format nil "%SET-~A-WITH-OFFSET" fun)))) + `(progn + (defknown ,fun (system-area-pointer fixnum) ,value-type + (flushable)) + #!+x86 + (defknown ,with-offset-fun (system-area-pointer fixnum fixnum) ,value-type + (flushable always-translatable)) + (defknown ,set-fun (system-area-pointer fixnum ,value-type) ,value-type + ()) + #!+x86 + (defknown ,set-with-offset-fun (system-area-pointer fixnum fixnum ,value-type) ,value-type + (always-translatable)))))) + (defsapref sap-ref-8 (unsigned-byte 8)) + (defsapref sap-ref-16 (unsigned-byte 16)) + (defsapref sap-ref-32 (unsigned-byte 32)) + (defsapref sap-ref-64 (unsigned-byte 64)) + (defsapref sap-ref-word (unsigned-byte #.sb!vm:n-word-bits)) + (defsapref signed-sap-ref-8 (signed-byte 8)) + (defsapref signed-sap-ref-16 (signed-byte 16)) + (defsapref signed-sap-ref-32 (signed-byte 32)) + (defsapref signed-sap-ref-64 (signed-byte 64)) + (defsapref signed-sap-ref-word (signed-byte #.sb!vm:n-word-bits)) + (defsapref sap-ref-sap system-area-pointer) + (defsapref sap-ref-single single-float) + (defsapref sap-ref-double double-float) + (defsapref sap-ref-long long-float) +) ; MACROLET -(defknown sap-ref-16 (system-area-pointer fixnum) (unsigned-byte 16) - (flushable)) -(defknown %set-sap-ref-16 (system-area-pointer fixnum (unsigned-byte 16)) - (unsigned-byte 16) - ()) - -(defknown sap-ref-32 (system-area-pointer fixnum) (unsigned-byte 32) - (flushable)) -(defknown %set-sap-ref-32 (system-area-pointer fixnum (unsigned-byte 32)) - (unsigned-byte 32) - ()) - -;; FIXME These are supported natively on alpha and using deftransforms -;; in compiler/x86/sap.lisp, which in OAO$n$ style need copying to -;; other 32 bit systems -(defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64) - (flushable)) -(defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64)) - (unsigned-byte 64) - ()) - -(defknown sap-ref-word (system-area-pointer fixnum) - (unsigned-byte #.sb!vm::n-machine-word-bits) - (flushable)) -(defknown %set-sap-ref-word - (system-area-pointer fixnum (unsigned-byte #.sb!vm::n-machine-word-bits)) - (unsigned-byte #.sb!vm::n-machine-word-bits) - ()) - -(defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8) - (flushable)) -(defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8)) - (signed-byte 8) - ()) - -(defknown signed-sap-ref-16 (system-area-pointer fixnum) (signed-byte 16) - (flushable)) -(defknown %set-signed-sap-ref-16 (system-area-pointer fixnum (signed-byte 16)) - (signed-byte 16) - ()) - -(defknown signed-sap-ref-32 (system-area-pointer fixnum) (signed-byte 32) - (flushable)) -(defknown %set-signed-sap-ref-32 (system-area-pointer fixnum (signed-byte 32)) - (signed-byte 32) - ()) - -(defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64) - (flushable)) -(defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64)) - (signed-byte 64) - ()) - -(defknown signed-sap-ref-word (system-area-pointer fixnum) - (signed-byte #.sb!vm::n-machine-word-bits) - (flushable)) -(defknown %set-signed-sap-ref-word - (system-area-pointer fixnum (signed-byte #.sb!vm::n-machine-word-bits)) - (signed-byte #.sb!vm::n-machine-word-bits) - ()) - -(defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer - (flushable)) -(defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer) - system-area-pointer - ()) - -(defknown sap-ref-single (system-area-pointer fixnum) single-float - (flushable)) -(defknown sap-ref-double (system-area-pointer fixnum) double-float - (flushable)) -#!+(or x86 long-float) -(defknown sap-ref-long (system-area-pointer fixnum) long-float - (flushable)) - -(defknown %set-sap-ref-single - (system-area-pointer fixnum single-float) single-float - ()) -(defknown %set-sap-ref-double - (system-area-pointer fixnum double-float) double-float - ()) -#!+long-float -(defknown %set-sap-ref-long - (system-area-pointer fixnum long-float) long-float - ()) ;;;; transforms for converting sap relation operators @@ -162,43 +104,66 @@ (eql (lvar-value offset) 0)) 'sap) (t - (extract-fun-args sap 'sap+ 2) + (splice-fun-args sap 'sap+ 2) '(lambda (sap offset1 offset2) (sap+ sap (+ offset1 offset2)))))) -(macrolet ((def (fun &optional setp) - `(deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *) - (extract-fun-args sap 'sap+ 2) - `(lambda (sap offset1 offset2 ,@',(when setp `(new-value))) - (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value))))))) - (def sap-ref-8) - (def %set-sap-ref-8 t) - (def signed-sap-ref-8) - (def %set-signed-sap-ref-8 t) - (def sap-ref-16) - (def %set-sap-ref-16 t) - (def signed-sap-ref-16) - (def %set-signed-sap-ref-16 t) - (def sap-ref-32) - (def %set-sap-ref-32 t) - (def signed-sap-ref-32) - (def %set-signed-sap-ref-32 t) - (def sap-ref-64) - (def %set-sap-ref-64 t) - (def signed-sap-ref-64) - (def %set-signed-sap-ref-64 t) - (def sap-ref-sap) - (def %set-sap-ref-sap t) - (def sap-ref-single) - (def %set-sap-ref-single t) - (def sap-ref-double) - (def %set-sap-ref-double t) - ;; The original CMUCL code had #!+(and x86 long-float) for this first one, - ;; but only #!+long-float for the second. This was redundant, since the - ;; LONG-FLOAT target feature only exists on X86. So we removed the - ;; redundancy. --njf 2002-01-08 - #!+long-float (def sap-ref-long) - #!+long-float (def %set-sap-ref-long t)) +(macrolet ((def (fun element-size &optional setp value-type) + (declare (ignorable value-type)) + `(progn + (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *) + (splice-fun-args sap 'sap+ 2) + `(lambda (sap offset1 offset2 ,@',(when setp `(new-value))) + (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value))))) + ;; Avoid defining WITH-OFFSET transforms for accessors whose + ;; sizes are larger than the word size; they'd probably be + ;; pointless to optimize anyway and tricky to boot. + ,(unless (and (listp value-type) + (or (eq (first value-type) 'unsigned-byte) + (eq (first value-type) 'signed-byte)) + (> (second value-type) sb!vm:n-word-bits)) + #!+x86 + (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun)))) + `(progn + ,(cond + (setp + `(deftransform ,fun ((sap offset new-value) + (system-area-pointer fixnum ,value-type) *) + `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value))) + (t + `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *) + `(,',with-offset-fun sap (truly-the fixnum offset) 0)))) + (deftransform ,with-offset-fun ((sap offset disp + ,@(when setp `(new-value))) * *) + (fold-index-addressing ',with-offset-fun + ,element-size + 0 ; lowtag + 0 ; data offset + offset disp ,setp)))))))) + (def sap-ref-8 8) + (def %set-sap-ref-8 8 t (unsigned-byte 8)) + (def signed-sap-ref-8 8) + (def %set-signed-sap-ref-8 8 t (signed-byte 8)) + (def sap-ref-16 16) + (def %set-sap-ref-16 16 t (unsigned-byte 16)) + (def signed-sap-ref-16 16) + (def %set-signed-sap-ref-16 16 t (signed-byte 16)) + (def sap-ref-32 32) + (def %set-sap-ref-32 32 t (unsigned-byte 32)) + (def signed-sap-ref-32 32) + (def %set-signed-sap-ref-32 32 t (signed-byte 32)) + (def sap-ref-64 64) + (def %set-sap-ref-64 64 t (unsigned-byte 64)) + (def signed-sap-ref-64 64) + (def %set-signed-sap-ref-64 64 t (signed-byte 64)) + (def sap-ref-sap sb!vm:n-word-bits) + (def %set-sap-ref-sap sb!vm:n-word-bits t system-area-pointer) + (def sap-ref-single 32) + (def %set-sap-ref-single 32 t single-float) + (def sap-ref-double 64) + (def %set-sap-ref-double 64 t double-float) + #!+long-float (def sap-ref-long 96) + #!+long-float (def %set-sap-ref-long 96 t 8)) (macrolet ((def (fun args 32-bit 64-bit) `(deftransform ,fun (,args) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 1b29e8d..1380cdb 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1476,7 +1476,9 @@ (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag (unsigned-reg) unsigned-num sb!bignum:%bignum-ref) - +(define-full-reffer+offset bignum-ref-with-offset * + bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum:%bignum-ref-with-offset) (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag (unsigned-reg) unsigned-num sb!bignum:%bignum-set) diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index 40926d7..d07ec98 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -132,12 +132,12 @@ ;;; out of 8, 16, or 32 bit elements. (macrolet ((def-full-data-vector-frobs (type element-type &rest scs) `(progn - (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) + (define-full-reffer+offset ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type) ,type vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-ref) - (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) + ,element-type data-vector-ref-with-offset) + (define-full-setter+offset ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" type) ,type vector-data-offset other-pointer-lowtag ,scs - ,element-type data-vector-set)))) + ,element-type data-vector-set-with-offset)))) (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num unsigned-reg) @@ -146,7 +146,10 @@ (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num - unsigned-reg)) + unsigned-reg) + #!+sb-unicode + (def-full-data-vector-frobs simple-character-string character character-reg)) + ;;;; integer vectors whose elements are smaller than a byte, i.e., ;;;; bit, 2-bit, and 4-bit vectors @@ -299,213 +302,114 @@ ;;; And the float variants. -(define-vop (data-vector-ref/simple-array-single-float) +(defun make-ea-for-float-ref (object index offset element-size + &key (scale 1) (complex-offset 0)) + (sc-case index + (immediate + (make-ea :dword :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (* element-size (+ offset complex-offset + (tn-value index))) + other-pointer-lowtag)))) + (t + (make-ea :dword :base object :index index :scale scale + :disp (- (+ (* vector-data-offset n-word-bytes) + (* element-size offset) + complex-offset) + other-pointer-lowtag))))) + +(define-vop (data-vector-ref-with-offset/simple-array-single-float) (:note "inline array access") - (:translate data-vector-ref) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-single-float positive-fixnum) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 4 vector-data-offset))) (: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)))))) - -(define-vop (data-vector-ref-c/simple-array-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-single-float (:constant (signed-byte 30))) - (: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)))))) - -(define-vop (data-vector-set/simple-array-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg) :target result)) - (:arg-types simple-array-single-float positive-fixnum single-float) - (: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 fld (make-ea-for-float-ref object index offset 4))))) -(define-vop (data-vector-set-c/simple-array-single-float) +(define-vop (data-vector-set-with-offset/simple-array-single-float) (:note "inline array store") - (:translate data-vector-set) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) (value :scs (single-reg) :target result)) - (:info index) - (:arg-types simple-array-single-float (:constant (signed-byte 30)) + (:info offset) + (:arg-types simple-array-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 4 vector-data-offset)) single-float) (:results (result :scs (single-reg))) (:result-types single-float) - (:generator 4 + (:generator 5 (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))) + (inst fst (make-ea-for-float-ref object index offset 4)) (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fst 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))) + (inst fst (make-ea-for-float-ref object index offset 4)) (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 fst result)) (inst fxch value))))))) -(define-vop (data-vector-ref/simple-array-double-float) +(define-vop (data-vector-ref-with-offset/simple-array-double-float) (:note "inline array access") - (:translate data-vector-ref) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-double-float positive-fixnum) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-double-float + positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset))) (: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 fldd (make-ea-for-float-ref object index offset 8 :scale 2))))) -(define-vop (data-vector-ref-c/simple-array-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-double-float (:constant (signed-byte 30))) - (: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)))))) - -(define-vop (data-vector-set/simple-array-double-float) +(define-vop (data-vector-set-with-offset/simple-array-double-float) (:note "inline array store") - (:translate data-vector-set) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (double-reg) :target result)) - (:arg-types simple-array-double-float positive-fixnum double-float) - (: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 - :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))))))) - -(define-vop (data-vector-set-c/simple-array-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (double-reg) :target result)) - (:info index) - (:arg-types simple-array-double-float (:constant (signed-byte 30)) + (:info offset) + (:arg-types simple-array-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset)) double-float) (:results (result :scs (double-reg))) (:result-types double-float) - (:generator 19 + (:generator 20 (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))) + (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2)) (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))) + (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2)) (cond ((zerop (tn-offset result)) ;; The result is in ST0. (inst fstd value)) @@ -515,66 +419,41 @@ (inst fstd result)) (inst fxch value))))))) - - ;;; complex float variants -(define-vop (data-vector-ref/simple-array-complex-single-float) +(define-vop (data-vector-ref-with-offset/simple-array-complex-single-float) (:note "inline array access") - (:translate data-vector-ref) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-complex-single-float positive-fixnum) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-complex-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset))) (:results (value :scs (complex-single-reg))) (:result-types complex-single-float) (:generator 5 (let ((real-tn (complex-single-reg-real-tn value))) (with-empty-tn@fp-top (real-tn) - (inst fld (make-ea :dword :base object :index index :scale 2 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))))) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (with-empty-tn@fp-top (imag-tn) - (inst fld (make-ea :dword :base object :index index :scale 2 - :disp (- (* (1+ vector-data-offset) - n-word-bytes) - other-pointer-lowtag))))))) - -(define-vop (data-vector-ref-c/simple-array-complex-single-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))) - (:results (value :scs (complex-single-reg))) - (:result-types complex-single-float) - (:generator 4 - (let ((real-tn (complex-single-reg-real-tn value))) - (with-empty-tn@fp-top (real-tn) - (inst fld (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag))))) + (inst fld (make-ea-for-float-ref object index offset 8 :scale 2)))) (let ((imag-tn (complex-single-reg-imag-tn value))) (with-empty-tn@fp-top (imag-tn) - (inst fld (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index) 4) - other-pointer-lowtag))))))) + ;; FIXME + (inst fld (make-ea-for-float-ref object index offset 8 + :scale 2 :complex-offset 4)))))) -(define-vop (data-vector-set/simple-array-complex-single-float) +(define-vop (data-vector-set-with-offset/simple-array-complex-single-float) (:note "inline array store") - (:translate data-vector-set) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (complex-single-reg) :target result)) + (:info offset) (:arg-types simple-array-complex-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset)) complex-single-float) (:results (result :scs (complex-single-reg))) (:result-types complex-single-float) @@ -583,20 +462,14 @@ (result-real (complex-single-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) ;; Value is in ST0. - (inst fst (make-ea :dword :base object :index index :scale 2 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) + (inst fst (make-ea-for-float-ref object index offset 8 :scale 2)) (unless (zerop (tn-offset result-real)) ;; Value is in ST0 but not result. (inst fst result-real))) (t ;; Value is not in ST0. (inst fxch value-real) - (inst fst (make-ea :dword :base object :index index :scale 2 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) + (inst fst (make-ea-for-float-ref object index offset 8 :scale 2)) (cond ((zerop (tn-offset result-real)) ;; The result is in ST0. (inst fst value-real)) @@ -608,125 +481,44 @@ (let ((value-imag (complex-single-reg-imag-tn value)) (result-imag (complex-single-reg-imag-tn result))) (inst fxch value-imag) - (inst fst (make-ea :dword :base object :index index :scale 2 - :disp (- (+ (* vector-data-offset - n-word-bytes) - 4) - other-pointer-lowtag))) + (inst fst (make-ea-for-float-ref object index offset 8 + :scale 2 :complex-offset 4)) (unless (location= value-imag result-imag) (inst fst result-imag)) (inst fxch value-imag)))) -(define-vop (data-vector-set-c/simple-array-complex-single-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (complex-single-reg) :target result)) - (:info index) - (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)) - complex-single-float) - (:results (result :scs (complex-single-reg))) - (:result-types complex-single-float) - (:generator 4 - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0. - (inst fst (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag))) - (unless (zerop (tn-offset result-real)) - ;; Value is in ST0 but not result. - (inst fst result-real))) - (t - ;; Value is not in ST0. - (inst fxch value-real) - (inst fst (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index)) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result-real)) - ;; The result is in ST0. - (inst fst value-real)) - (t - ;; Neither value or result are in ST0 - (unless (location= value-real result-real) - (inst fst result-real)) - (inst fxch value-real)))))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst fxch value-imag) - (inst fst (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 8 index) 4) - other-pointer-lowtag))) - (unless (location= value-imag result-imag) - (inst fst result-imag)) - (inst fxch value-imag)))) - - -(define-vop (data-vector-ref/simple-array-complex-double-float) +(define-vop (data-vector-ref-with-offset/simple-array-complex-double-float) (:note "inline array access") - (:translate data-vector-ref) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) - (:arg-types simple-array-complex-double-float positive-fixnum) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-complex-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 16 vector-data-offset))) (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) (:generator 7 (let ((real-tn (complex-double-reg-real-tn value))) (with-empty-tn@fp-top (real-tn) - (inst fldd (make-ea :dword :base object :index index :scale 4 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))))) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (with-empty-tn@fp-top (imag-tn) - (inst fldd (make-ea :dword :base object :index index :scale 4 - :disp (- (+ (* vector-data-offset - n-word-bytes) - 8) - other-pointer-lowtag))))))) - -(define-vop (data-vector-ref-c/simple-array-complex-double-float) - (:note "inline array access") - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))) - (:results (value :scs (complex-double-reg))) - (:result-types complex-double-float) - (:generator 6 - (let ((real-tn (complex-double-reg-real-tn value))) - (with-empty-tn@fp-top (real-tn) - (inst fldd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 16 index)) - other-pointer-lowtag))))) + (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4))) (let ((imag-tn (complex-double-reg-imag-tn value))) (with-empty-tn@fp-top (imag-tn) - (inst fldd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 16 index) 8) - other-pointer-lowtag))))))) + (inst fldd (make-ea-for-float-ref object index offset 16 + :scale 4 :complex-offset 8))))))) -(define-vop (data-vector-set/simple-array-complex-double-float) +(define-vop (data-vector-set-with-offset/simple-array-complex-double-float) (:note "inline array store") - (:translate data-vector-set) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (complex-double-reg) :target result)) + (:info offset) (:arg-types simple-array-complex-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 16 vector-data-offset)) complex-double-float) (:results (result :scs (complex-double-reg))) (:result-types complex-double-float) @@ -735,72 +527,16 @@ (result-real (complex-double-reg-real-tn result))) (cond ((zerop (tn-offset value-real)) ;; Value is in ST0. - (inst fstd (make-ea :dword :base object :index index :scale 4 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) - (unless (zerop (tn-offset result-real)) - ;; Value is in ST0 but not result. - (inst fstd result-real))) - (t - ;; Value is not in ST0. - (inst fxch value-real) - (inst fstd (make-ea :dword :base object :index index :scale 4 - :disp (- (* vector-data-offset - n-word-bytes) - other-pointer-lowtag))) - (cond ((zerop (tn-offset result-real)) - ;; The result is in ST0. - (inst fstd value-real)) - (t - ;; Neither value or result are in ST0 - (unless (location= value-real result-real) - (inst fstd result-real)) - (inst fxch value-real)))))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst fxch value-imag) - (inst fstd (make-ea :dword :base object :index index :scale 4 - :disp (- (+ (* vector-data-offset - n-word-bytes) - 8) - other-pointer-lowtag))) - (unless (location= value-imag result-imag) - (inst fstd result-imag)) - (inst fxch value-imag)))) - -(define-vop (data-vector-set-c/simple-array-complex-double-float) - (:note "inline array store") - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs (complex-double-reg) :target result)) - (:info index) - (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)) - complex-double-float) - (:results (result :scs (complex-double-reg))) - (:result-types complex-double-float) - (:generator 19 - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (cond ((zerop (tn-offset value-real)) - ;; Value is in ST0. - (inst fstd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 16 index)) - other-pointer-lowtag))) + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4)) (unless (zerop (tn-offset result-real)) ;; Value is in ST0 but not result. (inst fstd result-real))) (t ;; Value is not in ST0. (inst fxch value-real) - (inst fstd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 16 index)) - other-pointer-lowtag))) + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4)) (cond ((zerop (tn-offset result-real)) ;; The result is in ST0. (inst fstd value-real)) @@ -812,450 +548,151 @@ (let ((value-imag (complex-double-reg-imag-tn value)) (result-imag (complex-double-reg-imag-tn result))) (inst fxch value-imag) - (inst fstd (make-ea :dword :base object - :disp (- (+ (* vector-data-offset - n-word-bytes) - (* 16 index) 8) - other-pointer-lowtag))) + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4 :complex-offset 8)) (unless (location= value-imag result-imag) (inst fstd result-imag)) (inst fxch value-imag)))) - - -;;; unsigned-byte-8 -(macrolet ((define-data-vector-frobs (ptype) +;;; {un,}signed-byte-8, simple-base-string + +(macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs) `(progn - (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype)) - (:translate data-vector-ref) + (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype)) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,ptype positive-fixnum) - (:results (value :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) + (index :scs (unsigned-reg immediate))) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 1 vector-data-offset))) + (:results (value :scs ,scs)) + (:result-types ,element-type) (:generator 5 - (inst movzx value - (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,ptype (:constant (signed-byte 30))) - (:results (value :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) - (:generator 4 - (inst movzx value - (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag))))) - (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype)) - (:translate data-vector-set) + (sc-case index + (immediate + (inst ,ref-inst value + (make-ea :byte :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (tn-value index) + offset) + other-pointer-lowtag)))) + (t + (inst ,ref-inst value + (make-ea :byte :base object :index index :scale 1 + :disp (- (+ (* vector-data-offset n-word-bytes) + offset) + other-pointer-lowtag))))))) + (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype)) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (unsigned-reg signed-reg) :target eax)) - (:arg-types ,ptype positive-fixnum positive-fixnum) + (index :scs (unsigned-reg immediate) :to (:eval 0)) + (value :scs ,scs :target eax)) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 1 vector-data-offset)) + ,element-type) (:temporary (:sc unsigned-reg :offset eax-offset :target result :from (:argument 2) :to (:result 0)) eax) - (:results (result :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) + (:results (result :scs ,scs)) + (:result-types ,element-type) (:generator 5 (move eax value) - (inst mov (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - al-tn) - (move result eax))) - (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (unsigned-reg signed-reg) :target eax)) - (:info index) - (:arg-types ,ptype (:constant (signed-byte 30)) - positive-fixnum) - (:temporary (:sc unsigned-reg :offset eax-offset :target result - :from (:argument 1) :to (:result 0)) - eax) - (:results (result :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) - (:generator 4 - (move eax value) - (inst mov (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag)) - al-tn) + (sc-case index + (immediate + (inst mov (make-ea :byte :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (tn-value index) + offset) + other-pointer-lowtag)) + al-tn)) + (t + (inst mov (make-ea :byte :base object :index index :scale 1 + :disp (- (+ (* vector-data-offset n-word-bytes) + offset) + other-pointer-lowtag)) + al-tn))) (move result eax)))))) - (define-data-vector-frobs simple-array-unsigned-byte-7) - (define-data-vector-frobs simple-array-unsigned-byte-8)) - -;;; unsigned-byte-16 -(macrolet ((define-data-vector-frobs (ptype) + (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-signed-byte-8 tagged-num + movsx signed-reg) + (define-data-vector-frobs simple-base-string character movzx character-reg)) + +;;; {un,}signed-byte-16 +(macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs) `(progn - (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype)) - (:translate data-vector-ref) + (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype)) + (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,ptype positive-fixnum) - (:results (value :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) + (index :scs (unsigned-reg immediate))) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 2 vector-data-offset))) + (:results (value :scs ,scs)) + (:result-types ,element-type) (:generator 5 - (inst movzx value - (make-ea :word :base object :index index :scale 2 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype)) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,ptype (:constant (signed-byte 30))) - (:results (value :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) - (:generator 4 - (inst movzx value - (make-ea :word :base object - :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index)) - other-pointer-lowtag))))) - (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype)) - (:translate data-vector-set) + (sc-case index + (immediate + (inst ,ref-inst value + (make-ea :word :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (* 2 (+ offset (tn-value index))) + other-pointer-lowtag))))) + (t + (inst ,ref-inst value + (make-ea :word :base object :index index :scale 2 + :disp (- (+ (* vector-data-offset n-word-bytes) + (* 2 offset)) + other-pointer-lowtag))))))) + (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype)) + (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (unsigned-reg signed-reg) :target eax)) - (:arg-types ,ptype positive-fixnum positive-fixnum) + (index :scs (unsigned-reg immediate) :to (:eval 0)) + (value :scs ,scs :target eax)) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 2 vector-data-offset)) + ,element-type) (:temporary (:sc unsigned-reg :offset eax-offset :target result :from (:argument 2) :to (:result 0)) eax) - (:results (result :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) + (:results (result :scs ,scs)) + (:result-types ,element-type) (:generator 5 (move eax value) - (inst mov (make-ea :word :base object :index index :scale 2 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - ax-tn) - (move result eax))) - - (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype)) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (unsigned-reg signed-reg) :target eax)) - (:info index) - (:arg-types ,ptype (:constant (signed-byte 30)) - positive-fixnum) - (:temporary (:sc unsigned-reg :offset eax-offset :target result - :from (:argument 1) :to (:result 0)) - eax) - (:results (result :scs (unsigned-reg signed-reg))) - (:result-types positive-fixnum) - (:generator 4 - (move eax value) - (inst mov (make-ea :word :base object - :disp (- (+ (* vector-data-offset n-word-bytes) - (* 2 index)) - other-pointer-lowtag)) - ax-tn) + (sc-case index + (immediate + (inst mov (make-ea :word :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (* 2 (+ offset (tn-value index)))) + other-pointer-lowtag)) + ax-tn)) + (t + (inst mov (make-ea :word :base object :index index :scale 2 + :disp (- (+ (* vector-data-offset n-word-bytes) + (* 2 offset)) + other-pointer-lowtag)) + ax-tn))) (move result eax)))))) - (define-data-vector-frobs simple-array-unsigned-byte-15) - (define-data-vector-frobs simple-array-unsigned-byte-16)) - -;;; simple-string - -#!+sb-unicode -(progn -(define-vop (data-vector-ref/simple-base-string) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types simple-base-string positive-fixnum) - (:results (value :scs (character-reg))) - (:result-types character) - (:generator 5 - (inst movzx value - (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - -(define-vop (data-vector-ref-c/simple-base-string) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-base-string (:constant (signed-byte 30))) - (:results (value :scs (character-reg))) - (:result-types character) - (:generator 4 - (inst movzx value - (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag))))) - -(define-vop (data-vector-set/simple-base-string) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (character-reg) :target eax)) - (:arg-types simple-base-string positive-fixnum character) - (:temporary (:sc character-reg :offset eax-offset :target result - :from (:argument 2) :to (:result 0)) - eax) - (:results (result :scs (character-reg))) - (:result-types character) - (:generator 5 - (move eax value) - (inst mov (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - al-tn) - (move result eax))) - -(define-vop (data-vector-set-c/simple-base-string) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (character-reg))) - (:info index) - (:arg-types simple-base-string (:constant (signed-byte 30)) character) - (:temporary (:sc unsigned-reg :offset eax-offset :target result - :from (:argument 1) :to (:result 0)) - eax) - (:results (result :scs (character-reg))) - (:result-types character) - (:generator 4 - (move eax value) - (inst mov (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag)) - al-tn) - (move result eax))) -) ; PROGN - -#!-sb-unicode -(progn -(define-vop (data-vector-ref/simple-base-string) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types simple-base-string positive-fixnum) - (:results (value :scs (character-reg))) - (:result-types character) - (:generator 5 - (inst mov value - (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - -(define-vop (data-vector-ref-c/simple-base-string) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-base-string (:constant (signed-byte 30))) - (:results (value :scs (character-reg))) - (:result-types character) - (:generator 4 - (inst mov value - (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag))))) + (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-signed-byte-16 tagged-num + movsx signed-reg)) -(define-vop (data-vector-set/simple-base-string) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (character-reg) :target result)) - (:arg-types simple-base-string positive-fixnum character) - (:results (result :scs (character-reg))) - (:result-types character) - (:generator 5 - (inst mov (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - value) - (move result value))) - -(define-vop (data-vector-set-c/simple-base-string) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (character-reg))) - (:info index) - (:arg-types simple-base-string (:constant (signed-byte 30)) character) - (:results (result :scs (character-reg))) - (:result-types character) - (:generator 4 - (inst mov (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag)) - value) - (move result value))) -) ; PROGN - -#!+sb-unicode -(define-full-reffer data-vector-ref/simple-character-string - simple-character-string vector-data-offset other-pointer-lowtag - (character-reg) character data-vector-ref) -#!+sb-unicode -(define-full-setter data-vector-set/simple-character-string - simple-character-string vector-data-offset other-pointer-lowtag - (character-reg) character data-vector-set) - -;;; signed-byte-8 - -(define-vop (data-vector-ref/simple-array-signed-byte-8) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types simple-array-signed-byte-8 positive-fixnum) - (:results (value :scs (signed-reg))) - (:result-types tagged-num) - (:generator 5 - (inst movsx value - (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - -(define-vop (data-vector-ref-c/simple-array-signed-byte-8) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))) - (:results (value :scs (signed-reg))) - (:result-types tagged-num) - (:generator 4 - (inst movsx value - (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag))))) - -(define-vop (data-vector-set/simple-array-signed-byte-8) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (signed-reg) :target eax)) - (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num) - (:temporary (:sc unsigned-reg :offset eax-offset :target result - :from (:argument 2) :to (:result 0)) - eax) - (:results (result :scs (signed-reg))) - (:result-types tagged-num) - (:generator 5 - (move eax value) - (inst mov (make-ea :byte :base object :index index :scale 1 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - al-tn) - (move result eax))) - -(define-vop (data-vector-set-c/simple-array-signed-byte-8) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (signed-reg) :target eax)) - (:info index) - (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)) - tagged-num) - (:temporary (:sc unsigned-reg :offset eax-offset :target result - :from (:argument 1) :to (:result 0)) - eax) - (:results (result :scs (signed-reg))) - (:result-types tagged-num) - (:generator 4 - (move eax value) - (inst mov (make-ea :byte :base object - :disp (- (+ (* vector-data-offset n-word-bytes) index) - other-pointer-lowtag)) - al-tn) - (move result eax))) - -;;; signed-byte-16 - -(define-vop (data-vector-ref/simple-array-signed-byte-16) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types simple-array-signed-byte-16 positive-fixnum) - (:results (value :scs (signed-reg))) - (:result-types tagged-num) - (:generator 5 - (inst movsx value - (make-ea :word :base object :index index :scale 2 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))))) - -(define-vop (data-vector-ref-c/simple-array-signed-byte-16) - (:translate data-vector-ref) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30))) - (:results (value :scs (signed-reg))) - (:result-types tagged-num) - (:generator 4 - (inst movsx value - (make-ea :word :base object - :disp (- (+ (* vector-data-offset n-word-bytes) - (* 2 index)) - other-pointer-lowtag))))) - -(define-vop (data-vector-set/simple-array-signed-byte-16) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg) :to (:eval 0)) - (value :scs (signed-reg) :target eax)) - (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num) - (:temporary (:sc signed-reg :offset eax-offset :target result - :from (:argument 2) :to (:result 0)) - eax) - (:results (result :scs (signed-reg))) - (:result-types tagged-num) - (:generator 5 - (move eax value) - (inst mov (make-ea :word :base object :index index :scale 2 - :disp (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - ax-tn) - (move result eax))) - -(define-vop (data-vector-set-c/simple-array-signed-byte-16) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:eval 0)) - (value :scs (signed-reg) :target eax)) - (:info index) - (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num) - (:temporary (:sc signed-reg :offset eax-offset :target result - :from (:argument 1) :to (:result 0)) - eax) - (:results (result :scs (signed-reg))) - (:result-types tagged-num) - (:generator 4 - (move eax value) - (inst mov - (make-ea :word :base object - :disp (- (+ (* vector-data-offset n-word-bytes) - (* 2 index)) - other-pointer-lowtag)) - ax-tn) - (move result eax))) ;;; These vops are useful for accessing the bits of a vector ;;; irrespective of what type of vector it is. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index f42bcc3..dba9b91 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -393,7 +393,7 @@ `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg immediate))) + (index :scs (any-reg immediate unsigned-reg))) (:arg-types ,type tagged-num) (:results (value :scs ,scs)) (:result-types ,el-type) @@ -404,11 +404,50 @@ :disp (- (* (+ ,offset (tn-value index)) n-word-bytes) ,lowtag)))) + (unsigned-reg + (inst mov value (make-ea :dword :base object :index index :scale 4 + :disp (- (* ,offset n-word-bytes) + ,lowtag)))) (t (inst mov value (make-ea :dword :base object :index index :disp (- (* ,offset n-word-bytes) ,lowtag))))))))) +(defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate unsigned-reg))) + (:arg-types ,type tagged-num + (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset))) + (:info offset) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + (unless (zerop offset) + (format t "Attempting D-F-R-O, offset ~D~%" offset)) + (sc-case index + (immediate + (inst mov value (make-ea :dword :base object + :disp (- (* (+ ,offset + (tn-value index) + offset) + n-word-bytes) + ,lowtag)))) + (unsigned-reg + (inst mov value (make-ea :dword :base object :index index :scale 4 + :disp (- (* (+ ,offset offset) + n-word-bytes) + ,lowtag)))) + (t + (inst mov value (make-ea :dword :base object :index index + :disp (- (* (+ ,offset offset) + n-word-bytes) + ,lowtag))))))))) + (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) `(progn (define-vop (,name) @@ -435,6 +474,35 @@ value))) (move result value))))) +(defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs ,scs :target result)) + (:info offset) + (:arg-types ,type tagged-num + (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset)) ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (sc-case index + (immediate + (inst mov (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index) offset) + n-word-bytes) + ,lowtag)) + value)) + (t + (inst mov (make-ea :dword :base object :index index + :disp (- (* (+ ,offset offset) + n-word-bytes) ,lowtag)) + value))) + (move result value))))) + ;;; helper for alien stuff. (defmacro with-pinned-objects ((&rest objects) &body body) "Arrange with the garbage collector that the pages occupied by diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index e6cde61..6e34325 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -35,6 +35,12 @@ ;;; addressable object (def!constant n-byte-bits 8) +;;; The minimum immediate offset in a memory-referencing instruction. +(def!constant minimum-immediate-offset (- (expt 2 31))) + +;;; The maximum immediate offset in a memory-referencing instruction. +(def!constant maximum-immediate-offset (1- (expt 2 31))) + (def!constant float-sign-shift 31) ;;; comment from CMU CL: diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp index b1454a0..3f5ae15 100644 --- a/src/compiler/x86/sap.lisp +++ b/src/compiler/x86/sap.lisp @@ -150,16 +150,22 @@ type size &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C")) - (temp-sc (symbolicate size "-REG"))) + (let ((temp-sc (symbolicate size "-REG")) + (element-size (ecase size + (:byte 1) + (:word 2) + (:dword 4)))) `(progn (define-vop (,ref-name) (:translate ,ref-name) (:policy :fast-safe) (:args (sap :scs (sap-reg)) (offset :scs (signed-reg immediate))) - (:arg-types system-area-pointer signed-num) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + ,element-size + 0))) (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 @@ -171,10 +177,12 @@ (immediate (inst ,mov-inst result (make-ea ,size :base sap - :disp (tn-value offset)))) + :disp (+ (tn-value offset) + (* ,element-size disp))))) (t (inst ,mov-inst result (make-ea ,size :base sap - :index offset))))))) + :index offset + :disp (* ,element-size disp)))))))) (define-vop (,set-name) (:translate ,set-name) (:policy :fast-safe) @@ -184,7 +192,12 @@ :target ,(if (eq size :dword) 'result 'temp))) - (:arg-types system-area-pointer signed-num ,type) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + ,element-size + 0)) + ,type) ,@(unless (eq size :dword) `((:temporary (:sc ,temp-sc :offset eax-offset :from (:argument 2) :to (:result 0) @@ -193,105 +206,118 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 - ,@(unless (eq size :dword) - `((move eax-tn value))) - (inst mov (sc-case offset - (immediate - (make-ea ,size :base sap - :disp (tn-value offset))) - (t (make-ea ,size - :base sap - :index offset))) - ,(if (eq size :dword) 'value 'temp)) - (move result - ,(if (eq size :dword) 'value 'eax-tn)))))))) + ,@(unless (eq size :dword) + `((move eax-tn value))) + (inst mov (sc-case offset + (immediate + (make-ea ,size :base sap + :disp (+ (tn-value offset) + (* ,element-size disp)))) + (t (make-ea ,size + :base sap + :index offset + :disp (* ,element-size disp)))) + ,(if (eq size :dword) 'value 'temp)) + (move result + ,(if (eq size :dword) 'value 'eax-tn)))))))) - (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + (def-system-ref-and-set sb!c::sap-ref-8-with-offset sb!c::%set-sap-ref-8-with-offset unsigned-reg positive-fixnum :byte nil) - (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + (def-system-ref-and-set sb!c::signed-sap-ref-8-with-offset sb!c::%set-signed-sap-ref-8-with-offset signed-reg tagged-num :byte t) - (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + (def-system-ref-and-set sb!c::sap-ref-16-with-offset sb!c::%set-sap-ref-16-with-offset unsigned-reg positive-fixnum :word nil) - (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + (def-system-ref-and-set sb!c::signed-sap-ref-16-with-offset sb!c::%set-signed-sap-ref-16-with-offset signed-reg tagged-num :word t) - (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + (def-system-ref-and-set sb!c::sap-ref-32-with-offset sb!c::%set-sap-ref-32-with-offset unsigned-reg unsigned-num :dword nil) - (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + (def-system-ref-and-set sb!c::signed-sap-ref-32-with-offset sb!c::%set-signed-sap-ref-32-with-offset signed-reg signed-num :dword t) - (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + (def-system-ref-and-set sb!c::sap-ref-sap-with-offset sb!c::%set-sap-ref-sap-with-offset sap-reg system-area-pointer :dword)) ;;;; SAP-REF-DOUBLE -(define-vop (sap-ref-double) - (:translate sap-ref-double) +(define-vop (sap-ref-double-with-offset) + (:translate sb!c::sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) + (offset :scs (signed-reg immediate))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 0))) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 5 - (with-empty-tn@fp-top(result) - (inst fldd (make-ea :dword :base sap :index offset))))) - -(define-vop (sap-ref-double-c) - (:translate sap-ref-double) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32))) - (:info offset) - (:results (result :scs (double-reg))) - (:result-types double-float) - (:generator 4 - (with-empty-tn@fp-top(result) - (inst fldd (make-ea :dword :base sap :disp offset))))) + (sc-case offset + (immediate + (aver (zerop disp)) + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :disp (tn-value offset))))) + (t + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :index offset + :disp (* 4 disp)))))))) -(define-vop (%set-sap-ref-double) - (:translate %set-sap-ref-double) +(define-vop (%set-sap-ref-double-with-offset) + (:translate sb!c::%set-sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) (offset :scs (signed-reg) :to (:eval 0)) (value :scs (double-reg))) - (:arg-types system-area-pointer signed-num double-float) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 0)) + double-float) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 5 (cond ((zerop (tn-offset value)) ;; Value is in ST0. - (inst fstd (make-ea :dword :base sap :index offset)) + (inst fstd (make-ea :dword :base sap :index offset + :disp (* 8 disp))) (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fstd 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 sap :index offset)) + (inst fstd (make-ea :dword :base sap :index offset + :disp (* 8 disp))) (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 fstd result)) (inst fxch value))))))) -(define-vop (%set-sap-ref-double-c) - (:translate %set-sap-ref-double) +(define-vop (%set-sap-ref-double-with-offset-c) + (:translate sb!c::%set-sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) (value :scs (double-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float) - (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 32)) + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 0)) + double-float) + (:info offset disp) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 4 + (aver (zerop disp)) (cond ((zerop (tn-offset value)) ;; Value is in ST0. (inst fstd (make-ea :dword :base sap :disp offset)) (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fstd result))) + ;; Value is in ST0 but not result. + (inst fstd result))) (t ;; Value is not in ST0. (inst fxch value) @@ -302,80 +328,91 @@ (t ;; Neither value or result are in ST0. (unless (location= value result) - (inst fstd result)) + (inst fstd result)) (inst fxch value))))))) ;;;; SAP-REF-SINGLE -(define-vop (sap-ref-single) - (:translate sap-ref-single) +(define-vop (sap-ref-single-with-offset) + (:translate sb!c::sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) + (offset :scs (signed-reg immediate))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 0))) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 5 - (with-empty-tn@fp-top(result) - (inst fld (make-ea :dword :base sap :index offset))))) - -(define-vop (sap-ref-single-c) - (:translate sap-ref-single) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32))) - (:info offset) - (:results (result :scs (single-reg))) - (:result-types single-float) - (:generator 4 - (with-empty-tn@fp-top(result) - (inst fld (make-ea :dword :base sap :disp offset))))) + (sc-case offset + (immediate + (aver (zerop disp)) + (with-empty-tn@fp-top(result) + (inst fld (make-ea :dword :base sap :disp (tn-value offset))))) + (t + (with-empty-tn@fp-top(result) + (inst fld (make-ea :dword :base sap :index offset + :disp (* 4 disp)))))))) -(define-vop (%set-sap-ref-single) - (:translate %set-sap-ref-single) +(define-vop (%set-sap-ref-single-with-offset) + (:translate sb!c::%set-sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) (offset :scs (signed-reg) :to (:eval 0)) (value :scs (single-reg))) - (:arg-types system-area-pointer signed-num single-float) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 0)) + single-float) (: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 sap :index offset)) + (inst fst (make-ea :dword :base sap :index offset + :disp (* 4 disp))) (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fst 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 sap :index offset)) + (inst fst (make-ea :dword :base sap :index offset + :disp (* 4 disp))) (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 fst result)) (inst fxch value))))))) -(define-vop (%set-sap-ref-single-c) - (:translate %set-sap-ref-single) +(define-vop (%set-sap-ref-single-with-offset-c) + (:translate sb!c::%set-sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) (value :scs (single-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float) - (:info offset) + (:arg-types system-area-pointer (:constant (signed-byte 32)) + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 0)) + single-float) + (:info offset disp) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 4 + (aver (zerop disp)) (cond ((zerop (tn-offset value)) ;; Value is in ST0 (inst fst (make-ea :dword :base sap :disp offset)) (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fst result))) + ;; Value is in ST0 but not result. + (inst fst result))) (t ;; Value is not in ST0. (inst fxch value) @@ -386,7 +423,7 @@ (t ;; Neither value or result are in ST0 (unless (location= value result) - (inst fst result)) + (inst fst result)) (inst fxch value))))))) ;;;; SAP-REF-LONG diff --git a/version.lisp-expr b/version.lisp-expr index bcdda39..c77312c 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.2" +"1.0.2.1" -- 1.7.10.4