X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=de364ebc6c3c8c884b54bf77827ab548fb229db9;hb=54da325f13fb41669869aea688ae195426c0e231;hp=6bc004ef62d06d79b4b6c2af12c8c4c6781344ab;hpb=b2f0204834bd0c314d44942dd92475c15ffa8c89;p=sbcl.git diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6bc004e..de364eb 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -34,6 +34,26 @@ (defstruct (unknown-type (:include hairy-type) (:copier nil))) +(defun maybe-reparse-specifier (type) + (when (unknown-type-p type) + (let* ((spec (unknown-type-specifier type)) + (name (if (consp spec) + (car spec) + spec))) + (when (info :type :kind name) + (let ((new-type (specifier-type spec))) + (unless (unknown-type-p new-type) + new-type)))))) + +;;; Evil macro. +(defmacro maybe-reparse-specifier! (type) + (assert (symbolp type)) + (with-unique-names (new-type) + `(let ((,new-type (maybe-reparse-specifier ,type))) + (when ,new-type + (setf ,type ,new-type) + t)))) + (defstruct (negation-type (:include ctype (class-info (type-class-or-lose 'negation)) ;; FIXME: is this right? It's @@ -63,7 +83,7 @@ ;; true if other &KEY arguments are allowed (allowp nil :type boolean)) -(defun canonicalize-args-type-args (required optional rest) +(defun canonicalize-args-type-args (required optional rest &optional keyp) (when (eq rest *empty-type*) ;; or vice-versa? (setq rest nil)) @@ -72,19 +92,20 @@ for opt in optional do (cond ((eq opt *empty-type*) (return (values required (subseq optional i) rest))) - ((neq opt rest) + ((and (not keyp) (neq opt rest)) (setq last-not-rest i))) finally (return (values required - (if last-not-rest - (subseq optional 0 (1+ last-not-rest)) - nil) + (cond (keyp + optional) + (last-not-rest + (subseq optional 0 (1+ last-not-rest)))) rest)))) -(defun args-types (lambda-list-like-thing) +(defun parse-args-types (lambda-list-like-thing) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count llk-p) - (parse-lambda-list-like-thing lambda-list-like-thing) + (parse-lambda-list-like-thing lambda-list-like-thing :silent t) (declare (ignore aux morep more-context more-count)) (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing)) @@ -106,26 +127,37 @@ :type (single-value-specifier-type (second key)))))) (key-info)))) (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest) + (canonicalize-args-type-args required optional rest keyp) (values required optional rest keyp keywords allowp llk-p))))) (defstruct (values-type (:include args-type (class-info (type-class-or-lose 'values))) (:constructor %make-values-type) + (:predicate %values-type-p) (:copier nil))) +(declaim (inline value-type-p)) +(defun values-type-p (x) + (or (eq x *wild-type*) + (%values-type-p x))) + (defun-cached (make-values-type-cached :hash-bits 8 - :hash-function (lambda (req opt rest allowp) - (logand (logxor - (type-list-cache-hash req) - (type-list-cache-hash opt) - (if rest - (type-hash-value rest) - 42) - (sxhash allowp)) - #xFF))) + :hash-function + (lambda (req opt rest allowp) + (logand (logxor + (type-list-cache-hash req) + (type-list-cache-hash opt) + (if rest + (type-hash-value rest) + 42) + ;; Results (logand #xFF (sxhash t/nil)) + ;; hardcoded to avoid relying on the xc host. + (if allowp + 194 + 11)) + #xFF))) ((required equal-but-no-car-recursion) (optional equal-but-no-car-recursion) (rest eq) @@ -135,34 +167,17 @@ :rest rest :allowp allowp)) -(defun make-values-type (&key (args nil argsp) - required optional rest allowp) - (if argsp - (if (eq args '*) - *wild-type* - (multiple-value-bind (required optional rest keyp keywords allowp - llk-p) - (args-types args) - (declare (ignore keywords)) - (when keyp - (error "&KEY appeared in a VALUES type specifier ~S." - `(values ,@args))) - (if llk-p - (make-values-type :required required - :optional optional - :rest rest - :allowp allowp) - (make-short-values-type required)))) - (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest) - (cond ((and (null required) - (null optional) - (eq rest *universal-type*)) - *wild-type*) - ((memq *empty-type* required) - *empty-type*) - (t (make-values-type-cached required optional - rest allowp)))))) +(defun make-values-type (&key required optional rest allowp) + (multiple-value-bind (required optional rest) + (canonicalize-args-type-args required optional rest) + (cond ((and (null required) + (null optional) + (eq rest *universal-type*)) + *wild-type*) + ((memq *empty-type* required) + *empty-type*) + (t (make-values-type-cached required optional + rest allowp))))) (!define-type-class values) @@ -170,44 +185,18 @@ (defstruct (fun-type (:include args-type (class-info (type-class-or-lose 'function))) (:constructor - %make-fun-type (&key required optional rest - keyp keywords allowp - wild-args - returns - &aux (rest (if (eq rest *empty-type*) - nil - rest))))) + make-fun-type (&key required optional rest + keyp keywords allowp + wild-args + returns + &aux (rest (if (eq rest *empty-type*) + nil + rest))))) ;; true if the arguments are unrestrictive, i.e. * (wild-args nil :type boolean) ;; type describing the return values. This is a values type ;; when multiple values were specified for the return. (returns (missing-arg) :type ctype)) -(defun make-fun-type (&rest initargs - &key (args nil argsp) returns &allow-other-keys) - (if argsp - (if (eq args '*) - (if (eq returns *wild-type*) - (specifier-type 'function) - (%make-fun-type :wild-args t :returns returns)) - (multiple-value-bind (required optional rest keyp keywords allowp) - (args-types args) - (if (and (null required) - (null optional) - (eq rest *universal-type*) - (not keyp)) - (if (eq returns *wild-type*) - (specifier-type 'function) - (%make-fun-type :wild-args t :returns returns)) - (%make-fun-type :required required - :optional optional - :rest rest - :keyp keyp - :keywords keywords - :allowp allowp - :returns returns)))) - ;; FIXME: are we really sure that we won't make something that - ;; looks like a completely wild function here? - (apply #'%make-fun-type initargs))) ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG ;;; "type specifier", which is only meaningful in function argument @@ -392,41 +381,78 @@ (class-info (type-class-or-lose 'member)) (enumerable t)) (:copier nil) - (:constructor %make-member-type (members)) + (:constructor %make-member-type (xset fp-zeroes)) #-sb-xc-host (:pure nil)) - ;; the things in the set, with no duplications - (members nil :type list)) -(defun make-member-type (&key members) - (declare (type list members)) - ;; make sure that we've removed duplicates - (aver (= (length members) (length (remove-duplicates members)))) + (xset (missing-arg) :type xset) + (fp-zeroes (missing-arg) :type list)) +(defun make-member-type (&key xset fp-zeroes members) + (unless xset + (aver (not fp-zeroes)) + (setf xset (alloc-xset)) + (dolist (elt members) + (if (fp-zero-p elt) + (pushnew elt fp-zeroes) + (add-to-xset elt xset)))) ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 - (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - #!+long-float - (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) - (if (or singlep doublep #!+long-float longp) - (let (union-types) - (when singlep - (push (ctype-of 0.0f0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (when doublep - (push (ctype-of 0.0d0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) + (let ((unpaired nil) + (union-types nil)) + (do ((tail (cdr fp-zeroes) (cdr tail)) + (zero (car fp-zeroes) (car tail))) + ((not zero)) + (macrolet ((frob (c) + `(let ((neg (neg-fp-zero zero))) + (if (member neg tail) + (push (ctype-of ,c) union-types) + (push zero unpaired))))) + (etypecase zero + (single-float (frob 0.0f0)) + (double-float (frob 0.0d0)) #!+long-float - (when longp - (push (ctype-of 0.0l0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (aver (not (null union-types))) - (make-union-type t - (if (null members) - union-types - (cons (%make-member-type members) - union-types)))) - (%make-member-type members)))) + (long-float (frob 0.0l0))))) + ;; The actual member-type contains the XSET (with no FP zeroes), + ;; and a list of unpaired zeroes. + (let ((member-type (unless (and (xset-empty-p xset) (not unpaired)) + (%make-member-type xset unpaired)))) + (cond (union-types + (make-union-type t (if member-type + (cons member-type union-types) + union-types))) + (member-type + member-type) + (t + *empty-type*))))) + +(defun member-type-size (type) + (+ (length (member-type-fp-zeroes type)) + (xset-count (member-type-xset type)))) + +(defun member-type-member-p (x type) + (if (fp-zero-p x) + (and (member x (member-type-fp-zeroes type)) t) + (xset-member-p x (member-type-xset type)))) + +(defun mapcar-member-type-members (function type) + (declare (function function)) + (collect ((results)) + (map-xset (lambda (x) + (results (funcall function x))) + (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (results (funcall function zero))) + (results))) + +(defun mapc-member-type-members (function type) + (declare (function function)) + (map-xset function (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (funcall function zero))) + +(defun member-type-members (type) + (append (member-type-fp-zeroes type) + (xset-members (member-type-xset type)))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. @@ -512,6 +538,29 @@ (t (values min :maybe)))) ())) +;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type. +#!+sb-simd-pack +(defstruct (simd-pack-type + (:include ctype (class-info (type-class-or-lose 'simd-pack))) + (:constructor %make-simd-pack-type (element-type)) + (:copier nil)) + (element-type (missing-arg) + :type (cons #||(member #.*simd-pack-element-types*) ||#) + :read-only t)) + +#!+sb-simd-pack +(defun make-simd-pack-type (element-type) + (aver (neq element-type *wild-type*)) + (if (eq element-type *empty-type*) + *empty-type* + (%make-simd-pack-type + (dolist (pack-type *simd-pack-element-types* + (error "~S element type must be a subtype of ~ + ~{~S~#[~;, or ~:;, ~]~}." + 'simd-pack *simd-pack-element-types*)) + (when (csubtypep element-type (specifier-type pack-type)) + (return (list pack-type))))))) + ;;;; type utilities @@ -528,10 +577,14 @@ ((orig equal-but-no-car-recursion)) (let ((u (uncross orig))) (or (info :type :builtin u) - (let ((spec (type-expand u))) + (let ((spec (typexpand u))) (cond ((and (not (eq spec u)) (info :type :builtin spec))) + ((and (consp spec) (symbolp (car spec)) + (info :type :builtin (car spec)) + (let ((expander (info :type :expander (car spec)))) + (and expander (values-specifier-type (funcall expander spec)))))) ((eq (info :type :kind spec) :instance) (find-classoid spec)) ((typep spec 'classoid) @@ -553,7 +606,11 @@ (not (eq (info :type :kind spec) :forthcoming-defclass-type))) (signal 'parse-unknown-type :specifier spec)) - ;; (The RETURN-FROM here inhibits caching.) + ;; (The RETURN-FROM here inhibits caching; this + ;; does not only make sense from a compiler + ;; diagnostics point of view but is also + ;; indispensable for proper workingness of + ;; VALID-TYPE-SPECIFIER-P.) (return-from values-specifier-type (make-unknown-type :specifier spec))) (t @@ -576,25 +633,113 @@ *universal-type* (specifier-type x))) -;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother -;;; returning a second value. -(defun type-expand (form) - (let ((def (cond ((symbolp form) - (info :type :expander form)) - ((and (consp form) (symbolp (car form))) - (info :type :expander (car form))) - (t nil)))) - (if def - (type-expand (funcall def (if (consp form) form (list form)))) - form))) +(defun typexpand-1 (type-specifier &optional env) + #!+sb-doc + "Takes and expands a type specifier once like MACROEXPAND-1. +Returns two values: the expansion, and a boolean that is true when +expansion happened." + (declare (type type-specifier type-specifier)) + (declare (ignore env)) + (multiple-value-bind (expander lspec) + (let ((spec type-specifier)) + (cond ((and (symbolp spec) (info :type :builtin spec)) + ;; We do not expand builtins even though it'd be + ;; possible to do so sometimes (e.g. STRING) for two + ;; reasons: + ;; + ;; a) From a user's point of view, CL types are opaque. + ;; + ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING)) + (values nil nil)) + ((symbolp spec) + (values (info :type :expander spec) (list spec))) + ((and (consp spec) (symbolp (car spec)) (info :type :builtin (car spec))) + ;; see above + (values nil nil)) + ((and (consp spec) (symbolp (car spec))) + (values (info :type :expander (car spec)) spec)) + (t nil))) + (if expander + (values (funcall expander lspec) t) + (values type-specifier nil)))) + +(defun typexpand (type-specifier &optional env) + #!+sb-doc + "Takes and expands a type specifier repeatedly like MACROEXPAND. +Returns two values: the expansion, and a boolean that is true when +expansion happened." + (declare (type type-specifier type-specifier)) + (multiple-value-bind (expansion flag) + (typexpand-1 type-specifier env) + (if flag + (values (typexpand expansion env) t) + (values expansion flag)))) + +(defun typexpand-all (type-specifier &optional env) + #!+sb-doc + "Takes and expands a type specifier recursively like MACROEXPAND-ALL." + (declare (type type-specifier type-specifier)) + (declare (ignore env)) + ;; I first thought this would not be a good implementation because + ;; it signals an error on e.g. (CONS 1 2) until I realized that + ;; walking and calling TYPEXPAND would also result in errors, and + ;; it actually makes sense. + ;; + ;; There's still a small problem in that + ;; (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM) + ;; whereas walking+typexpand would result in (CONS * FIXNUM). + ;; + ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION. + (type-specifier (values-specifier-type type-specifier))) + +(defun defined-type-name-p (name &optional env) + #!+sb-doc + "Returns T if NAME is known to name a type specifier, otherwise NIL." + (declare (symbol name)) + (declare (ignore env)) + (and (info :type :kind name) t)) + +(defun valid-type-specifier-p (type-specifier &optional env) + #!+sb-doc + "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL. + +There may be different metrics on what constitutes a \"valid type +specifier\" depending on context. If this function does not suit your +exact need, you may be able to craft a particular solution using a +combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions. + +The definition of \"valid type specifier\" employed by this function +is based on the following mnemonic: + + \"Would TYPEP accept it as second argument?\" + +Except that unlike TYPEP, this function fully supports compound +FUNCTION type specifiers, and the VALUES type specifier, too. + +In particular, VALID-TYPE-SPECIFIER-P will return NIL if +TYPE-SPECIFIER is not a class, not a symbol that is known to name a +type specifier, and not a cons that represents a known compound type +specifier in a syntactically and recursively correct way. + +Examples: + + (valid-type-specifier-p '(cons * *)) => T + (valid-type-specifier-p '#:foo) => NIL + (valid-type-specifier-p '(cons * #:foo)) => NIL + (valid-type-specifier-p '(cons 1 *) => NIL + +Experimental." + (declare (ignore env)) + (handler-case (prog1 t (values-specifier-type type-specifier)) + (parse-unknown-type () nil) + (error () nil))) ;;; Note that the type NAME has been (re)defined, updating the ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache. (defun %note-type-defined (name) (declare (symbol name)) (note-name-defined name :type) - (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*) - (values-specifier-type-cache-clear)) + (values-specifier-type-cache-clear) (values))