Changeset 7940


Ignore:
Timestamp:
Dec 26, 2007, 7:47:59 AM (12 years ago)
Author:
gb
Message:

Try harder (maybe much harder) to inline TYPEP calls involving
integers/floats and vector types.
Always inline REQUIRE-TYPE, on the theory that TYPEP will likely
inline.

File:
1 edited

Legend:

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

    r7843 r7940  
    965965                       (specifier-type '(unsigned-byte 64)))
    966966                `(the (unsigned-byte 64) (require-u64 ,arg)))               
    967                ((and (consp type)(memq (car type) '(signed-byte unsigned-byte integer)))
    968                 `(the ,type (%require-type-builtin ,arg
    969                                                    (load-time-value (find-builtin-cell ',type)))))
    970967               ((and (symbolp type)
    971968                     (let ((simpler (type-predicate type)))
     
    973970               ((and (symbolp type)(find-class type nil env))
    974971                  `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
    975                (t call)))
     972               (t (let* ((val (gensym)))
     973                    `(let* ((,val ,arg))
     974                      (if (typep ,val ',type)
     975                        ,val
     976                        (%kernel-restart $xwrongtype ,val ',type)))))))
    976977        (t call)))
    977978
     
    13881389        (null (%cdr (%cdr form)))))
    13891390
     1391
     1392;; Return a form that checks to see if THING is if type CTYPE, or
     1393;; NIL if we can't do that for some reason.
     1394(defun optimize-ctypep (thing ctype)
     1395  (when (eq *target-backend* *host-backend*)
     1396    (typecase ctype
     1397      (numeric-ctype
     1398       (cond ((eq :real (numeric-ctype-complexp ctype))
     1399              (let* ((low (numeric-ctype-low ctype))
     1400                     (high (numeric-ctype-high ctype))
     1401                     (class (numeric-ctype-class ctype))
     1402                     (format (numeric-ctype-format ctype))
     1403                     (type (if (eq class 'float)
     1404                             (or format class)
     1405                             class)))
     1406                (cond ((and low (eql low high) (or (not (eq class 'float))
     1407                                                   format))
     1408                       `(eql ,thing ,low))
     1409                      ((and (eq type 'float)
     1410                            (or low high)
     1411                            (or (null low)
     1412                                (typep low 'single-float)
     1413                                (not (null (ignore-errors
     1414                                             (coerce (if (atom low)
     1415                                                       low
     1416                                                       (car low))
     1417                                                     'single-float)))))
     1418                            (or (null high)
     1419                                (typep high 'single-float)
     1420                                (not (null (ignore-errors
     1421                                             (coerce (if (atom high)
     1422                                                       high
     1423                                                       (car high))
     1424                                                     'single-float))))))
     1425                       (let* ((temp (gensym)))
     1426                         (flet ((bounded-float (type low high)
     1427                                  `(,type
     1428                                    ,(if low
     1429                                         (if (listp low)
     1430                                           (list (coerce (car low) type))
     1431                                           (coerce low type))
     1432                                         '*)
     1433                                    ,(if high
     1434                                         (if (listp high)
     1435                                           (list (coerce (car high) type))
     1436                                           (coerce high type))
     1437                                         '*))))
     1438                         `(let* ((,temp ,thing))
     1439                           (or (typep ,temp ',(bounded-float 'single-float low high))
     1440                            (typep ,temp ',(bounded-float 'double-float low high)))))))
     1441                      (t
     1442                       (let* ((temp (gensym)))
     1443                         (if (and (typep low 'fixnum) (typep high 'fixnum))
     1444                           (setq type 'fixnum))
     1445                         (if (or low high)
     1446                           `(let* ((,temp ,thing))
     1447                             (and (typep ,temp ',type)
     1448                              ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low))))
     1449                              ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high))))))
     1450                           `(typep ,thing ',type)))))))
     1451             (t `(numeric-%%typep ,thing ,ctype))))
     1452      (array-ctype
     1453       (or
     1454        (let* ((typecode (array-ctype-typecode ctype))
     1455               (dims (array-ctype-dimensions ctype)))
     1456          (cond ((and typecode (consp dims) (null (cdr dims)))
     1457                 (case (array-ctype-complexp ctype)
     1458                   ((nil)
     1459                    (if (eq (car dims) '*)
     1460                      `(eql (typecode ,thing) ,typecode)
     1461                      (let* ((temp (gensym)))
     1462                        `(let* ((,temp ,thing))
     1463                          (and (eql (typecode ,temp) ,typecode)
     1464                           (eq (uvsize ,temp) ,(car dims)))))))
     1465                   ((* :maybe)
     1466                    (let* ((temp (gensym))
     1467                           (tempcode (gensym)))
     1468                      `(let* ((,temp ,thing)
     1469                              (,tempcode (typecode ,temp)))
     1470                        (or (and (eql ,tempcode ,typecode)
     1471                             ,@(unless (eq (car dims) '*)
     1472                                       `((eq (uvize ,temp) ,(car dims)))))
     1473                         (and (eql ,tempcode target::subtag-vectorH)
     1474                          (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode)
     1475                          ,@(unless (eq (car dims) '*)
     1476                                    `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims)))))))))))))
     1477        `(array-%%typep ,thing ,ctype))))))
     1478
     1479                             
     1480 
    13901481(defun optimize-typep (thing type env)
    13911482  ;; returns a new form, or nil if it can't optimize
    1392   (cond ((symbolp type)
    1393          (let ((typep (type-predicate type)))
    1394            (cond ((and typep
    1395                        (symbolp typep))
    1396                   `(,typep ,thing))
    1397                  ((%deftype-expander type)
    1398                   ;; recurse here, rather than returning the
    1399                   ;; partially-expanded form mostly since it doesn't
    1400                   ;; seem to further optimize the result otherwise
    1401                   (let ((expanded-type (type-expand type)))
    1402                     (or (optimize-typep thing expanded-type env)
    1403                         ;; at least do the first expansion
    1404                         `(typep ,thing ',expanded-type))))
    1405                  ((structure-class-p type env)
    1406                   `(structure-typep ,thing ',type))
    1407                  ((find-class type nil env)
    1408                   `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
    1409                  ((info-type-builtin type) ; bootstrap troubles here?
    1410                   `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1411                  (t nil))))
    1412         ((consp type)
    1413          (cond
    1414           ((info-type-builtin type)  ; byte types
    1415            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1416           (t
    1417            (case (%car type)
    1418              (satisfies `(funcall ',(cadr type) ,thing))
    1419              (eql `(eql ,thing ',(cadr type)))
    1420              (member `(not (null (member ,thing ',(%cdr type)))))
    1421              (not `(not (typep ,thing ',(cadr type))))
    1422              ((or and)
    1423               (let ((thing-sym (gensym)))
    1424                 `(let ((,thing-sym ,thing))
    1425                    (,(%car type)
    1426                     ,@(mapcar #'(lambda (type-spec)
    1427                                   (or (optimize-typep thing-sym type-spec env)
    1428                                       `(typep ,thing-sym ',type-spec)))
    1429                               (%cdr type))))))
    1430              ((signed-byte unsigned-byte integer mod)  ; more byte types
    1431               `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
    1432              (t nil)))))
    1433         (t nil)))
     1483  (let* ((ctype (ignore-errors (specifier-type type))))
     1484    (when (and ctype (not (typep ctype 'unknown-ctype)))
     1485      (let* ((type (type-specifier ctype))
     1486             (predicate (if (typep type 'symbol) (type-predicate type))))
     1487        (if (and predicate (symbolp predicate))
     1488          `(,predicate ,thing)
     1489          (or (optimize-ctypep thing ctype)
     1490              (cond ((symbolp type)
     1491                     (cond ((%deftype-expander type)
     1492                            ;; recurse here, rather than returning the
     1493                            ;; partially-expanded form mostly since it doesn't
     1494                            ;; seem to further optimize the result otherwise
     1495                            (let ((expanded-type (type-expand type)))
     1496                              (or (optimize-typep thing expanded-type env)
     1497                                  ;; at least do the first expansion
     1498                                  `(typep ,thing ',expanded-type))))
     1499                           ((structure-class-p type env)
     1500                            `(structure-typep ,thing ',type))
     1501                           ((find-class type nil env)
     1502                            `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t))))
     1503                           ((info-type-builtin type) ; bootstrap troubles here?
     1504                            `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1505                           (t nil)))
     1506                    ((consp type)
     1507                     (cond
     1508                       ((info-type-builtin type) ; byte types
     1509                        `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1510                       (t
     1511                        (case (%car type)
     1512                          (satisfies `(funcall ',(cadr type) ,thing))
     1513                          (eql `(eql ,thing ',(cadr type)))
     1514                          (member `(not (null (member ,thing ',(%cdr type)))))
     1515                          (not `(not (typep ,thing ',(cadr type))))
     1516                          ((or and)
     1517                           (let ((thing-sym (gensym)))
     1518                             `(let ((,thing-sym ,thing))
     1519                               (,(%car type)
     1520                                ,@(mapcar #'(lambda (type-spec)
     1521                                              (or (optimize-typep thing-sym type-spec env)
     1522                                                  `(typep ,thing-sym ',type-spec)))
     1523                                          (%cdr type))))))
     1524                          ((signed-byte unsigned-byte integer mod) ; more byte types
     1525                           `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type))))
     1526                          (t nil)))))
     1527                    (t nil))))))))
    14341528
    14351529(define-compiler-macro typep  (&whole call &environment env thing type &optional e)
     
    14381532    (or (optimize-typep thing (%cadr type) env)
    14391533        call)
    1440     call))
     1534    (if (eq type t)
     1535      `(progn ,thing t)
     1536      call)))
    14411537
    14421538(define-compiler-macro true (&rest args)
     
    17501846  `(simple-base-string-p ,thing))
    17511847
     1848(define-compiler-macro stringp (thing)
     1849  `(base-string-p  ,thing))
     1850
     1851(define-compiler-macro base-string-p (thing)
     1852  (let* ((gthing (gensym))
     1853         (gtype (gensym)))
     1854    `(let* ((,gthing ,thing)
     1855            (,gtype (typecode ,thing)))
     1856      (declare (type (unsigned-byte 8) ,gtype))
     1857      (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header))
     1858        (= (the (unsigned-byte 8)
     1859             (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell))))
     1860           ,(nx-lookup-target-uvector-subtag :simple-string))
     1861        (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string))))))
     1862
    17521863
    17531864(defsetf %misc-ref %misc-set)
     
    17651876    `(let* ((,typecode (typecode ,thing)))
    17661877      (declare (fixnum ,typecode))
    1767       (or (= ,typecode ,fixnum-tag)
    1768        (= ,typecode ,bignum-tag)))))
     1878      (if (= ,typecode ,fixnum-tag)
     1879        t
     1880        (= ,typecode ,bignum-tag)))))
    17691881       
    17701882(define-compiler-macro %composite-pointer-ref (size pointer offset)
Note: See TracChangeset for help on using the changeset viewer.