(%compiler-defstruct ',dd ',inherits))
(%defstruct ',dd ',inherits)
,@(unless expanding-into-code-for-xc-host-p
- (append (predicate-definitions dd)
- ;; FIXME: We've inherited from CMU CL nonparallel
+ (append ;; FIXME: We've inherited from CMU CL nonparallel
;; code for creating copiers for typed and untyped
;; structures. This should be fixed.
;(copier-definition dd)
\f
;;;; functions to generate code for various parts of DEFSTRUCT definitions
-;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
-(defun predicate-definitions (dd)
- (let ((pred (dd-predicate-name dd))
- (argname (gensym "ARG")))
- (and pred
- `((protect-cl ',pred)
- (declaim (inline ,pred))
- (defun ,pred (,argname)
- (declare (optimize (speed 3) (safety 0)))
- (typep-to-layout ,argname
- (compile-time-find-layout ,(dd-name dd))))))))
-
-;;; Return a list of forms which create a predicate function for a typed
-;;; DEFSTRUCT.
+;;; Return a list of forms which create a predicate function for a
+;;; typed DEFSTRUCT.
(defun typed-predicate-definitions (defstruct)
(let ((name (dd-name defstruct))
(predicate-name (dd-predicate-name defstruct))
(let ((predicate-name (dd-predicate-name dd)))
(when predicate-name
- (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))))
+ (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))
+ ;; Provide inline expansion (or not).
+ (ecase (dd-type dd)
+ ((structure funcallable-structure)
+ ;; Let the predicate be inlined.
+ (setf (info :function :inline-expansion-designator predicate-name)
+ (lambda ()
+ `(lambda (x)
+ ;; This dead simple definition works because the
+ ;; type system knows how to generate inline type
+ ;; tests for instances.
+ (typep x ',(dd-name dd))))
+ (info :function :inlinep predicate-name)
+ :inline))
+ ((list vector)
+ ;; Just punt. We could provide inline expansions for :TYPE
+ ;; LIST and :TYPE VECTOR predicates too, but it'd be a
+ ;; little messier and we don't bother. (Does anyway use
+ ;; typed DEFSTRUCTs at all, let alone for high
+ ;; performance?)
+ ))))
(dolist (dsd (dd-slots dd))
(let* ((accessor-name (dsd-accessor-name dsd))
(accessor-inline-expansion-designators dd dsd)
(sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
,accessor-name))
- (setf (info :function
- :inline-expansion-designator
- accessor-name)
+ (setf (info :function :inline-expansion-designator accessor-name)
reader-designator
(info :function :inlinep accessor-name)
:inline)
;;; use it?)
(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
\f
-;;; Return the type structure corresponding to a type specifier. We
-;;; pick off structure types as a special case.
-;;;
-;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
-;;; type is defined (or redefined).
-(defun-cached (values-specifier-type
- :hash-function (lambda (x)
- ;; FIXME: The THE FIXNUM stuff is
- ;; redundant in SBCL (or modern CMU
- ;; CL) because of type inference.
- (the fixnum
- (logand (the fixnum (sxhash x))
- #x3FF)))
- :hash-bits 10
- :init-wrapper !cold-init-forms)
- ((orig eq))
- (let ((u (uncross orig)))
- (or (info :type :builtin u)
- (let ((spec (type-expand u)))
- (cond
- ((and (not (eq spec u))
- (info :type :builtin spec)))
- ((eq (info :type :kind spec) :instance)
- (sb!xc:find-class spec))
- ((typep spec 'class)
- ;; There doesn't seem to be any way to translate
- ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
- ;; executed on the host Common Lisp at cross-compilation time.
- #+sb-xc-host (error
- "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
- (if (typep spec 'built-in-class)
- (or (built-in-class-translation spec) spec)
- spec))
- (t
- (let* (;; FIXME: This automatic promotion of FOO-style
- ;; specs to (FOO)-style specs violates the ANSI
- ;; standard. Unfortunately, we can't fix the
- ;; problem just by removing it, since then things
- ;; downstream should break. But at some point we
- ;; should fix this and the things downstream too.
- (lspec (if (atom spec) (list spec) spec))
- (fun (info :type :translator (car lspec))))
- (cond (fun
- (funcall fun lspec))
- ((or (and (consp spec) (symbolp (car spec)))
- (symbolp spec))
- (when *type-system-initialized*
- (signal 'parse-unknown-type :specifier spec))
- ;; (The RETURN-FROM here inhibits caching.)
- (return-from values-specifier-type
- (make-unknown-type :specifier spec)))
- (t
- (error "bad thing to be a type specifier: ~S"
- spec))))))))))
-
-;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never
-;;; return a VALUES type.
-(defun specifier-type (x)
- (let ((res (values-specifier-type x)))
- (when (values-type-p res)
- (error "VALUES type illegal in this context:~% ~S" x))
- res))
-
-;;; 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)))
+;;;; representations of types
;;; A HAIRY-TYPE represents anything too weird to be described
;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
;; specifier to win.
(type (missing-arg) :type ctype))
-;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be
-;;; super- or sub-types of all types, not just classes and * and NIL aren't
-;;; classes anyway, so it wouldn't make much sense to make them built-in
-;;; classes.
+;;; The NAMED-TYPE is used to represent *, T and NIL. These types must
+;;; be super- or sub-types of all types, not just classes and * and
+;;; NIL aren't classes anyway, so it wouldn't make much sense to make
+;;; them built-in classes.
(defstruct (named-type (:include ctype
(class-info (type-class-or-lose 'named)))
(:copier nil))
;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
(car-type (missing-arg) :type ctype :read-only t)
(cdr-type (missing-arg) :type ctype :read-only t))
+\f
+;;;; type utilities
+
+;;; Return the type structure corresponding to a type specifier. We
+;;; pick off structure types as a special case.
+;;;
+;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
+;;; type is defined (or redefined).
+(defun-cached (values-specifier-type
+ :hash-function (lambda (x)
+ ;; FIXME: The THE FIXNUM stuff is
+ ;; redundant in SBCL (or modern CMU
+ ;; CL) because of type inference.
+ (the fixnum
+ (logand (the fixnum (sxhash x))
+ #x3FF)))
+ :hash-bits 10
+ :init-wrapper !cold-init-forms)
+ ((orig eq))
+ (let ((u (uncross orig)))
+ (or (info :type :builtin u)
+ (let ((spec (type-expand u)))
+ (cond
+ ((and (not (eq spec u))
+ (info :type :builtin spec)))
+ ((eq (info :type :kind spec) :instance)
+ (sb!xc:find-class spec))
+ ((typep spec 'class)
+ ;; There doesn't seem to be any way to translate
+ ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
+ ;; executed on the host Common Lisp at cross-compilation time.
+ #+sb-xc-host (error
+ "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
+ (if (typep spec 'built-in-class)
+ (or (built-in-class-translation spec) spec)
+ spec))
+ (t
+ (let* (;; FIXME: This automatic promotion of FOO-style
+ ;; specs to (FOO)-style specs violates the ANSI
+ ;; standard. Unfortunately, we can't fix the
+ ;; problem just by removing it, since then things
+ ;; downstream should break. But at some point we
+ ;; should fix this and the things downstream too.
+ (lspec (if (atom spec) (list spec) spec))
+ (fun (info :type :translator (car lspec))))
+ (cond (fun
+ (funcall fun lspec))
+ ((or (and (consp spec) (symbolp (car spec)))
+ (symbolp spec))
+ (when *type-system-initialized*
+ (signal 'parse-unknown-type :specifier spec))
+ ;; (The RETURN-FROM here inhibits caching.)
+ (return-from values-specifier-type
+ (make-unknown-type :specifier spec)))
+ (t
+ (error "bad thing to be a type specifier: ~S"
+ spec))))))))))
+
+;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never
+;;; return a VALUES type.
+(defun specifier-type (x)
+ (let ((res (values-specifier-type x)))
+ (when (values-type-p res)
+ (error "VALUES type illegal in this context:~% ~S" x))
+ res))
+
+;;; 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)))
;;; Note that the type NAME has been (re)defined, updating the
;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
(when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
(values-specifier-type-cache-clear))
(values))
-
+\f
(!defun-from-collected-cold-init-forms !early-type-cold-init)
projects / sbcl.git / commitdiff