Changeset 7940
- Timestamp:
- Dec 25, 2007, 11:47:59 PM (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/optimizers.lisp
r7843 r7940 965 965 (specifier-type '(unsigned-byte 64))) 966 966 `(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 ,arg969 (load-time-value (find-builtin-cell ',type)))))970 967 ((and (symbolp type) 971 968 (let ((simpler (type-predicate type))) … … 973 970 ((and (symbolp type)(find-class type nil env)) 974 971 `(%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))))))) 976 977 (t call))) 977 978 … … 1388 1389 (null (%cdr (%cdr form))))) 1389 1390 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 1390 1481 (defun optimize-typep (thing type env) 1391 1482 ;; 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)))))))) 1434 1528 1435 1529 (define-compiler-macro typep (&whole call &environment env thing type &optional e) … … 1438 1532 (or (optimize-typep thing (%cadr type) env) 1439 1533 call) 1440 call)) 1534 (if (eq type t) 1535 `(progn ,thing t) 1536 call))) 1441 1537 1442 1538 (define-compiler-macro true (&rest args) … … 1750 1846 `(simple-base-string-p ,thing)) 1751 1847 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 1752 1863 1753 1864 (defsetf %misc-ref %misc-set) … … 1765 1876 `(let* ((,typecode (typecode ,thing))) 1766 1877 (declare (fixnum ,typecode)) 1767 (or (= ,typecode ,fixnum-tag) 1768 (= ,typecode ,bignum-tag))))) 1878 (if (= ,typecode ,fixnum-tag) 1879 t 1880 (= ,typecode ,bignum-tag))))) 1769 1881 1770 1882 (define-compiler-macro %composite-pointer-ref (size pointer offset)
Note:
See TracChangeset
for help on using the changeset viewer.
