element-type-specifier)))
;;; Array access functions return an object from the array, hence its
-;;; type will be asserted to be array element type.
-(defun extract-element-type (array)
- (let ((type (continuation-type array)))
- (if (array-type-p type)
- (array-type-element-type type)
- *universal-type*)))
-
-;;; Array access functions return an object from the array, hence its
;;; type is going to be the array upgraded element type.
(defun extract-upgraded-element-type (array)
(let ((type (continuation-type array)))
(defun assert-new-value-type (new-value array)
(let ((type (continuation-type array)))
(when (array-type-p type)
- (assert-continuation-type new-value (array-type-element-type type))))
+ (assert-continuation-type new-value (array-type-specialized-element-type type))))
(continuation-type new-value))
;;; Return true if Arg is NIL, or is a constant-continuation whose
;; If the node continuation has a single use then assert its type.
(let ((cont (node-cont node)))
(when (= (length (find-uses cont)) 1)
- (assert-continuation-type cont (extract-element-type array))))
+ (assert-continuation-type cont (extract-upgraded-element-type array))))
(extract-upgraded-element-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(when (array-type-p atype)
(values-specifier-type
`(values (simple-array ,(type-specifier
- (array-type-element-type atype))
+ (array-type-specialized-element-type atype))
(*))
index index index)))))
(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))))
+ ,@(mapcar (lambda (el)
+ (once-only ((n-val el))
+ `(locally (declare (optimize (safety 0)))
+ (setf (svref ,n-vec ,(incf n))
+ ,n-val))))
elements)
,n-vec))))
;; (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)
+ (single-float 0.0f0 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)
((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
+ ((complex single-float) #C(0.0f0 0.0f0) 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)
*specialized-array-element-type-properties*)))
(unless saetp
(give-up-ir1-transform
- "cannot open-code creation of ~S" spec))
+ "cannot open-code creation of ~S" result-type-spec))
(let* ((initial-element-default (saetp-initial-element-default saetp))
(n-bits-per-element (saetp-n-bits saetp))
'(: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))))))
\f
;;;; 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 (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 bit-and)
+ (def bit-ior)
+ (def bit-xor)
+ (def bit-eqv)
+ (def bit-nand)
+ (def bit-nor)
+ (def bit-andc1)
+ (def bit-andc2)
+ (def bit-orc1)
+ (def bit-orc2))
;;; Similar for BIT-NOT, but there is only one arg...
(deftransform bit-not ((bit-array-1 &optional result-bit-array)
'(bit-not bit-array-1
(make-array (length bit-array-1) :element-type 'bit)))
(deftransform bit-not ((bit-array-1 result-bit-array)
- (bit-vector (constant-argument t)))
+ (bit-vector (constant-arg t)))
'(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
-;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
+;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
+;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
;;; value?
\f
;;; Pick off some constant cases.
(deftransform array-header-p ((array) (array))
(let ((type (continuation-type array)))
- (declare (optimize (safety 3)))
(unless (array-type-p type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions type)))
(cond ((csubtypep type (specifier-type '(simple-array * (*))))
- ;; No array header.
+ ;; no array header
nil)
((and (listp dims) (> (length dims) 1))
- ;; Multi-dimensional array, will have a header.
+ ;; multi-dimensional array, will have a header
t)
(t
(give-up-ir1-transform))))))
projects / sbcl.git / blobdiff