From: Christophe Rhodes Date: Thu, 14 Sep 2006 21:10:44 +0000 (+0000) Subject: 0.9.16.30: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d1e7b48b17180a417c41ed55eb382ebf6d4e7a2a;p=sbcl.git 0.9.16.30: A couple of type-system fixups for #+sb-eval ... we have to have sb-eval:interpreted-function defined on the host, so that the deftype for COMPILED-FUNCTION does not involve any unknown types. So ... make !defstruct-with-alternate-metaclass compilable by the host compiler, similarly to sb-xc:defstruct. Don't quite do it properly: put a FIXME note in for posterity. ... move early-full-eval.lisp earlier in the build, and split out the definition for compiled-function from deftypes-for-target to late-deftypes-for-target (after the interpreted-function class is defined) ... (declare (type compiled-function x)) should do a type check for compiled-function, not for simply FUNCTION. ... the problem was actually in PRIMITIVE-TYPE on intersection types; the computation was fairly bogus. Make it less bogus. ... also delete some stale classoid symbols. --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index c95481d..27b9cc2 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -420,10 +420,20 @@ ;; CHECK-FUN-NAME defined in proclaim.lisp. ("src/code/force-delayed-defbangstructs") + ;; early-full-eval uses !DEFSTRUCT-WITH-ALTERNATE-METACLASS and + ;; DEF!METHOD. It split out from the rest of full-eval because + ;; defstruct/metaclass fun makes it unslammable, and to define + ;; INTERPRETED-FUNCTION before it is used in compiler/main and in the + ;; definition of the COMPILED-FUNCTION type. + #!+sb-eval + ("src/code/early-full-eval") + ("src/code/typep" :not-host) ("src/compiler/compiler-error") + ("src/code/late-deftypes-for-target") + ("src/code/type-init") ;; Now that the type system is initialized, fix up UNKNOWN types that ;; have crept in. @@ -485,13 +495,6 @@ ;; trace table definitions from compiler/trace-table.lisp. ("src/compiler/dump") - ;; early-full-eval uses !DEFSTRUCT-WITH-ALTERNATE-METACLASS and - ;; DEF!METHOD. It split out from the rest of full-eval because - ;; defstruct/metaclass fun makes it unslammable, and to define - ;; INTERPRETED-FUNCTION before it is used in compiler/main. - #!+sb-eval - ("src/code/early-full-eval" :not-host) - ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp ("src/code/source-location") ("src/compiler/target-main" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9a00ffa..2058cdf 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1533,11 +1533,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "STANDARD-CLASSOID" "CLASSOID-OF" "MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP" "FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE" - "FUNCALLABLE-STRUCTURE-CLASSOID" "%RANDOM-DOUBLE-FLOAT" + "%RANDOM-DOUBLE-FLOAT" #!+long-float "%RANDOM-LONG-FLOAT" "%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID" "%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK" - "MAKE-FUNCALLABLE-STRUCTURE-CLASSOID" "LAYOUT-CLOS-HASH-MAX" "CLASSOID-CELL-NAME" "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES" "BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH" @@ -1545,7 +1544,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT" "%SET-FUNCALLABLE-INSTANCE-LAYOUT" "BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID" - "FUNCALLABLE-STRUCTURE-CLASSOID-P" "REGISTER-LAYOUT" + "REGISTER-LAYOUT" "FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX" "MAKE-STATIC-CLASSOID" "INSTANCE-LAMBDA" "%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL" diff --git a/src/code/class.lisp b/src/code/class.lisp index 9171637..c3af80d 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -950,8 +950,8 @@ NIL is returned when no such class exists." ;;; FUNCALLABLE-STANDARD-CLASS. (def!struct (standard-classoid (:include classoid) (:constructor make-standard-classoid))) -;;; a metaclass for miscellaneous PCL structure-like objects (at the -;;; moment, only CTOR objects). +;;; a metaclass for classes which aren't standardlike but will never +;;; change either. (def!struct (static-classoid (:include classoid) (:constructor make-static-classoid))) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 12571a1..995a12f 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -333,7 +333,8 @@ `((setf (structure-classoid-constructor (find-classoid ',name)) #',def-con)))))))) -;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT +;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and +;;; cross-compiler macroexpansion for CL:DEFSTRUCT (defmacro !expander-for-defstruct (name-and-options slot-descriptions expanding-into-code-for-xc-host-p) @@ -1158,7 +1159,7 @@ (lambda (x) (sb!xc:typep x 'structure-classoid)) (lambda (x) - (sb!xc:typep x (find-classoid class)))) + (sb!xc:typep x (classoid-name (find-classoid class))))) (fdefinition constructor))) (setf (classoid-direct-superclasses class) (case (dd-name info) @@ -1551,6 +1552,47 @@ (dd-type dd) dd-type) dd)) +;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host +;;; lisp, installing the information we need to reason about the +;;; structures (layouts and classoids). +;;; +;;; FIXME: we should share the parsing and the DD construction between +;;; this and the cross-compiler version, but my brain was too small to +;;; get that right. -- CSR, 2006-09-14 +#+sb-xc-host +(defmacro !defstruct-with-alternate-metaclass + (class-name &key + (slot-names (missing-arg)) + (boa-constructor (missing-arg)) + (superclass-name (missing-arg)) + (metaclass-name (missing-arg)) + (metaclass-constructor (missing-arg)) + (dd-type (missing-arg)) + predicate + (runtime-type-checks-p t)) + + (declare (type (and list (not null)) slot-names)) + (declare (type (and symbol (not null)) + boa-constructor + superclass-name + metaclass-name + metaclass-constructor)) + (declare (type symbol predicate)) + (declare (type (member structure funcallable-structure) dd-type)) + (declare (ignore boa-constructor predicate runtime-type-checks)) + + (let* ((dd (make-dd-with-alternate-metaclass + :class-name class-name + :slot-names slot-names + :superclass-name superclass-name + :metaclass-name metaclass-name + :metaclass-constructor metaclass-constructor + :dd-type dd-type))) + `(progn + + (eval-when (:compile-toplevel :load-toplevel :execute) + (%compiler-set-up-layout ',dd ',(inherits-for-structure dd)))))) + (sb!xc:defmacro !defstruct-with-alternate-metaclass (class-name &key (slot-names (missing-arg)) diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 8a066f5..0091da5 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -56,9 +56,6 @@ (sb!xc:deftype bit () '(integer 0 1)) -(sb!xc:deftype compiled-function () - '(and function #!+sb-eval (not sb!eval:interpreted-function))) - (sb!xc:deftype atom () '(not cons)) (sb!xc:deftype base-char () diff --git a/src/code/early-full-eval.lisp b/src/code/early-full-eval.lisp index fd7f203..7114306 100644 --- a/src/code/early-full-eval.lisp +++ b/src/code/early-full-eval.lisp @@ -25,7 +25,7 @@ ;; RECOMPILE restart doesn't work on it. This is the main reason why ;; this stuff is split out into its own file. Also, it lets the ;; INTERPRETED-FUNCTION type be declared before it is used in -;; compiler/main. +;; compiler/main and code/deftypes-for-target. (sb!kernel::!defstruct-with-alternate-metaclass interpreted-function :slot-names (name lambda-list env declarations documentation body source-location) @@ -36,21 +36,23 @@ :dd-type funcallable-structure :runtime-type-checks-p nil) -(defun make-interpreted-function - (&key name lambda-list env declarations documentation body source-location) - (let ((function (%make-interpreted-function - name lambda-list env declarations documentation body - source-location))) - (setf (sb!kernel:funcallable-instance-fun function) - #'(lambda (&rest args) - (interpreted-apply function args))) - function)) - -(defun interpreted-function-p (function) - (typep function 'interpreted-function)) - -(sb!int:def!method print-object ((obj interpreted-function) stream) - (print-unreadable-object (obj stream - :identity (not (interpreted-function-name obj))) - (format stream "~A ~A" '#:interpreted-function - (interpreted-function-name obj)))) +#-sb-xc-host +(progn + (defun make-interpreted-function + (&key name lambda-list env declarations documentation body source-location) + (let ((function (%make-interpreted-function + name lambda-list env declarations documentation body + source-location))) + (setf (sb!kernel:funcallable-instance-fun function) + #'(lambda (&rest args) + (interpreted-apply function args))) + function)) + + (defun interpreted-function-p (function) + (typep function 'interpreted-function)) + + (sb!int:def!method print-object ((obj interpreted-function) stream) + (print-unreadable-object (obj stream + :identity (not (interpreted-function-name obj))) + (format stream "~A ~A" '#:interpreted-function + (interpreted-function-name obj))))) diff --git a/src/code/late-deftypes-for-target.lisp b/src/code/late-deftypes-for-target.lisp new file mode 100644 index 0000000..54e8441 --- /dev/null +++ b/src/code/late-deftypes-for-target.lisp @@ -0,0 +1,4 @@ +(in-package "SB!KERNEL") + +(sb!xc:deftype compiled-function () + '(and function #!+sb-eval (not sb!eval:interpreted-function))) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 1232ca1..e3e59b2 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -313,19 +313,33 @@ (return (any))))))))))) (intersection-type (let ((types (intersection-type-types type)) - (res (any)) - (exact nil)) - (dolist (type types (values res exact)) - (multiple-value-bind (ptype ptype-exact) + (res (any))) + ;; why NIL for the exact? Well, we assume that the + ;; intersection type is in fact doing something for us: + ;; that is, that each of the types in the intersection is + ;; in fact cutting off some of the type lattice. Since no + ;; intersection type is represented by a primitive type and + ;; primitive types are mutually exclusive, it follows that + ;; no intersection type can represent the entirety of the + ;; primitive type. (And NIL is the conservative answer, + ;; anyway). -- CSR, 2006-09-14 + (dolist (type types (values res nil)) + (multiple-value-bind (ptype) (primitive-type type) - (when ptype-exact - (aver (or (not exact) (eq ptype res))) - (setq exact t)) - (when (or ptype-exact (and (not exact) (eq res (any)))) - ;; Try to find a narrower representation then - ;; (any). Takes care of undecidable types in - ;; intersections with decidable ones. - (setq res ptype)))))) + (cond + ;; if the result so far is (any), any improvement on + ;; the specificity of the primitive type is valid. + ((eq res (any)) + (setq res ptype)) + ;; if the primitive type returned is (any), the + ;; result so far is valid. Likewise, if the + ;; primitive type is the same as the result so far, + ;; everything is fine. + ((or (eq ptype (any)) (eq ptype res))) + ;; otherwise, we have something hairy and confusing, + ;; such as (and condition funcallable-instance). + ;; Punt. + (t (return (any)))))))) (member-type (let* ((members (member-type-members type)) (res (primitive-type-of (first members)))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 5e6540a..73301f0 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -551,4 +551,11 @@ (assert-t-t (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector) '(or fixnum vector end-of-file parse-error fixnum simple-string))) + +#+sb-eval +(assert-t-t + (subtypep '(and function (not compiled-function) + (not sb-eval:interpreted-function)) + nil)) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 6c804ea..db872f1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.16.29" +"0.9.16.30"