Changeset 11822


Ignore:
Timestamp:
Mar 18, 2009, 11:53:18 PM (10 years ago)
Author:
gz
Message:

Don't expand require-type and make-array into THE if aren't going to trust declarations anyway. If do trust declarations, add the THE even if don't use a special operator for require-type. Fix declaration in dotimes optimizer.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r11807 r11822  
    513513             ,@decls
    514514             (declare (fixnum ,limit)
    515                       (type (integer 0 ,(if (<= upper 0) 0 `(,upper))) ,i)
     515                      (type (integer 0 ,(if (<= upper 0) 0 upper)) ,i)
    516516                      (unsettable ,i))
    517517             (block nil
     
    755755                    (t                        ;Should do more here
    756756                     (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
    757              (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
     757             (type (if (nx-trust-declarations env)
     758                     (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)
     759                     t)))
    758760        `(the ,type ,expansion)))
    759761
     
    957959              (setq ctype (specifier-type-if-known type env)))
    958960         (cond ((nx-form-typep arg type env) arg)
    959                ((eq type 'simple-vector)
    960                 `(the simple-vector (require-simple-vector ,arg)))
    961                ((eq type 'simple-string)
    962                 `(the simple-string (require-simple-string ,arg)))
    963                ((eq type 'integer)
    964                 `(the integer (require-integer ,arg)))
    965                ((eq type 'fixnum)
    966                 `(the fixnum (require-fixnum ,arg)))
    967                ((eq type 'real)
    968                 `(the real (require-real ,arg)))
    969                ((eq type 'list)
    970                 `(the list (require-list ,arg)))
    971                ((eq type 'character)
    972                 `(the character (require-character ,arg)))
    973                ((eq type 'number)
    974                 `(the number (require-number ,arg)))
    975                ((eq type 'symbol)
    976                 `(the symbol (require-symbol ,arg)))
    977                ((type= ctype
    978                        (specifier-type '(signed-byte 8)))
    979                 `(the (signed-byte 8) (require-s8 ,arg)))
    980                ((type= ctype
    981                        (specifier-type '(unsigned-byte 8)))
    982                 `(the (unsigned-byte 8) (require-u8 ,arg)))
    983                ((type= ctype
    984                        (specifier-type '(signed-byte 16)))
    985                 `(the (signed-byte 16) (require-s16 ,arg)))
    986                ((type= ctype
    987                        (specifier-type '(unsigned-byte 16)))
    988                 `(the (unsigned-byte 16) (require-u16 ,arg)))
    989                ((type= ctype
    990                        (specifier-type '(signed-byte 32)))
    991                 `(the (signed-byte 32) (require-s32 ,arg)))
    992                ((type= ctype
    993                        (specifier-type '(unsigned-byte 32)))
    994                 `(the (unsigned-byte 32) (require-u32 ,arg)))
    995                ((type= ctype
    996                        (specifier-type '(signed-byte 64)))
    997                 `(the (signed-byte 64) (require-s64 ,arg)))
    998                ((type= ctype
    999                        (specifier-type '(unsigned-byte 64)))
    1000                 `(the (unsigned-byte 64) (require-u64 ,arg)))
    1001                #+nil
    1002                ((and (symbolp type)
    1003                      (let ((simpler (type-predicate type)))
    1004                        (if simpler `(the ,type (%require-type ,arg ',simpler))))))
    1005                #+nil
    1006                ((and (symbolp type)(find-class type nil env))
    1007                   `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
     961               ((and (nx-trust-declarations env) ;; if don't trust declarations, don't bother.
     962                     (cond ((eq type 'simple-vector)
     963                            `(the simple-vector (require-simple-vector ,arg)))
     964                           ((eq type 'simple-string)
     965                            `(the simple-string (require-simple-string ,arg)))
     966                           ((eq type 'integer)
     967                            `(the integer (require-integer ,arg)))
     968                           ((eq type 'fixnum)
     969                            `(the fixnum (require-fixnum ,arg)))
     970                           ((eq type 'real)
     971                            `(the real (require-real ,arg)))
     972                           ((eq type 'list)
     973                            `(the list (require-list ,arg)))
     974                           ((eq type 'character)
     975                            `(the character (require-character ,arg)))
     976                           ((eq type 'number)
     977                            `(the number (require-number ,arg)))
     978                           ((eq type 'symbol)
     979                            `(the symbol (require-symbol ,arg)))
     980                           ((type= ctype
     981                                   (specifier-type '(signed-byte 8)))
     982                            `(the (signed-byte 8) (require-s8 ,arg)))
     983                           ((type= ctype
     984                                   (specifier-type '(unsigned-byte 8)))
     985                            `(the (unsigned-byte 8) (require-u8 ,arg)))
     986                           ((type= ctype
     987                                   (specifier-type '(signed-byte 16)))
     988                            `(the (signed-byte 16) (require-s16 ,arg)))
     989                           ((type= ctype
     990                                   (specifier-type '(unsigned-byte 16)))
     991                            `(the (unsigned-byte 16) (require-u16 ,arg)))
     992                           ((type= ctype
     993                                   (specifier-type '(signed-byte 32)))
     994                            `(the (signed-byte 32) (require-s32 ,arg)))
     995                           ((type= ctype
     996                                   (specifier-type '(unsigned-byte 32)))
     997                            `(the (unsigned-byte 32) (require-u32 ,arg)))
     998                           ((type= ctype
     999                                   (specifier-type '(signed-byte 64)))
     1000                            `(the (signed-byte 64) (require-s64 ,arg)))
     1001                           ((type= ctype
     1002                                   (specifier-type '(unsigned-byte 64)))
     1003                            `(the (unsigned-byte 64) (require-u64 ,arg)))
     1004                           #+nil
     1005                           ((and (symbolp type)
     1006                                 (let ((simpler (type-predicate type)))
     1007                                   (if simpler `(the ,type (%require-type ,arg ',simpler))))))
     1008                           #+nil
     1009                           ((and (symbolp type)(find-class type nil env))
     1010                            `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
     1011                           (t (let* ((val (gensym)))
     1012                                `(the ,type
     1013                                   (let* ((,val ,arg))
     1014                                     (if (typep ,val ',type)
     1015                                       ,val
     1016                                       (%kernel-restart $xwrongtype ,val ',type)))))))))
    10081017               (t (let* ((val (gensym)))
    10091018                    `(let* ((,val ,arg))
    1010                       (if (typep ,val ',type)
    1011                         ,val
    1012                         (%kernel-restart $xwrongtype ,val ',type)))))))
     1019                       (if (typep ,val ',type)
     1020                         ,val
     1021                         (%kernel-restart $xwrongtype ,val ',type)))))))
    10131022        (t call)))
    10141023
Note: See TracChangeset for help on using the changeset viewer.