Changeset 10432


Ignore:
Timestamp:
Aug 11, 2008, 6:48:48 AM (11 years ago)
Author:
gb
Message:

(Mostly) propagate working-0711 branch version to trunk.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/optimizers.lisp

    r10378 r10432  
    15301530        (if (and predicate (symbolp predicate))
    15311531          `(,predicate ,thing)
    1532           (or (optimize-ctypep thing ctype)
    1533               (cond ((symbolp type)
    1534                      (cond ((%deftype-expander type)
    1535                             ;; recurse here, rather than returning the
    1536                             ;; partially-expanded form mostly since it doesn't
    1537                             ;; seem to further optimize the result otherwise
    1538                             (let ((expanded-type (type-expand type)))
    1539                               (or (optimize-typep thing expanded-type env)
    1540                                   ;; at least do the first expansion
    1541                                   `(typep ,thing ',expanded-type))))
    1542                            ((structure-class-p type env)
    1543                             `(structure-typep ,thing ',type))
    1544                            ((find-class type nil env)
    1545                             `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
    1546                            ((info-type-builtin type) ; bootstrap troubles here?
     1532          (let* ((pair (assq type *istruct-cells*))
     1533                 (class (and pair (%wrapper-class (istruct-cell-info pair)))))
     1534            (if (and class (not (%class-direct-subclasses class)))
     1535              `(istruct-typep ,thing ',type)             
     1536              (or (optimize-ctypep thing ctype)
     1537                  (cond ((symbolp type)
     1538                         (cond ((%deftype-expander type)
     1539                                ;; recurse here, rather than returning the
     1540                                ;; partially-expanded form mostly since it doesn't
     1541                                ;; seem to further optimize the result otherwise
     1542                                (let ((expanded-type (type-expand type)))
     1543                                  (or (optimize-typep thing expanded-type env)
     1544                                      ;; at least do the first expansion
     1545                                      `(typep ,thing ',expanded-type))))
     1546                               ((structure-class-p type env)
     1547                                `(structure-typep ,thing ',(find-class-cell type t)))
     1548                               ((find-class type nil env)
     1549                                (let* ((class (find-class type nil nil))
     1550                                       (fname
     1551                                        (if (or (null class)
     1552                                                (and (subtypep class 'standard-object)
     1553                                                     (not (subtypep class 'foreign-standard-object))))
     1554                                          'std-instance-class-cell-typep
     1555                                          'class-cell-typep)))
     1556                                  `(,fname ,thing (load-time-value (find-class-cell ',type t)))))
     1557                               ((info-type-builtin type) ; bootstrap troubles here?
     1558                                `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1559                               (t nil)))
     1560                        ((consp type)
     1561                         (cond
     1562                           ((info-type-builtin type) ; byte types
    15471563                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1548                            (t nil)))
    1549                     ((consp type)
    1550                      (cond
    1551                        ((info-type-builtin type) ; byte types
    1552                         `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1553                        (t
    1554                         (case (%car type)
    1555                           (satisfies `(funcall ',(cadr type) ,thing))
    1556                           (eql `(eql ,thing ',(cadr type)))
    1557                           (member `(not (null (member ,thing ',(%cdr type)))))
    1558                           (not `(not (typep ,thing ',(cadr type))))
    1559                           ((or and)
    1560                            (let ((thing-sym (gensym)))
    1561                              `(let ((,thing-sym ,thing))
    1562                                (,(%car type)
    1563                                 ,@(mapcar #'(lambda (type-spec)
    1564                                               (or (optimize-typep thing-sym type-spec env)
    1565                                                   `(typep ,thing-sym ',type-spec)))
    1566                                           (%cdr type))))))
    1567                           ((signed-byte unsigned-byte integer mod) ; more byte types
    1568                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1569                           (t nil)))))
    1570                     (t nil))))))))
     1564                           (t
     1565                            (case (%car type)
     1566                              (satisfies `(funcall ',(cadr type) ,thing))
     1567                              (eql `(eql ,thing ',(cadr type)))
     1568                              (member `(not (null (member ,thing ',(%cdr type)))))
     1569                              (not `(not (typep ,thing ',(cadr type))))
     1570                              ((or and)
     1571                               (let ((thing-sym (gensym)))
     1572                                 `(let ((,thing-sym ,thing))
     1573                                   (,(%car type)
     1574                                    ,@(mapcar #'(lambda (type-spec)
     1575                                                  (or (optimize-typep thing-sym type-spec env)
     1576                                                      `(typep ,thing-sym ',type-spec)))
     1577                                              (%cdr type))))))
     1578                              ((signed-byte unsigned-byte integer mod) ; more byte types
     1579                               `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1580                              (t nil)))))
     1581                        (t nil))))))))))
    15711582
    15721583(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
     
    15791590      `(progn ,thing t)
    15801591      call)))
     1592
     1593(define-compiler-macro structure-typep (&whole w thing type)
     1594  (if (not (quoted-form-p type))
     1595    (progn
     1596      (warn "Non-qouted structure-type in ~s" w)
     1597      w)
     1598    (let* ((type (nx-unquote type)))
     1599      (if (symbolp type)
     1600        `(structure-typep ,thing ',(find-class-cell type t))
     1601        w))))
    15811602
    15821603(define-compiler-macro true (&rest args)
     
    17221743
    17231744
    1724 
     1745(define-compiler-macro slot-boundp (&whole whole instance slot-name-form)
     1746  (let* ((name (and (quoted-form-p slot-name-form)
     1747                    (typep (cadr slot-name-form) 'symbol)
     1748                    (cadr slot-name-form))))
     1749    (if name
     1750      `(slot-id-boundp ,instance (load-time-value (ensure-slot-id ',name)))
     1751      whole)))
    17251752
    17261753(defsynonym %get-unsigned-byte %get-byte)
     
    18781905
    18791906
     1907(define-compiler-macro write-string (&environment env &whole call
     1908                                                  string &optional (stream nil) &rest keys)
     1909  (if (nx-form-typep string 'simple-string env)
     1910    (if keys
     1911      `((lambda (string stream &key start end)
     1912          (write-simple-string string stream start end))
     1913        ,string ,stream ,@keys)
     1914      `(write-simple-string ,string ,stream 0 nil))
     1915    call))
     1916
     1917(define-compiler-macro format (&environment env &whole call stream string &rest args)
     1918  (if (stringp string)
     1919    (cond ((string-equal string "~a")
     1920           (destructuring-bind (object) args
     1921             (cond ((null stream)
     1922                    `(princ-to-string ,object))
     1923                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1924                    `(progn (princ ,object ,(and (neq stream t) stream)) nil))
     1925                   (t `(let ((stream ,stream)
     1926                             (object ,object))
     1927                         (if (or (null stream) (stringp stream))
     1928                           (format-to-string stream ,string object)
     1929                           (progn (princ object (and (neq stream t) stream)) nil)))))))
     1930          ((string-equal string "~s")
     1931           (destructuring-bind (object) args
     1932             (cond ((null stream)
     1933                    `(prin1-to-string ,object))
     1934                   ((or (eq stream t) (nx-form-typep stream 'stream env))
     1935                    `(progn (prin1 ,object ,(and (neq stream t) stream)) nil))
     1936                   (t `(let ((stream ,stream)
     1937                             (object ,object))
     1938                         (if (or (null stream) (stringp stream))
     1939                           (format-to-string stream ,string object)
     1940                           (progn (prin1 object (and (neq stream t) stream)) nil)))))))
     1941          ((and (null (position #\~ string)) (null args))
     1942           (cond ((null stream)
     1943                  string)
     1944                 ((or (eq stream t) (nx-form-typep stream 'stream env))
     1945                  `(progn (write-string ,string ,(and (neq stream t) stream)) nil))
     1946                 (t `(let ((stream ,stream))
     1947                       (if (or (null stream) (stringp stream))
     1948                         (format-to-string stream ,string)
     1949                         (progn (write-string ,string (and (neq stream t) stream)) nil))))))
     1950          ((optimize-format-call stream string args env))
     1951          (t call))
     1952    call))
     1953
     1954(defun count-known-format-args (string start end)
     1955  (declare (fixnum start end))
     1956  (loop with count = 0
     1957        do (setq start (position #\~ string :start start :end end))
     1958        when (null start)
     1959          do (return count)
     1960        unless (< (incf start) end)
     1961          do (return nil)
     1962        do (let ((ch (aref string start)))
     1963             (cond ((memq ch '(#\a #\A #\s #\S)) (incf count))
     1964                   ((memq ch '(#\~ #\% #\&)))
     1965                   (t (return nil)))
     1966             (incf start))))
     1967
     1968(defun optimize-format-call (stream string args env)
     1969  (let* ((start (or (search "~/" string)
     1970                    (return-from optimize-format-call nil)))
     1971         (ipos (+ start 2))
     1972         (epos (or (position #\/ string :start ipos)
     1973                   (return-from optimize-format-call nil)))
     1974         (nargs (or (count-known-format-args string 0 start)
     1975                    (return-from optimize-format-call nil))))
     1976    (when (and
     1977           ;; Must be able to split args
     1978           (< nargs (length args))
     1979           ;; Don't deal with packages
     1980           (not (position #\: string :start ipos :end epos)))
     1981      (let* ((func (intern (string-upcase (subseq string ipos epos)) :cl-user))
     1982             (prev (and (< 0 start) (subseq string 0 start)))
     1983             (prev-args (subseq args 0 nargs))
     1984             (rest (and (< (1+ epos) (length string)) (subseq string (1+ epos))))
     1985             (rest-args (nthcdr nargs args))
     1986             (obj (pop rest-args))
     1987             (stream-var (gensym))
     1988             (body `(,@(and prev `((format ,stream-var ,prev ,@prev-args)))
     1989                       (,func ,stream-var ,obj nil nil)
     1990                       ,(if rest `(format ,stream-var ,rest ,@rest-args) `nil))))
     1991        (cond ((null stream)
     1992               `(with-output-to-string (,stream-var)
     1993                  (declare (type stream ,stream-var))
     1994                  ,@body))
     1995              ((or (eq stream t) (nx-form-typep stream 'stream env))
     1996               `(let ((,stream-var ,(if (eq stream t) '*standard-output* stream)))
     1997                  (declare (type stream ,stream-var))
     1998                  ,@body))
     1999              (t
     2000               `(let ((,stream-var ,stream))
     2001                  (if (or (null ,stream-var) (stringp ,stream-var))
     2002                    (format-to-string ,stream-var ,string ,@args)
     2003                    (let ((,stream-var
     2004                           (if (eq ,stream-var t) *standard-output* ,stream-var)))
     2005                      ;; For the purposes of body, it's ok to assume stream-var
     2006                      ;; is a stream. method dispatch will signal any errors
     2007                      ;; at runtime if it's not true...
     2008                      (declare (type stream ,stream-var))
     2009                      ,@body)))))))))
     2010
     2011
    18802012(define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
    18812013  (if (and sub0 (null others))
     
    19312063        t
    19322064        (= ,typecode ,bignum-tag)))))
     2065
     2066(define-compiler-macro realp (&whole call x)
     2067  (if (not (eq *host-backend* *target-backend*))
     2068    call
     2069    (let* ((typecode (gensym)))
     2070      `(let* ((,typecode (typecode ,x)))
     2071        (declare (type (unsigned-byte 8) ,typecode))
     2072        #+ppc32-target
     2073        (or (= ,typecode ppc32::tag-fixnum)
     2074         (and (>= ,typecode ppc32::min-numeric-subtag)
     2075          (<= ,typecode ppc32::max-real-subtag)))
     2076        #+ppc64-target
     2077        (if (<= ,typecode ppc64::subtag-double-float)
     2078          (logbitp (the (integer 0 #.ppc64::subtag-double-float) ,typecode)
     2079                   (logior (ash 1 ppc64::tag-fixnum)
     2080                           (ash 1 ppc64::subtag-single-float)
     2081                           (ash 1 ppc64::subtag-double-float)
     2082                           (ash 1 ppc64::subtag-bignum)
     2083                           (ash 1 ppc64::subtag-ratio))))
     2084        #+x8664-target
     2085        (if (<= ,typecode x8664::subtag-double-float)
     2086          (logbitp (the (integer 0 #.x8664::subtag-double-float) ,typecode)
     2087                   (logior (ash 1 x8664::tag-fixnum)
     2088                           (ash 1 x8664::subtag-bignum)
     2089                           (ash 1 x8664::tag-single-float)
     2090                           (ash 1 x8664::subtag-double-float)
     2091                           (ash 1 x8664::subtag-ratio))))))))
    19332092
    19342093(define-compiler-macro %composite-pointer-ref (size pointer offset)
     
    21042263          (%non-standard-instance-slots ,itemp ,typecode))))))
    21052264
    2106 
    21072265(define-compiler-macro instance-class-wrapper (instance)
    21082266  (let* ((itemp (gensym)))
     
    21172275  `(%wrapper-class (instance.class-wrapper ,instance)))
    21182276
     2277(define-compiler-macro standard-object-p (thing)
     2278  (let* ((temp (gensym))
     2279         (typecode (gensym)))
     2280    `(let* ((,temp ,thing)
     2281            (,typecode (typecode ,temp)))
     2282      (declare (type (unsigned-byte 8) ,typecode))
     2283      (if (= ,typecode ,(nx-lookup-target-uvector-subtag :instance))
     2284        (instance.class-wrapper ,temp)
     2285        (if (= ,typecode ,(nx-lookup-target-uvector-subtag :macptr))
     2286          (foreign-instance-class-wrapper ,temp))))))
     2287
     2288(define-compiler-macro %class-ordinal (class &optional error)
     2289  (let* ((temp (gensym)))
     2290    `(let* ((,temp ,class))
     2291      (if (eql (the (unsigned-byte 8) (typecode ,temp))
     2292               ,(nx-lookup-target-uvector-subtag :instance))
     2293        (instance.hash ,temp)
     2294        (funcall '%class-ordinal ,temp ,error)))))
     2295
     2296(define-compiler-macro native-class-p (class)
     2297  (let* ((temp (gensym)))
     2298    `(let* ((,temp ,class))
     2299      (if (eql (the (unsigned-byte 8) (typecode ,temp))
     2300               ,(nx-lookup-target-uvector-subtag :instance))
     2301        (< (the fixnum (instance.hash ,temp)) max-class-ordinal)))))
     2302 
     2303
     2304
    21192305(define-compiler-macro unsigned-byte-p (x)
    21202306  (if (typep (nx-unquote x) 'unsigned-byte)
     
    21232309      `(let* ((,val ,x))
    21242310        (and (integerp ,val) (not (< ,val 0)))))))
     2311
     2312(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv  &environment env)
     2313  (if (and (consp t1)
     2314           (consp (cdr t1))
     2315           (null (cddr t1))
     2316           (eq (car t1) 'type-of))
     2317    ;; People really write code like this.  I've seen it.
     2318    `(typep ,(cadr t1) ,t2 ,@(and rtenv `(,rtenv)))
     2319    (if (and (null rtenv) (quoted-form-p t2))
     2320      `(cell-csubtypep-2 ,t1 (load-time-value (register-type-cell ,t2)))
     2321      w)))
     2322
    21252323
    21262324(define-compiler-macro string-equal (&whole w s1 s2 &rest keys)
     
    21332331          (%bounded-string-equal ,s1-arg ,s2-arg start1 end1 start2 end2))
    21342332        ,s1 ,s2 ,@keys))))
    2135 
    21362333
    21372334;;; Try to use "package-references" to speed up package lookup when
Note: See TracChangeset for help on using the changeset viewer.