Changeset 9338


Ignore:
Timestamp:
May 1, 2008, 7:30:05 AM (11 years ago)
Author:
gz
Message:

Support for compile-time classes: make SPECIFIER-TYPE accept
an optional environment arg and pass it around as appropriate,
so that compile-time classes are accepted in type expressions
(and are represented by a CLASS-CTYPE whose CLASS-CTYPE-CLASS
is a COMPILE-TIME-CLASS).

Make assorted compiler macros pass the environment into
SPECIFIER-TYPE, so they access the compile-time class info.

Make define-compile-time-structure define a compile-time class
for the structure.

Location:
branches/working-0711/ccl
Files:
3 edited

Legend:

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

    r9245 r9338  
    624624      `(progn ,@body))))
    625625
    626 (defun specifier-type-if-known (typespec)
    627   (handler-case (specifier-type typespec)
    628     (parse-unknown-type () nil)
     626(defun specifier-type-if-known (typespec &optional env)
     627  (handler-case (specifier-type typespec env)
     628    (parse-unknown-type (c) (values nil (parse-unknown-type-specifier c)))
    629629    (error () nil)))
    630630
    631631
    632 (defun target-element-type-type-keyword (typespec)
    633   (let* ((ctype (specifier-type-if-known `(array ,typespec))))
     632(defun target-element-type-type-keyword (typespec &optional env)
     633  (let* ((ctype (specifier-type-if-known `(array ,typespec) env)))
    634634    (if (null ctype)
    635635      (progn
     
    671671                '*))))
    672672    (let* ((typespec (if element-type-p (nx-unquote element-type) t))
    673            (element-type (or (specifier-type-if-known typespec)
     673           (element-type (or (specifier-type-if-known typespec env)
    674674                             (make-unknown-ctype :specifier typespec))))
    675675      (setf (array-ctype-element-type ctype) element-type)
     
    711711                         (null (setq element-type-keyword
    712712                                     (target-element-type-type-keyword
    713                                       (eval element-type)))))
     713                                      (eval element-type) env))))
    714714                     (comp-make-array-1 dims keys))
    715715                    ((and (typep element-type-keyword 'keyword)
     
    927927                  (and (quoted-form-p type)
    928928                       (setq type (%cadr type))))
    929               (setq ctype (specifier-type-if-known type)))
     929              (setq ctype (specifier-type-if-known type env)))
    930930         (cond ((nx-form-typep arg type env) arg)
    931931               ((eq type 'simple-vector)
     
    14901490(defun optimize-typep (thing type env)
    14911491  ;; returns a new form, or nil if it can't optimize
    1492   (let* ((ctype (specifier-type-if-known type)))
     1492  (let* ((ctype (specifier-type-if-known type env)))
    14931493    (when ctype
    14941494      (let* ((type (type-specifier ctype))
     
    15391539  (declare (ignore e))
    15401540  (if (quoted-form-p type)
    1541     (if (and (constantp thing) (specifier-type-if-known type))
     1541    (if (and (constantp thing) (specifier-type-if-known type env))
    15421542      (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type))
    15431543      (or (optimize-typep thing (%cadr type) env)
     
    17941794(define-compiler-macro aref (&whole call a &rest subscripts &environment env)
    17951795  (let* ((ctype (if (nx-form-typep a 'array env)
    1796                   (specifier-type (nx-form-type a env))))
     1796                  (specifier-type (nx-form-type a env) env)))
    17971797         (type (if ctype (type-specifier (array-ctype-specialized-element-type ctype))))
    17981798         (useful (unless (or (eq type *) (eq type t))
  • branches/working-0711/ccl/level-1/l1-typesys.lisp

    r9245 r9338  
    473473                                    lambda-list &body body)
    474474  `(progn
    475      (let* ((fn #'(lambda ,lambda-list ,@body)))
     475     (let* ((fn (nfunction (,class ,method ,@more-methods)
     476                           (lambda ,lambda-list ,@body))))
    476477       ,@(mapcar #'(lambda (method)
    477478                         `(setf (%svref
     
    745746  (type= (constant-ctype-type type1) (constant-ctype-type type2)))
    746747
    747 (def-type-translator constant-argument (type)
    748   (make-constant-ctype :type (specifier-type type)))
     748(def-type-translator constant-argument (type &environment env)
     749  (make-constant-ctype :type (specifier-type type env)))
    749750
    750751
     
    756757;;;
    757758
    758 (defun parse-args-types (lambda-list result)
     759(defun parse-args-types (lambda-list result &optional env)
    759760  (multiple-value-bind (required optional restp rest keyp keys allowp aux)
    760761                           (parse-lambda-list lambda-list)
    761762    (when aux
    762763      (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
    763     (setf (args-ctype-required result) (mapcar #'specifier-type required))
    764     (setf (args-ctype-optional result) (mapcar #'specifier-type optional))
    765     (setf (args-ctype-rest result) (if restp (specifier-type rest) nil))
    766     (setf (args-ctype-keyp result) keyp)
    767     (let* ((key-info ()))
    768       (dolist (key keys)
     764    (flet ((parse (spec) (specifier-type spec env)))
     765      (setf (args-ctype-required result) (mapcar #'parse required))
     766      (setf (args-ctype-optional result) (mapcar #'parse optional))
     767      (setf (args-ctype-rest result) (if restp (parse rest) nil))
     768      (setf (args-ctype-keyp result) keyp)
     769      (let* ((key-info ()))
     770        (dolist (key keys)
    769771          (when (or (atom key) (/= (length key) 2))
    770772            (signal-program-error "Keyword type description is not a two-list: ~S." key))
     
    773775              (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
    774776            (push (make-key-info :name kwd
    775                                :type (specifier-type (second key))) key-info)))
    776       (setf (args-ctype-keywords result) (nreverse key-info)))
    777     (setf (args-ctype-allowp result) allowp)))
     777                                 :type (parse (second key))) key-info)))
     778        (setf (args-ctype-keywords result) (nreverse key-info)))
     779      (setf (args-ctype-allowp result) allowp))))
    778780
    779781;;; Unparse-Args-Types  --  Internal
     
    808810    (nreverse result)))
    809811
    810 (def-type-translator function (&optional (args '*) (result '*))
     812(def-type-translator function (&optional (args '*) (result '*) &environment env)
    811813  (let ((res (make-function-ctype
    812                 :returns (values-specifier-type result))))
     814                :returns (values-specifier-type result env))))
    813815    (if (eq args '*)
    814816        (setf (function-ctype-wild-args res) t)
    815         (parse-args-types args res))
     817        (parse-args-types args res env))
    816818    res))
    817819
    818 (def-type-translator values (&rest values)
     820(def-type-translator values (&rest values &environment env)
    819821  (let ((res (make-values-ctype)))
    820     (parse-args-types values res)
     822    (parse-args-types values res env)
    821823    (when (or (values-ctype-keyp res) (values-ctype-allowp res))
    822824      (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s"
     
    13311333;;;
    13321334
    1333 (defun values-specifier-type-internal (orig)
     1335(defun values-specifier-type-internal (orig env)
    13341336  (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes
    13351337     
    1336       (let ((spec (type-expand orig)))
     1338      ;; Now that we have our hands on the environment, we could pass it into type-expand,
     1339      ;; but we'd have no way of knowing whether the expansion depended on the env, so
     1340      ;; we wouldn't know if the result is safe to cache.   So for now don't let type
     1341      ;; expanders see the env, which just means they won't see compile-time types.
     1342      (let ((spec (type-expand orig #+not-yet env)))
    13371343        (cond
    13381344         ((and (not (eq spec orig))
    13391345               (info-type-builtin spec)))
    1340          ((eq (info-type-kind spec) :instance)
    1341           (let* ((class-ctype (%class.ctype (find-class spec))))
     1346         ((or (eq (info-type-kind spec) :instance)
     1347              (and (symbolp spec)
     1348                   (typep (find-class spec nil env) 'compile-time-class)))
     1349          (let* ((class-ctype (%class.ctype (find-class spec t env))))
    13421350            (or (class-ctype-translation class-ctype)
    13431351                class-ctype)))
     
    13511359          (let* ((lspec (if (atom spec) (list spec) spec))
    13521360                 (fun (info-type-translator (car lspec))))
    1353             (cond (fun (funcall fun lspec nil))
     1361            (cond (fun (funcall fun lspec env))
    13541362                  ((or (and (consp spec) (symbolp (car spec)))
    13551363                       (symbolp spec))
     
    13651373  (defconstant type-cache-size (ash 1 12))
    13661374  (defconstant type-cache-mask (1- type-cache-size)))
     1375
     1376(defun compile-time-ctype-p (ctype)
     1377  (and (typep ctype 'class-ctype)
     1378       (typep (class-ctype-class ctype) 'compile-time-class)))
     1379
    13671380
    13681381;;; We can get in trouble if we try to cache certain kinds of ctypes,
     
    14001413          (cacheable-ctype-p (cons-ctype-cdr-ctype ctype))))
    14011414    (unknown-ctype nil)
     1415    (class-ctype
     1416     (not (typep (class-ctype-class ctype) 'compile-time-class)))
    14021417    ;; Anything else ?  Simple things (numbers, classes) can't lose.
    14031418    (t t)))
     
    14221437    nil)
    14231438
    1424   (defun values-specifier-type (spec)
     1439  (defun values-specifier-type (spec &optional env)
    14251440    (if (typep spec 'class)
    14261441      (let* ((class-ctype (%class.ctype spec)))
    14271442        (or (class-ctype-translation class-ctype) class-ctype))
    14281443      (if locked
    1429         (or (values-specifier-type-internal spec)
     1444        (or (values-specifier-type-internal spec env)
    14301445            (make-unknown-ctype :specifier spec))
    14311446        (unwind-protect
     
    14401455                    (incf hits)
    14411456                    (svref type-cache-ctypes idx))
    1442                   (let* ((ctype (values-specifier-type-internal spec)))
     1457                  (let* ((ctype (values-specifier-type-internal spec env)))
    14431458                    (if ctype
    14441459                      (progn
     
    14481463                        ctype)
    14491464                      (make-unknown-ctype :specifier spec)))))
    1450               (values-specifier-type-internal spec)))
     1465              (values-specifier-type-internal spec env)))
    14511466          (setq locked nil)))))
    14521467 
     
    14691484;;; VALUES type.
    14701485;;;
    1471 (defun specifier-type (x)
    1472   (let ((res (values-specifier-type x)))
     1486(defun specifier-type (x &optional env)
     1487  (let ((res (values-specifier-type x env)))
    14731488    (when (values-ctype-p res)
    14741489      (signal-program-error "VALUES type illegal in this context:~%  ~S" x))
    14751490    res))
    14761491
    1477 (defun single-value-specifier-type (x)
    1478   (let ((res (specifier-type x)))
     1492(defun single-value-specifier-type (x &optional env)
     1493  (let ((res (specifier-type x env)))
    14791494    (if (eq res *wild-type*)
    14801495        *universal-type*
    14811496        res)))
    14821497
    1483 (defun standardized-type-specifier (spec)
    1484   (type-specifier (specifier-type spec)))
     1498(defun standardized-type-specifier (spec &optional env)
     1499  (handler-case
     1500      (type-specifier (specifier-type spec env))
     1501    (parse-unknown-type () spec)))
    14851502
    14861503(defun modified-numeric-type (base
     
    18491866  (type= (negation-ctype-type type1) (negation-ctype-type type2)))
    18501867
    1851 (def-type-translator not (typespec)
    1852   (let* ((not-type (specifier-type typespec))
     1868(def-type-translator not (typespec &environment env)
     1869  (let* ((not-type (specifier-type typespec env))
    18531870         (spec (type-specifier not-type)))
    18541871    (cond
    18551872      ;; canonicalize (NOT (NOT FOO))
    18561873      ((and (listp spec) (eq (car spec) 'not))
    1857        (specifier-type (cadr spec)))
     1874       (specifier-type (cadr spec) env))
    18581875      ;; canonicalize (NOT NIL) and (NOT T)
    18591876      ((eq not-type *empty-type*) *universal-type*)
     
    18941911       (apply #'type-union
    18951912              (mapcar #'(lambda (x)
    1896                           (specifier-type `(not ,(type-specifier x))))
     1913                          (specifier-type `(not ,(type-specifier x)) env))
    18971914                      (intersection-ctype-types not-type))))
    18981915      ((union-ctype-p not-type)
    18991916       (apply #'type-intersection
    19001917              (mapcar #'(lambda (x)
    1901                           (specifier-type `(not ,(type-specifier x))))
     1918                          (specifier-type `(not ,(type-specifier x)) env))
    19021919                      (union-ctype-types not-type))))
    19031920      ((member-ctype-p not-type)
     
    19391956      ((cons-ctype-p not-type)
    19401957       (type-union
    1941         (make-negation-ctype :type (specifier-type 'cons))
     1958        (make-negation-ctype :type (specifier-type 'cons env))
    19421959        (cond
    19431960          ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*))
     
    19461963            (make-cons-ctype
    19471964             (specifier-type `(not ,(type-specifier
    1948                                      (cons-ctype-car-ctype not-type))))
     1965                                     (cons-ctype-car-ctype not-type))) env)
    19491966             *universal-type*)
    19501967            (make-cons-ctype
    19511968             *universal-type*
    19521969             (specifier-type `(not ,(type-specifier
    1953                                      (cons-ctype-cdr-ctype not-type)))))))
     1970                                     (cons-ctype-cdr-ctype not-type))) env))))
    19541971          ((not (eq (cons-ctype-car-ctype not-type) *universal-type*))
    19551972           (make-cons-ctype
    19561973            (specifier-type `(not ,(type-specifier
    1957                                     (cons-ctype-car-ctype not-type))))
     1974                                    (cons-ctype-car-ctype not-type))) env)
    19581975            *universal-type*))
    19591976          ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))
     
    19611978            *universal-type*
    19621979            (specifier-type `(not ,(type-specifier
    1963                                     (cons-ctype-cdr-ctype not-type))))))
     1980                                    (cons-ctype-cdr-ctype not-type))) env)))
    19641981          (t (error "Weird CONS type ~S" not-type)))))
    19651982      (t (make-negation-ctype :type not-type)))))
     
    23022319      (info-type-builtin 'number) (make-numeric-ctype :complexp nil))
    23032320
    2304 (def-type-translator complex (&optional spec)
     2321(def-type-translator complex (&optional spec &environment env)
    23052322  (if (eq spec '*)
    23062323      (make-numeric-ctype :complexp :complex)
     
    23412358                   (t                   ; punt on harder stuff for now
    23422359                    (not-real)))))
    2343         (let ((ctype (specifier-type spec)))
     2360        (let ((ctype (specifier-type spec env)))
    23442361          (do-complex ctype)))))
    23452362
     
    28212838                           dims))))
    28222839
    2823 (def-type-translator array (&optional element-type dimensions)
     2840(def-type-translator array (&optional element-type dimensions &environment env)
    28242841  (specialize-array-type
    28252842   (make-array-ctype :dimensions (check-array-dimensions dimensions)
    28262843                     :complexp :maybe
    2827                      :element-type (specifier-type element-type))))
    2828 
    2829 (def-type-translator simple-array (&optional element-type dimensions)
     2844                     :element-type (specifier-type element-type env))))
     2845
     2846(def-type-translator simple-array (&optional element-type dimensions &environment env)
    28302847  (specialize-array-type
    28312848   (make-array-ctype :dimensions (check-array-dimensions dimensions)
    2832                          :element-type (specifier-type element-type)
     2849                         :element-type (specifier-type element-type env)
    28332850                         :complexp nil)))
    28342851
     
    31043121
    31053122
    3106 (def-type-translator or (&rest type-specifiers)
     3123(def-type-translator or (&rest type-specifiers &environment env)
    31073124  (apply #'type-union
    3108          (mapcar #'specifier-type type-specifiers)))
     3125         (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers)))
    31093126
    31103127
     
    32073224                     (type-intersection accumulator union))))))))
    32083225
    3209 (def-type-translator and (&rest type-specifiers)
     3226(def-type-translator and (&rest type-specifiers &environment env)
    32103227  (apply #'type-intersection
    3211          (mapcar #'specifier-type
     3228         (mapcar #'(lambda (spec) (specifier-type spec env))
    32123229                 type-specifiers)))
    32133230
     
    32333250(setf (type-predicate 'cons-ctype) 'cons-ctype-p)
    32343251 
    3235 (def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
    3236   (make-cons-ctype (specifier-type car-type-spec)
    3237                    (specifier-type cdr-type-spec)))
     3252(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*) &environment env)
     3253  (make-cons-ctype (specifier-type car-type-spec env)
     3254                   (specifier-type cdr-type-spec env)))
    32383255
    32393256(define-type-method (cons :unparse) (type)
     
    34213438      (if (memq class2 (class-direct-superclasses class1))
    34223439        (values t t)
    3423         (if (class-has-a-forward-referenced-superclass-p class1)
     3440        (if (or (class-has-a-forward-referenced-superclass-p class1)
     3441                (typep class1 'compile-time-class))
    34243442          (values nil nil)
    34253443          (let ((supers (%inited-class-cpl class1)))
     
    34453463  (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1)))
    34463464         (class2 (if (class-ctype-p type2) (class-ctype-class type2))))
    3447     (if (and class1 class2)
     3465    (if (and class1
     3466             (not (typep class1 'compile-time-class))
     3467             class2
     3468             (not (typep class2 'compile-time-class)))
    34483469      (cond ((subclassp class1 class2)
    34493470             type1)
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r8926 r9338  
    823823  (let ((defenv (definition-environment env)))
    824824    (when defenv
     825      (when (non-nil-symbolp (sd-name sd))
     826        (push (make-instance 'compile-time-class :name (sd-name sd))
     827              (defenv.classes defenv)))
    825828      (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv)))
    826829      (let* ((structrefs (defenv.structrefs defenv)))
Note: See TracChangeset for help on using the changeset viewer.