Changeset 9389


Ignore:
Timestamp:
May 7, 2008, 10:12:45 PM (11 years ago)
Author:
greg
Message:

Add a compiler-macro for INTERN that attempts to resolve the package argument at load time if possible.

File:
1 edited

Legend:

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

    r9363 r9389  
    22;;;
    33;;;   Copyright (C) 1994-2001 Digitool, Inc
    4 ;;;   This file is part of OpenMCL. 
     4;;;   This file is part of OpenMCL.
    55;;;
    66;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
     
    88;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
    99;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
    10 ;;;   conflict, the preamble takes precedence. 
     10;;;   conflict, the preamble takes precedence.
    1111;;;
    1212;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
     
    5858    (let* ((bits (%symbol-bits name)))
    5959      (declare (fixnum bits))
    60       (%symbol-bits name (logior 
     60      (%symbol-bits name (logior
    6161                          (if handler (logior (ash 1 $sym_fbit_fold_subforms) (ash 1 $sym_fbit_constant_fold))
    6262                              (ash 1 $sym_fbit_constant_fold))
     
    118118              (push arg targs)
    119119              (return)))
    120         (return 
     120        (return
    121121         (fixnumify (nreverse targs) op))))
    122122    call))
     
    144144                            keys
    145145          (declare (ignore test-not))
    146           (if (and test-p 
     146          (if (and test-p
    147147                   (not test-not-p)
    148148                   (or (not key-p)
     
    153153                                (eq (%car key) 'quote))
    154154                            (eq (%cadr key) 'identity)))
    155                    (consp test) 
     155                   (consp test)
    156156                   (consp (%cdr test))
    157157                   (null (%cddr test))
     
    203203        (let* ((op (car call))
    204204               (constant (if (cdr constants) (handler-case (apply op constants)
    205                                                (error (c) (declare (ignore c)) 
     205                                               (error (c) (declare (ignore c))
    206206                                                      (return-from fold-constant-subforms (values call t))))
    207207                             (car constants))))
     
    256256;;;
    257257;;; The new (roughly alphabetical) order.
    258 ;;; 
     258;;;
    259259;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    260260
     
    302302  `(+ ,x 1))
    303303
    304 (define-compiler-macro append  (&whole call 
    305                                        &optional arg0 
    306                                        &rest 
    307                                        (&whole tail 
    308                                                &optional (junk nil arg1-p) 
     304(define-compiler-macro append  (&whole call
     305                                       &optional arg0
     306                                       &rest
     307                                       (&whole tail
     308                                               &optional (junk nil arg1-p)
    309309                                               &rest more))
    310310  ;(append (list x y z) A) -> (list* x y z A)
     
    338338        (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
    339339    (let ((original-fn fn))
    340       (if (and arg0 
     340      (if (and arg0
    341341               (null args)
    342342               (consp fn)
     
    368368    `(asseql ,item ,list)
    369369    call))
    370  
     370
    371371(define-compiler-macro asseql (&whole call &environment env item list)
    372372  (if (or (eql-iff-eq-p item env)
     
    424424(define-compiler-macro caaaar (form)
    425425  `(car (caaar ,form)))
    426  
     426
    427427(define-compiler-macro caaadr (form)
    428428  `(car (caadr ,form)))
     
    448448(define-compiler-macro cdaaar (form)
    449449  `(cdr (caaar ,form)))
    450  
     450
    451451(define-compiler-macro cdaadr (form)
    452452  `(cdr (caadr ,form)))
     
    492492     call))
    493493
    494 (define-compiler-macro dotimes (&whole call (i n &optional result) 
     494(define-compiler-macro dotimes (&whole call (i n &optional result)
    495495                                       &body body
    496496                                       &environment env)
     
    545545  (multiple-value-bind (test test-win) (nx-transform test env)
    546546    (if (or (quoted-form-p test) (self-evaluating-p test))
    547       (if (eval test) 
     547      (if (eval test)
    548548        true
    549549        false)
     
    559559      call)))
    560560
     561(defun string-designator-p (object)
     562  (typecase object
     563    (character t)
     564    (symbol t)
     565    (string t)))
     566
     567(defun package-designator-p (object)
     568  (or (string-designator-p object) (packagep object)))
     569
     570(define-compiler-macro intern (&whole call str &optional package)
     571  (if (or (and (quoted-form-p package) (package-designator-p (%cadr package)))
     572          (keywordp package)
     573          (stringp package))
     574    `(intern ,str (load-time-value (or (find-package ,package) ,package)))
     575    call))
    561576
    562577(define-compiler-macro ldb (&whole call &environment env byte integer)
     
    679694    (type-specifier ctype)))
    680695
    681      
    682      
     696
     697
    683698(define-compiler-macro make-array (&whole call &environment env dims &rest keys)
    684699  (if (constant-keywords-p keys)
     
    689704                              (fill-pointer () fill-pointer-p)
    690705                              (initial-element () initial-element-p)
    691                               (initial-contents () initial-contents-p)) 
     706                              (initial-contents () initial-contents-p))
    692707        keys
    693708      (declare (ignorable element-type element-type-p
     
    699714                          initial-contents initial-contents-p))
    700715      (let* ((element-type-keyword nil)
    701              (expansion 
     716             (expansion
    702717              (cond ((and initial-element-p initial-contents-p)
    703718                     (nx1-whine 'illegal-arguments call)
     
    707722                       (comp-make-array-1 dims keys)
    708723                       (comp-make-displaced-array dims keys)))
    709                     ((or displaced-index-offset-p 
     724                    ((or displaced-index-offset-p
    710725                         (not (constantp element-type))
    711726                         (null (setq element-type-keyword
     
    713728                                      (eval element-type) env))))
    714729                     (comp-make-array-1 dims keys))
    715                     ((and (typep element-type-keyword 'keyword) 
    716                           (nx-form-typep dims 'fixnum env) 
    717                           (null (or adjustable fill-pointer initial-contents 
    718                                     initial-contents-p))) 
    719                      (if 
    720                        (or (null initial-element-p) 
    721                            (cond ((eql element-type-keyword :double-float-vector) 
    722                                   (eql initial-element 0.0d0)) 
    723                                  ((eql element-type-keyword :single-float-vector) 
    724                                   (eql initial-element 0.0s0)) 
    725                                  ((eql element-type :simple-string) 
     730                    ((and (typep element-type-keyword 'keyword)
     731                          (nx-form-typep dims 'fixnum env)
     732                          (null (or adjustable fill-pointer initial-contents
     733                                    initial-contents-p)))
     734                     (if
     735                       (or (null initial-element-p)
     736                           (cond ((eql element-type-keyword :double-float-vector)
     737                                  (eql initial-element 0.0d0))
     738                                 ((eql element-type-keyword :single-float-vector)
     739                                  (eql initial-element 0.0s0))
     740                                 ((eql element-type :simple-string)
    726741                                  (eql initial-element #\Null))
    727742                                 (t (eql initial-element 0))))
    728                        `(allocate-typed-vector ,element-type-keyword ,dims) 
    729                        `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element))) 
     743                       `(allocate-typed-vector ,element-type-keyword ,dims)
     744                       `(allocate-typed-vector ,element-type-keyword ,dims ,initial-element)))
    730745                    (t                        ;Should do more here
    731746                     (comp-make-uarray dims keys (type-keyword-code element-type-keyword)))))
    732747             (type (infer-array-type dims element-type element-type-p displaced-to-p fill-pointer-p adjustable-p env)))
    733748        `(the ,type ,expansion)))
    734        
     749
    735750        call))
    736751
     
    767782  (let* ((call-list (make-list 10 :initial-element nil))
    768783         (dims-var (make-symbol "DIMS"))
    769          (let-list (comp-nuke-keys keys                                   
     784         (let-list (comp-nuke-keys keys
    770785                                   '((:element-type 0 1)
    771786                                     (:displaced-to 2)
     
    813828
    814829
    815                                  
     830
    816831
    817832(define-compiler-macro mapc  (&whole call fn lst &rest more)
     
    853868    `(memeql ,item ,list)
    854869    call))
    855  
     870
    856871(define-compiler-macro memeql (&whole call &environment env item list)
    857872  (if (or (eql-iff-eq-p item env)
     
    898913  (if (and (fixnump count)
    899914           (%i>= count 0)
    900            (%i< count 4)) 
     915           (%i< count 4))
    901916     (if (%izerop count)
    902917       `(require-type ,list 'list)
     
    949964               ((type= ctype
    950965                       (specifier-type '(signed-byte 8)))
    951                 `(the (signed-byte 8) (require-s8 ,arg)))               
     966                `(the (signed-byte 8) (require-s8 ,arg)))
    952967               ((type= ctype
    953968                       (specifier-type '(unsigned-byte 8)))
     
    958973               ((type= ctype
    959974                       (specifier-type '(unsigned-byte 16)))
    960                 `(the (unsigned-byte 16) (require-u16 ,arg)))               
     975                `(the (unsigned-byte 16) (require-u16 ,arg)))
    961976               ((type= ctype
    962977                       (specifier-type '(signed-byte 32)))
     
    11681183                 (dolist (,elt-var ,sequence (%cdr ,result-var))
    11691184                   (,loop-test (funcall ,test (funcall ,key ,elt-var))
    1170                                (setq ,temp-var 
    1171                                      (%cdr 
     1185                               (setq ,temp-var
     1186                                     (%cdr
    11721187                                      (%rplacd ,temp-var (list ,elt-var)))))))))
    11731188          call))
     
    12881303    `(not (logbitp 0 (the fixnum ,n0)))
    12891304    w))
    1290  
     1305
    12911306
    12921307(define-compiler-macro logandc2 (n0 n1)
     
    13281343              `(require-type ,n0 'integer)
    13291344              identity)))))))
    1330          
     1345
    13311346(define-compiler-macro logand (&whole w &rest all)
    13321347  (declare (ignore all))
     
    13511366    `(not (eql 0 (logand ,n1 ,n2)))
    13521367    w))
    1353  
     1368
    13541369
    13551370(defmacro defsynonym (from to)
     
    13581373     (setf (compiler-macro-function ',from) nil)
    13591374     (let ((pair (assq ',from *nx-synonyms*)))
    1360        (if pair (rplacd pair ',to) 
    1361            (push (cons ',from ',to) 
     1375       (if pair (rplacd pair ',to)
     1376           (push (cons ',from ',to)
    13621377                 *nx-synonyms*))
    13631378       ',to)))
     
    14861501        `(array-%%typep ,thing ,ctype))))))
    14871502
    1488                              
    1489  
     1503
     1504
    14901505(defun optimize-typep (thing type env)
    14911506  ;; returns a new form, or nil if it can't optimize
     
    15141529                           (t nil)))
    15151530                    ((consp type)
    1516                      (cond 
     1531                     (cond
    15171532                       ((info-type-builtin type) ; byte types
    15181533                        `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1519                        (t 
     1534                       (t
    15201535                        (case (%car type)
    15211536                          (satisfies `(funcall ',(cadr type) ,thing))
     
    16891704
    16901705
    1691                        
     1706
    16921707(defsynonym %get-unsigned-byte %get-byte)
    16931708(defsynonym %get-unsigned-word %get-word)
     
    17961811         (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
    17971812         (useful (unless (or (eq type *) (eq type t))
    1798                    type))) 
     1813                   type)))
    17991814    (if (= 2 (length subscripts))
    18001815      (setq call `(%aref2 ,a ,@subscripts))
     
    18931908
    18941909
    1895 (define-compiler-macro integerp (thing) 
     1910(define-compiler-macro integerp (thing)
    18961911  (let* ((typecode (gensym))
    18971912         (fixnum-tag (arch::target-fixnum-tag (backend-target-arch *target-backend*)))
     
    19291944                           (ash 1 x8664::subtag-double-float)
    19301945                           (ash 1 x8664::subtag-ratio))))))))
    1931        
     1946
    19321947(define-compiler-macro %composite-pointer-ref (size pointer offset)
    19331948  (if (constantp size)
     
    20292044
    20302045(define-compiler-macro float (&whole call number &optional (other 0.0f0 other-p) &environment env)
    2031  
     2046
    20322047  (cond ((and (typep other 'single-float)
    20332048              (nx-form-typep number 'double-float env))
     
    21062121        (and (integerp ,val) (not (< ,val 0)))))))
    21072122
    2108 
    2109 
    21102123(provide "OPTIMIZERS")
    2111 
    2112 
    2113 
    2114 
    2115 
    2116 
    2117 
Note: See TracChangeset for help on using the changeset viewer.