/[cmucl]/src/compiler/array-tran.lisp
ViewVC logotype

Diff of /src/compiler/array-tran.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28.2.1 by pmai, Fri Oct 4 23:13:39 2002 UTC revision 1.45 by rtoy, Tue Apr 20 17:57:46 2010 UTC
# Line 14  Line 14 
14  ;;; Extracted from srctran and extended by William Lott.  ;;; Extracted from srctran and extended by William Lott.
15  ;;;  ;;;
16  (in-package "C")  (in-package "C")
17    (intl:textdomain "cmucl")
18    
19    
20  ;;;; Derive-Type Optimizers  ;;;; Derive-Type Optimizers
# Line 59  Line 60 
60    (let ((type (continuation-type array)))    (let ((type (continuation-type array)))
61      (when (array-type-p type)      (when (array-type-p type)
62        (assert-continuation-optional-type new-value        (assert-continuation-optional-type new-value
63                                           (array-type-element-type type))))                                           (array-type-specialized-element-type type))))
64    (continuation-type new-value))    (continuation-type new-value))
65    
66  ;;; Unsupplied-Or-NIL  --  Internal  ;;; Unsupplied-Or-NIL  --  Internal
# Line 85  Line 86 
86  (defoptimizer (aref derive-type) ((array &rest indices) node)  (defoptimizer (aref derive-type) ((array &rest indices) node)
87    (assert-array-rank array (length indices))    (assert-array-rank array (length indices))
88    ;; If the node continuation has a single use then assert its type.    ;; If the node continuation has a single use then assert its type.
89      ;;
90      ;; Let's not do this.  As reported by Lynn Quam on cmucl-imp on
91      ;; 2004-03-30, the compiler generates bogus code for
92      ;;
93      ;; (defun foo (f d)
94      ;;   (declare (type (simple-array single-float (*)) f)
95      ;;            (type (simple-array double-float (*)) d))
96      ;;   (setf (aref f 0) (aref d 0)))
97      ;;
98      ;; and doesn't even warn about the type mismatch.  This might be a
99      ;; symptom of other compiler bugs, but removing this at least gives
100      ;; us back the warning.  I (RLT) do not know what impact removing
101      ;; this has on other user code.
102      #+(or)
103    (let ((cont (node-cont node)))    (let ((cont (node-cont node)))
104      (when (= (length (find-uses cont)) 1)      (when (= (length (find-uses cont)) 1)
105        (assert-continuation-type cont (extract-element-type array))))        (assert-continuation-type cont (extract-upgraded-element-type array))))
106    (extract-upgraded-element-type array))    (extract-upgraded-element-type array))
107    
108  ;;; %ASET  --  derive-type optimizer.  ;;; %ASET  --  derive-type optimizer.
109  ;;;  ;;;
110  (defoptimizer (%aset derive-type) ((array &rest stuff))  (defoptimizer (%aset derive-type) ((array &rest stuff))
111    (assert-array-rank array (1- (length stuff)))    (assert-array-rank array (1- (length stuff)))
112    (assert-new-value-type (car (last stuff)) array))    (assert-new-value-type (car (last stuff)) array)
113      ;; Without the following,  this function
114      ;;
115      ;;   (defun fn-492 (r p1)
116      ;;     (declare (optimize speed (safety 1))
117      ;;            (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1))
118      ;;     (setf (aref r) (lognand (the (integer 19464371) p1) 2257))
119      ;;     (values))
120      ;;   (defun tst-492 ()
121      ;;     (let ((r (make-array nil :element-type '(signed-byte 8))))
122      ;;       (fn-492 r 19469591)
123      ;;       (aref r)))
124      ;;
125      ;; causes the compiler to delete (values) as unreachable and in so
126      ;; doing, deletes the return, so we just run off the end.  I (rtoy)
127      ;; think this is caused by some confusion in type-derivation.  The
128      ;; derived result of the lognand is bigger than a (signed-byte 8).
129      ;;
130      ;; I think doing this also causes some loss, because we return the
131      ;; element-type of the array, even though the result of the aset is
132      ;; the new value.  Well, almost.  The element type is returned only
133      ;; if the array continuation is really an array type.  Otherwise, we
134      ;; do return the type of the new value.
135      ;;
136      ;; FIXME: This needs something better, but I (rtoy) am not smart
137      ;; enough to know what to do about it.
138      (let ((atype (continuation-type array)))
139        (if (array-type-p atype)
140            (array-type-specialized-element-type atype)
141            (continuation-type (car (last stuff))))))
142    
143  ;;; DATA-VECTOR-REF  --  derive-type optimizer.  ;;; DATA-VECTOR-REF  --  derive-type optimizer.
144  ;;;  ;;;
# Line 153  Line 197 
197                (t                (t
198                 '*))                 '*))
199         ,(cond ((not simple)         ,(cond ((not simple)
200                 '*)                 ;; Can't derive the actual dimensions lest someone do
201                   ;; an ADJUST-ARRAY, but we can try to get the rank
202                   ;; correct.
203                   (cond ((constant-continuation-p dims)
204                          (let ((val (continuation-value dims)))
205                            (if (listp val)
206                                (make-list (length val) :initial-element '*)
207                                '(*))))
208                         ((csubtypep (continuation-type dims)
209                                     (specifier-type 'integer))
210                          '(*))
211                         (t
212                          '*)))
213                ((constant-continuation-p dims)                ((constant-continuation-p dims)
214                 (let ((val (continuation-value dims)))                 (let ((val (continuation-value dims)))
215                   (if (listp val) val (list val))))                   (if (listp val) val (list val))))
# Line 190  Line 246 
246  ;;;  ;;;
247  ;;; Just convert it into a make-array.  ;;; Just convert it into a make-array.
248  ;;;  ;;;
249  (def-source-transform make-string (length &key (element-type #-unicode ''base-char  (deftransform make-string ((length &key (element-type 'base-char)
250                                                               #+unicode ''character)                                     (initial-element #\NULL)))
251                                            (initial-element #\NULL))    `(make-array (the (values index &rest t) length)
252    (if (byte-compiling)                 :element-type element-type
253        (values nil t)                 :initial-element initial-element))
       `(make-array (the (values index &rest t) ,length)  
                    :element-type ,element-type  
                    :initial-element ,initial-element)))  
254    
255  (defconstant array-info  (defconstant array-info
256    '(    '((base-char #\NULL #.vm:char-bits vm:simple-string-type)
257      #-unicode      (single-float 0.0f0 32 vm:simple-array-single-float-type)
     (base-char #\NULL 8 vm:simple-string-type)  
     #+unicode  
     (base-char #\NULL 8 vm:simple-base-string-type)  
     #+unicode  
     (character #\NULL 32 vm:simple-character-string-type)  
     (single-float 0.0s0 32 vm:simple-array-single-float-type)  
258      (double-float 0.0d0 64 vm:simple-array-double-float-type)      (double-float 0.0d0 64 vm:simple-array-double-float-type)
259      #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128      #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
260                    vm:simple-array-long-float-type)                    vm:simple-array-long-float-type)
261        #+double-double
262        (double-double-float 0w0 128
263                      vm::simple-array-double-double-float-type)
264      (bit 0 1 vm:simple-bit-vector-type)      (bit 0 1 vm:simple-bit-vector-type)
265      ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)      ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
266      ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)      ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
# Line 221  Line 271 
271      ((signed-byte 16) 0 16 vm:simple-array-signed-byte-16-type)      ((signed-byte 16) 0 16 vm:simple-array-signed-byte-16-type)
272      ((signed-byte 30) 0 32 vm:simple-array-signed-byte-30-type)      ((signed-byte 30) 0 32 vm:simple-array-signed-byte-30-type)
273      ((signed-byte 32) 0 32 vm:simple-array-signed-byte-32-type)      ((signed-byte 32) 0 32 vm:simple-array-signed-byte-32-type)
274      ((complex single-float) #C(0.0s0 0.0s0) 64      ((complex single-float) #C(0.0f0 0.0f0) 64
275       vm:simple-array-complex-single-float-type)       vm:simple-array-complex-single-float-type)
276      ((complex double-float) #C(0.0d0 0.0d0) 128      ((complex double-float) #C(0.0d0 0.0d0) 128
277       vm:simple-array-complex-double-float-type)       vm:simple-array-complex-double-float-type)
278      #+long-float      #+long-float
279      ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256      ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
280       vm:simple-array-complex-long-float-type)       vm:simple-array-complex-long-float-type)
281        #+double-double
282        ((complex double-double-float) #C(0.0w0 0.0w0) 256
283         vm::simple-array-complex-double-double-float-type)
284      (t 0 32 vm:simple-vector-type)))      (t 0 32 vm:simple-vector-type)))
285    
286  ;;; MAKE-ARRAY  --  source-transform.  ;;; MAKE-ARRAY  --  source-transform.
# Line 240  Line 293 
293                            (integer &rest *))                            (integer &rest *))
294    (let* ((eltype (cond ((not element-type) t)    (let* ((eltype (cond ((not element-type) t)
295                         ((not (constant-continuation-p element-type))                         ((not (constant-continuation-p element-type))
296                          (give-up "Element-Type is not constant."))                          (give-up (intl:gettext "Element-Type is not constant.")))
297                         (t                         (t
298                          (continuation-value element-type))))                          (continuation-value element-type))))
299           (len (if (constant-continuation-p length)           (len (if (constant-continuation-p length)
# Line 251  Line 304 
304      (multiple-value-bind      (multiple-value-bind
305          (default-initial-element element-size typecode)          (default-initial-element element-size typecode)
306          (dolist (info array-info          (dolist (info array-info
307                        (give-up "Cannot open-code creation of ~S" spec))                        (give-up (intl:gettext "Cannot open-code creation of ~S") spec))
308            (when (csubtypep eltype-type (specifier-type (car info)))            (when (csubtypep eltype-type (specifier-type (car info)))
309              (return (values-list (cdr info)))))              (return (values-list (cdr info)))))
310        (let* ((nwords-form        (let* ((nwords-form
# Line 259  Line 312 
312                    `(* length ,(/ element-size vm:word-bits))                    `(* length ,(/ element-size vm:word-bits))
313                    (let ((elements-per-word (/ 32 element-size)))                    (let ((elements-per-word (/ 32 element-size)))
314                      `(truncate (+ length                      `(truncate (+ length
315                                    ,(if (eq #-unicode 'vm:simple-string-type                                    ,(if (eq 'vm:simple-string-type typecode)
                                            #+unicode 'vm:simple-base-string-type typecode)  
316                                         elements-per-word                                         elements-per-word
317                                         (1- elements-per-word)))                                         (1- elements-per-word)))
318                                 ,elements-per-word))))                                 ,elements-per-word))))
# Line 275  Line 327 
327                                     default-initial-element))))                                     default-initial-element))))
328                  (unless (csubtypep (ctype-of default-initial-element)                  (unless (csubtypep (ctype-of default-initial-element)
329                                     eltype-type)                                     eltype-type)
330                    (compiler-note "Default initial element ~s is not a ~s."                    (compiler-note _N"Default initial element ~s is not a ~s."
331                                   default-initial-element eltype))                                   default-initial-element eltype))
332                  constructor)                  constructor)
333                 (t                 (t
# Line 290  Line 342 
342  (deftransform make-array ((dims &key initial-element element-type)  (deftransform make-array ((dims &key initial-element element-type)
343                            (list &rest *))                            (list &rest *))
344    (unless (or (null element-type) (constant-continuation-p element-type))    (unless (or (null element-type) (constant-continuation-p element-type))
345      (give-up "Element-type not constant; cannot open code array creation"))      (give-up (intl:gettext "Element-type not constant; cannot open code array creation")))
346    (unless (constant-continuation-p dims)    (unless (constant-continuation-p dims)
347      (give-up "Dimension list not constant; cannot open code array creation"))      (give-up (intl:gettext "Dimension list not constant; cannot open code array creation")))
348    (let ((dims (continuation-value dims)))    (let ((dims (continuation-value dims)))
349      (unless (every #'integerp dims)      (unless (every #'integerp dims)
350        (give-up "Dimension list contains something other than an integer: ~S"        (give-up (intl:gettext "Dimension list contains something other than an integer: ~S")
351                 dims))                 dims))
352      (if (= (length dims) 1)      (if (= (length dims) 1)
353          `(make-array ',(car dims)          `(make-array ',(car dims)
# Line 345  Line 397 
397        (give-up))        (give-up))
398      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
399        (if (not (listp dims))        (if (not (listp dims))
400            (give-up "Array rank not known at compile time: ~S" dims)            (give-up (intl:gettext "Array rank not known at compile time: ~S") dims)
401            (length dims)))))            (length dims)))))
402    
403  ;;; ARRAY-DIMENSION  --  transform.  ;;; ARRAY-DIMENSION  --  transform.
# Line 358  Line 410 
410  (deftransform array-dimension ((array axis)  (deftransform array-dimension ((array axis)
411                                 (array index))                                 (array index))
412    (unless (constant-continuation-p axis)    (unless (constant-continuation-p axis)
413      (give-up "Axis not constant."))      (give-up (intl:gettext "Axis not constant.")))
414    (let ((array-type (continuation-type array))    (let ((array-type (continuation-type array))
415          (axis (continuation-value axis)))          (axis (continuation-value axis)))
416      (unless (array-type-p array-type)      (unless (array-type-p array-type)
# Line 366  Line 418 
418      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
419        (unless (listp dims)        (unless (listp dims)
420          (give-up          (give-up
421           "Array dimensions unknown, must call array-dimension at runtime."))           (intl:gettext "Array dimensions unknown, must call array-dimension at runtime.")))
422        (unless (> (length dims) axis)        (unless (> (length dims) axis)
423          (abort-transform "Array has dimensions ~S, ~D is too large."          (abort-transform (intl:gettext "Array has dimensions ~S, ~D is too large.")
424                           dims axis))                           dims axis))
425        (let ((dim (nth axis dims)))        (let ((dim (nth axis dims)))
426          (cond ((integerp dim)          (cond ((integerp dim)
# Line 379  Line 431 
431                    '(%array-dimension array 0))                    '(%array-dimension array 0))
432                   ((nil)                   ((nil)
433                    '(length array))                    '(length array))
434                   (*                   ((:maybe *)
435                    (give-up "Can't tell if array is simple."))))                    (give-up (intl:gettext "Can't tell if array is simple.")))))
436                (t                (t
437                 '(%array-dimension array axis)))))))                 '(%array-dimension array axis)))))))
438    
# Line 395  Line 447 
447        (give-up))        (give-up))
448      (let ((dims (array-type-dimensions type)))      (let ((dims (array-type-dimensions type)))
449        (unless (and (listp dims) (integerp (car dims)))        (unless (and (listp dims) (integerp (car dims)))
450          (give-up "Vector length unknown, must call length at runtime."))          (give-up (intl:gettext "Vector length unknown, must call length at runtime.")))
451        (car dims))))        (car dims))))
452    
453  ;;; LENGTH  --  transform.  ;;; LENGTH  --  transform.
# Line 434  Line 486 
486        (give-up))        (give-up))
487      (let ((dims (array-type-dimensions array-type)))      (let ((dims (array-type-dimensions array-type)))
488        (unless (listp dims)        (unless (listp dims)
489          (give-up "Can't tell the rank at compile time."))          (give-up (intl:gettext "Can't tell the rank at compile time.")))
490        (if (member '* dims)        (if (member '* dims)
491            (do ((form 1 `(truly-the index            (do ((form 1 `(truly-the index
492                                     (* (array-dimension array ,i) ,form)))                                     (* (array-dimension array ,i) ,form)))
# Line 458  Line 510 
510               t)               t)
511              ((nil)              ((nil)
512               nil)               nil)
513              (*              (:maybe
514               (give-up "Array type ambiguous; must call ~               (give-up (intl:gettext "Array type ambiguous; must call ~
515                        array-has-fill-pointer-p at runtime.")))))))                        array-has-fill-pointer-p at runtime."))))))))
516    
517  ;;; %CHECK-BOUND  --  transform.  ;;; %CHECK-BOUND  --  transform.
518  ;;;  ;;;
# Line 471  Line 523 
523    (unless (constant-continuation-p dimension)    (unless (constant-continuation-p dimension)
524      (give-up))      (give-up))
525    (let ((dim (continuation-value dimension)))    (let ((dim (continuation-value dimension)))
526      `(the (integer 0 ,dim) index)))      `(the (integer 0 (,dim)) index)))
527  ;;;  ;;;
528  (deftransform %check-bound ((array dimension index) * *  (deftransform %check-bound ((array dimension index) * *
529                              :policy (and (> speed safety) (= safety 0)))                              :policy (and (> speed safety) (= safety 0)))
# Line 552  Line 604 
604                    (if (byte-compiling)                    (if (byte-compiling)
605                        (values nil t)                        (values nil t)
606                        `(%aset (the ,',type ,a) ,@i))))))                        `(%aset (the ,',type ,a) ,@i))))))
   (frob svref %svset simple-vector)  
   (frob schar %scharset simple-string)  
   (frob char %charset string)  
607    (frob sbit %sbitset (simple-array bit))    (frob sbit %sbitset (simple-array bit))
608    (frob bit %bitset (array bit)))    (frob bit %bitset (array bit)))
609    
610    (macrolet ((frob (reffer setter type)
611                 `(progn
612                    (def-source-transform ,reffer (a i)
613                      (if (byte-compiling)
614                          (values nil t)
615                          `(aref (the ,',type ,a) ,i)))
616                    (def-source-transform ,setter (a i v)
617                      (if (byte-compiling)
618                          (values nil t)
619                          `(%aset (the ,',type ,a) ,i ,v))))))
620      (frob svref %svset simple-vector)
621      (frob schar %scharset simple-string)
622      (frob char %charset string))
623    
624  ;;; AREF, %ASET  --  transform.  ;;; AREF, %ASET  --  transform.
625  ;;;  ;;;
626  ;;; Convert into a data-vector-ref (or set) with the set of indices replaced  ;;; Convert into a data-vector-ref (or set) with the set of indices replaced
# Line 600  Line 663 
663                       '(bit-vector bit-vector &optional null) '*                       '(bit-vector bit-vector &optional null) '*
664                       :eval-name t  :policy (>= speed space))                       :eval-name t  :policy (>= speed space))
665      `(,fun bit-array-1 bit-array-2      `(,fun bit-array-1 bit-array-2
666             (make-array (length bit-array-1) :element-type 'bit)))             (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
667    ;;    ;;
668    ;; If result its T, make it the first arg.    ;; If result its T, make it the first arg.
669    (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)    (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)

Legend:
Removed from v.1.28.2.1  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5