X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=61bd015cca665497b14fa07e5975cbb12c48b4d1;hb=e0814eee6f6dea52db010b45a330100f2fe65832;hp=c2f7c8300ae1453ad0e971740f7c6dc9330b226d;hpb=2f453e77acd12b73a09c3b50601a420d3454b732;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index c2f7c83..61bd015 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -141,59 +141,90 @@ ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the ;;; elements. -(def-source-transform vector (&rest elements) - (if (byte-compiling) - (values nil t) - (let ((len (length elements)) - (n -1)) - (once-only ((n-vec `(make-array ,len))) - `(progn - ,@(mapcar #'(lambda (el) - (once-only ((n-val el)) - `(locally (declare (optimize (safety 0))) - (setf (svref ,n-vec ,(incf n)) - ,n-val)))) - elements) - ,n-vec))))) +(define-source-transform vector (&rest elements) + (let ((len (length elements)) + (n -1)) + (once-only ((n-vec `(make-array ,len))) + `(progn + ,@(mapcar (lambda (el) + (once-only ((n-val el)) + `(locally (declare (optimize (safety 0))) + (setf (svref ,n-vec ,(incf n)) + ,n-val)))) + elements) + ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. -(def-source-transform make-string (length &key - (element-type ''base-char) - (initial-element default-init-char)) - (if (byte-compiling) - (values nil t) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element))) - -(defparameter *array-info* - #((base-char #.default-init-char 8 sb!vm:simple-string-type) - (single-float 0.0s0 32 sb!vm:simple-array-single-float-type) - (double-float 0.0d0 64 sb!vm:simple-array-double-float-type) - #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128 - sb!vm:simple-array-long-float-type) - (bit 0 1 sb!vm:simple-bit-vector-type) - ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type) - ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type) - ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type) - ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type) - ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type) - ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type) - ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type) - ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type) - ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type) - ((complex single-float) #C(0.0s0 0.0s0) 64 - sb!vm:simple-array-complex-single-float-type) - ((complex double-float) #C(0.0d0 0.0d0) 128 - sb!vm:simple-array-complex-double-float-type) - #!+long-float - ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256 - sb!vm:simple-array-complex-long-float-type) - (t 0 32 sb!vm:simple-vector-type))) +(define-source-transform make-string (length &key + (element-type ''base-char) + (initial-element + '#.*default-init-char-form*)) + `(make-array (the index ,length) + :element-type ,element-type + :initial-element ,initial-element)) + +(defstruct (specialized-array-element-type-properties + (:conc-name saetp-) + (:constructor !make-saetp (ctype + initial-element-default + n-bits + typecode + &key + (n-pad-elements 0))) + (:copier nil)) + ;; the element type, e.g. # or + ;; # + (ctype (missing-arg) :type ctype :read-only t) + ;; what we get when the low-level vector-creation logic zeroes all + ;; the bits (which also serves as the default value of MAKE-ARRAY's + ;; :INITIAL-ELEMENT keyword) + (initial-element-default (missing-arg) :read-only t) + ;; how many bits per element + (n-bits (missing-arg) :type index :read-only t) + ;; the low-level type code + (typecode (missing-arg) :type index :read-only t) + ;; the number of extra elements we use at the end of the array for + ;; low level hackery (e.g., one element for arrays of BASE-CHAR, + ;; which is used for a fixed #\NULL so that when we call out to C + ;; we don't need to cons a new copy) + (n-pad-elements (missing-arg) :type index :read-only t)) + +(defparameter *specialized-array-element-type-properties* + (map 'simple-vector + (lambda (args) + (destructuring-bind (type-spec &rest rest) args + (let ((ctype (specifier-type type-spec))) + (apply #'!make-saetp ctype rest)))) + `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag + ;; (SIMPLE-STRINGs are stored with an extra trailing + ;; #\NULL for convenience in calling out to C.) + :n-pad-elements 1) + (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-widetag) + (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag) + #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128 + ,sb!vm:simple-array-long-float-widetag) + (bit 0 1 ,sb!vm:simple-bit-vector-widetag) + ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag) + ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag) + ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag) + ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag) + ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag) + ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag) + ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag) + ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag) + ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag) + ((complex single-float) #C(0.0s0 0.0s0) 64 + ,sb!vm:simple-array-complex-single-float-widetag) + ((complex double-float) #C(0.0d0 0.0d0) 128 + ,sb!vm:simple-array-complex-double-float-widetag) + #!+long-float ((complex long-float) #C(0.0L0 0.0L0) + #!+x86 192 #!+sparc 256 + ,sb!vm:simple-array-complex-long-float-widetag) + (t 0 32 ,sb!vm:simple-vector-widetag)))) ;;; The integer type restriction on the length ensures that it will be -;;; a vector. The lack of adjustable, fill-pointer, and displaced-to -;;; keywords ensures that it will be simple. +;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and +;;; :DISPLACED-TO keywords ensures that it will be simple. (deftransform make-array ((length &key initial-element element-type) (integer &rest *)) (let* ((eltype (cond ((not element-type) t) @@ -205,57 +236,66 @@ (len (if (constant-continuation-p length) (continuation-value length) '*)) - (spec `(simple-array ,eltype (,len))) - (eltype-type (specifier-type eltype))) - (multiple-value-bind (default-initial-element element-size typecode) - (dovector (info *array-info* - (give-up-ir1-transform - "cannot open-code creation of ~S" spec)) - (when (csubtypep eltype-type (specifier-type (car info))) - (return (values-list (cdr info))))) - (let* ((nwords-form - (if (>= element-size sb!vm:word-bits) - `(* length ,(/ element-size sb!vm:word-bits)) - (let ((elements-per-word (/ 32 element-size))) - `(truncate (+ length - ,(if (eq 'sb!vm:simple-string-type typecode) - ;; (Simple strings are stored with an - ;; extra trailing null for convenience - ;; in calling out to C.) - elements-per-word - (1- elements-per-word))) - ,elements-per-word)))) - (constructor - `(truly-the ,spec - (allocate-vector ,typecode length ,nwords-form)))) - (values - (cond ((and default-initial-element - (or (null initial-element) - (and (constant-continuation-p initial-element) - (eql (continuation-value initial-element) - default-initial-element)))) - (unless (csubtypep (ctype-of default-initial-element) - eltype-type) - ;; This situation arises e.g. in - ;; (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5)) - ;; ANSI's definition of MAKE-ARRAY says "If - ;; INITIAL-ELEMENT is not supplied, the consequences - ;; of later reading an uninitialized element of - ;; new-array are undefined," so this could be legal - ;; code as long as the user plans to write before he - ;; reads, and if he doesn't we're free to do - ;; anything we like. But in case the user doesn't - ;; know to write before he reads, we'll signal a - ;; STYLE-WARNING in case he didn't realize this. - ;; - ;; FIXME: should be STYLE-WARNING, not note - (compiler-note "The default initial element ~S is not a ~S." - default-initial-element - eltype)) - constructor) - (t - `(truly-the ,spec (fill ,constructor initial-element)))) - '((declare (type index length)))))))) + (result-type-spec `(simple-array ,eltype (,len))) + (eltype-type (specifier-type eltype)) + (saetp (find-if (lambda (saetp) + (csubtypep eltype-type (saetp-ctype saetp))) + *specialized-array-element-type-properties*))) + (unless saetp + (give-up-ir1-transform + "cannot open-code creation of ~S" spec)) + + (let* ((initial-element-default (saetp-initial-element-default saetp)) + (n-bits-per-element (saetp-n-bits saetp)) + (typecode (saetp-typecode saetp)) + (n-pad-elements (saetp-n-pad-elements saetp)) + (padded-length-form (if (zerop n-pad-elements) + 'length + `(+ length ,n-pad-elements))) + (n-words-form + (if (>= n-bits-per-element sb!vm:n-word-bits) + `(* ,padded-length-form + (the fixnum ; i.e., not RATIO + ,(/ n-bits-per-element sb!vm:n-word-bits))) + (let ((n-elements-per-word (/ sb!vm:n-word-bits + n-bits-per-element))) + (declare (type index n-elements-per-word)) ; i.e., not RATIO + `(ceiling ,padded-length-form ,n-elements-per-word)))) + (bare-constructor-form + `(truly-the ,result-type-spec + (allocate-vector ,typecode length ,n-words-form))) + (initial-element-form (if initial-element + 'initial-element + initial-element-default))) + (values + (cond (;; Can we skip the FILL step? + (or (null initial-element) + (and (constant-continuation-p initial-element) + (eql (continuation-value initial-element) + initial-element-default))) + (unless (csubtypep (ctype-of initial-element-default) + eltype-type) + ;; This situation arises e.g. in + ;; (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5)) + ;; ANSI's definition of MAKE-ARRAY says "If + ;; INITIAL-ELEMENT is not supplied, the consequences + ;; of later reading an uninitialized element of + ;; new-array are undefined," so this could be legal + ;; code as long as the user plans to write before he + ;; reads, and if he doesn't we're free to do anything + ;; we like. But in case the user doesn't know to write + ;; elements before he reads elements (or to read + ;; manuals before he writes code:-), we'll signal a + ;; STYLE-WARNING in case he didn't realize this. + (compiler-note "The default initial element ~S is not a ~S." + initial-element-default + eltype)) + bare-constructor-form) + (t + `(truly-the ,result-type-spec + (fill ,bare-constructor-form + ,initial-element-form)))) + '((declare (type index length))))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, @@ -287,7 +327,7 @@ (continuation-value element-type)) (t '*)) ,(make-list rank :initial-element '*)))) - `(let ((header (make-array-header sb!vm:simple-array-type ,rank))) + `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) (setf (%array-fill-pointer header) ,total-size) (setf (%array-fill-pointer-p header) nil) (setf (%array-available-elements header) ,total-size) @@ -299,9 +339,9 @@ '(:initial-element initial-element)))) (setf (%array-displaced-p header) nil) ,@(let ((axis -1)) - (mapcar #'(lambda (dim) - `(setf (%array-dimension header ,(incf axis)) - ,dim)) + (mapcar (lambda (dim) + `(setf (%array-dimension header ,(incf axis)) + ,dim)) dims)) (truly-the ,spec header)))))) @@ -339,7 +379,7 @@ (give-up-ir1-transform "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime.")) (unless (> (length dims) axis) - (abort-ir1-transform "The array has dimensions ~S, ~D is too large." + (abort-ir1-transform "The array has dimensions ~S, ~W is too large." dims axis)) (let ((dim (nth axis dims))) @@ -436,62 +476,97 @@ :policy (and (> speed safety) (= safety 0))) 'index) -;;;; array accessors - -;;; FIXME: This was commented out in sbcl-0.6.9.21 since it was -;;; causing a problem in a CHAR form in HEXSTR. It's still important -;;; to be able to inline this, so something along these lines -;;; will probably be back, but it might be different in detail, e.g. -;;; (DECLAIM (MAYBE-INLINE %WITH-ARRAY-DATA)). -#| -;;; Handle the 1-dimensional case of %WITH-ARRAY-DATA specially. It's -;;; important to do this efficiently if we want people to be able to -;;; use vectors with fill pointers anywhere near inner loops, and -;;; hence it's important to do this efficiently if we want people to -;;; be able to use sequence functions anywhere near inner loops. -(deftransform %with-array-data ((array start end) - (vector index (or index null)) - * - :important t - :node node - :policy (> speed space)) - "avoid full call to %WITH-ARRAY-DATA at runtime" - (let* ((element-ctype (extract-upgraded-element-type array)) - (element-type-specifier (type-specifier element-ctype)) - (simple-array-type `(simple-array ,element-type-specifier 1))) - (declare (type ctype element-ctype)) - `(let* (;; FIXME: Instead of doing this hairy expression for SIZE, - ;; it should just be (ARRAY-DIMENSION ARRAY 0), and there - ;; should be a DEFTRANSFORM for ARRAY-DIMENSION which - ;; expands that way. - (size (if (array-header-p array) - (%array-dimension array 0) - (length (the ,simple-array-type array)))) - (end (if end - (if (or ,(policy node (= safety 0)) - (<= (the index end) size)) - end - (vector-data-start-out-of-range)) - size))) - (declare (type index end)) - (unless (or ,(policy node (= safety 0)) - (<= start end)) - (vector-data-end-out-of-range)) - (do (;; cumulative displacement - (d 0 (truly-the index (+ d (%array-displacement array)))) - ;; eventually becomes bare data vector - (v array (%array-data-vector v))) - ((not (array-header-p v)) - (values (the ,simple-array-type v) - (truly-the index (+ d start)) - (truly-the index (+ d end)) - (the index d))) - (declare (type index d)))))) -(defun vector-data-start-out-of-range () - (error "The start of vector data was out of range.")) -(defun vector-data-end-out-of-range () - (error "The end of vector data was out of range.")) -|# +;;;; WITH-ARRAY-DATA + +;;; This checks to see whether the array is simple and the start and +;;; end are in bounds. If so, it proceeds with those values. +;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA +;;; may be further optimized. +;;; +;;; Given any ARRAY, bind DATA-VAR to the array's data vector and +;;; START-VAR and END-VAR to the start and end of the designated +;;; portion of the data vector. SVALUE and EVALUE are any start and +;;; end specified to the original operation, and are factored into the +;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative +;;; offset of all displacements encountered, and does not include +;;; SVALUE. +;;; +;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is +;;; forced to be inline, overriding the ordinary judgment of the +;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are +;;; fairly picky about their arguments, figuring that if you haven't +;;; bothered to get all your ducks in a row, you probably don't care +;;; that much about speed anyway! But in some cases it makes sense to +;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and +;;; the DEFTRANSFORM can't tell that that's going on, so it can make +;;; sense to use FORCE-INLINE option in that case. +(def!macro with-array-data (((data-var array &key offset-var) + (start-var &optional (svalue 0)) + (end-var &optional (evalue nil)) + &key force-inline) + &body forms) + (once-only ((n-array array) + (n-svalue `(the index ,svalue)) + (n-evalue `(the (or index null) ,evalue))) + `(multiple-value-bind (,data-var + ,start-var + ,end-var + ,@(when offset-var `(,offset-var))) + (if (not (array-header-p ,n-array)) + (let ((,n-array ,n-array)) + (declare (type (simple-array * (*)) ,n-array)) + ,(once-only ((n-len `(length ,n-array)) + (n-end `(or ,n-evalue ,n-len))) + `(if (<= ,n-svalue ,n-end ,n-len) + ;; success + (values ,n-array ,n-svalue ,n-end 0) + ;; failure: Make a NOTINLINE call to + ;; %WITH-ARRAY-DATA with our bad data + ;; to cause the error to be signalled. + (locally + (declare (notinline %with-array-data)) + (%with-array-data ,n-array ,n-svalue ,n-evalue))))) + (,(if force-inline '%with-array-data-macro '%with-array-data) + ,n-array ,n-svalue ,n-evalue)) + ,@forms))) + +;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in +;;; DEFTRANSFORMs and DEFUNs. +(def!macro %with-array-data-macro (array + start + end + &key + (element-type '*) + unsafe? + fail-inline?) + (let ((size (gensym "SIZE-")) + (defaulted-end (gensym "DEFAULTED-END-")) + (data (gensym "DATA-")) + (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) + `(let* ((,size (array-total-size ,array)) + (,defaulted-end + (cond (,end + (unless (or ,unsafe? (<= ,end ,size)) + ,(if fail-inline? + `(error "End ~W is greater than total size ~W." + ,end ,size) + `(failed-%with-array-data ,array ,start ,end))) + ,end) + (t ,size)))) + (unless (or ,unsafe? (<= ,start ,defaulted-end)) + ,(if fail-inline? + `(error "Start ~W is greater than end ~W." ,start ,defaulted-end) + `(failed-%with-array-data ,array ,start ,end))) + (do ((,data ,array (%array-data-vector ,data)) + (,cumulative-offset 0 + (+ ,cumulative-offset + (%array-displacement ,data)))) + ((not (array-header-p ,data)) + (values (the (simple-array ,element-type 1) ,data) + (the index (+ ,cumulative-offset ,start)) + (the index (+ ,cumulative-offset ,defaulted-end)) + (the index ,cumulative-offset))) + (declare (type index ,cumulative-offset)))))) (deftransform %with-array-data ((array start end) ;; Note: This transform is limited to @@ -513,19 +588,17 @@ `(%with-array-data-macro array start end :unsafe? ,(policy node (= safety 0)) :element-type ,element-type))) + +;;;; array accessors ;;; We convert all typed array accessors into AREF and %ASET with type ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) `(progn - (def-source-transform ,reffer (a &rest i) - (if (byte-compiling) - (values nil t) - `(aref (the ,',type ,a) ,@i))) - (def-source-transform ,setter (a &rest i) - (if (byte-compiling) - (values nil t) - `(%aset (the ,',type ,a) ,@i)))))) + (define-source-transform ,reffer (a &rest i) + `(aref (the ,',type ,a) ,@i)) + (define-source-transform ,setter (a &rest i) + `(%aset (the ,',type ,a) ,@i))))) (define-frob svref %svset simple-vector) (define-frob schar %scharset simple-string) (define-frob char %charset string) @@ -549,10 +622,10 @@ `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value))) (let* (,@(let ((,index -1)) - (mapcar #'(lambda (name) - `(,name (array-dimension - ,',array - ,(incf ,index)))) + (mapcar (lambda (name) + `(,name (array-dimension + ,',array + ,(incf ,index)))) dims)) (,',index ,(if (null dims) @@ -609,20 +682,27 @@ ;;;; and eliminates the need for any VM-dependent transforms to handle ;;;; these cases. -(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 - bit-andc2 bit-orc1 bit-orc2)) - ;; Make a result array if result is NIL or unsupplied. - (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array) - '(bit-vector bit-vector &optional null) '* - :eval-name t - :policy (>= speed space)) - `(,fun bit-array-1 bit-array-2 - (make-array (length bit-array-1) :element-type 'bit))) - ;; If result is T, make it the first arg. - (deftransform fun ((bit-array-1 bit-array-2 result-bit-array) - '(bit-vector bit-vector (member t)) '* - :eval-name t) - `(,fun bit-array-1 bit-array-2 bit-array-1))) +(macrolet ((def-frob (fun) + `(progn + (deftransform ,fun ((bit-array-1 bit-array-2 &optional result-bit-array) + (bit-vector bit-vector &optional null) * + :policy (>= speed space)) + `(,',fun bit-array-1 bit-array-2 + (make-array (length bit-array-1) :element-type 'bit))) + ;; If result is T, make it the first arg. + (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) + (bit-vector bit-vector (member t)) *) + `(,',fun bit-array-1 bit-array-2 bit-array-1))))) + (def-frob bit-and) + (def-frob bit-ior) + (def-frob bit-xor) + (def-frob bit-eqv) + (def-frob bit-nand) + (def-frob bit-nor) + (def-frob bit-andc1) + (def-frob bit-andc2) + (def-frob bit-orc1) + (def-frob bit-orc2)) ;;; Similar for BIT-NOT, but there is only one arg... (deftransform bit-not ((bit-array-1 &optional result-bit-array)