Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28622/src/compiler/generic
Modified Files:
genesis.lisp primtype.lisp
Log Message:
0.9.4.54:
Declassification of INSTANCE and FUNCALLABLE-INSTANCE.
It turns out that the classes INSTANCE and
FUNCALLABLE-INSTANCE, as expressed in instance-pointer-lowtag
and funcallable-instance-widetag, are incompatible with the
MOP's notion of classes: the types INSTANCE and
FUNCALLABLE-INSTANCE are necessarily disjoint (no instance can
have a widetag of anything other than instance-header-widetag),
but FUNCALLABLE-STANDARD-OBJECT is required to be a subclass of
STANDARD-OBJECT, and must therefore have the superclasses of
STANDARD-OBJECT among its superclasses. If INSTANCE is one of
those, FUNCALLABLE-INSTANCE cannot be, so F-S-Os would not be of
type FUNCALLABLE-INSTANCE (which is wrong); if it is not one of
those, then ordinary S-Os would not be of type INSTANCE (which
is wrong). CMUCL, at the time of writing, exhibits type system
confusion in this area, as demonstrated by CSR cmucl-imp
2005-09-0x).
So, we need to do something else; probably most straightforward
to make INSTANCE and FUNCALLABLE-INSTANCE named types, as they
are of the same order of specialness as e.g. T -- not quite as
special, but almost. Some hacking later...
... the usual type system dance. Play whack-a-mole with test
failures and compilation failures until they all go
away. Primtype, class, typetran, and so on are
fiddled with.
... somewhat hacky code for determining when a class is subtypep
instance / funcallable-instance.
... different hard-coded constants for genesis; don't make a
special instance-layout, because the instance class is
gone.
... just to prove we've achieved something, make STANDARD-OBJECT
a superclass of FUNCALLABLE-STANDARD-OBJECT.
(Supporting METAOBJECT should be straightforward now)
... many many new tests, both of the before-xc variety (it's
amazing in how many ways I can get the type system
wrong) and of the regular form. Also add some
ctor tests that aren't exercised yet.
Index: genesis.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/genesis.lisp,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -d -r1.109 -r1.110
--- genesis.lisp 31 Aug 2005 14:12:37 -0000 1.109
+++ genesis.lisp 9 Sep 2005 14:16:18 -0000 1.110
@@ -980,7 +980,7 @@
(number-to-core target-layout-length)
(vector-in-core)
;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
- (number-to-core 4)
+ (number-to-core 3)
;; no raw slots in LAYOUT:
(number-to-core 0)))
(write-wordindexed *layout-layout*
@@ -998,26 +998,19 @@
(vector-in-core)
(number-to-core 0)
(number-to-core 0)))
- (i-layout
- (make-cold-layout 'instance
- (number-to-core 0)
- (vector-in-core t-layout)
- (number-to-core 1)
- (number-to-core 0)))
(so-layout
(make-cold-layout 'structure-object
(number-to-core 1)
- (vector-in-core t-layout i-layout)
- (number-to-core 2)
+ (vector-in-core t-layout)
+ (number-to-core 1)
(number-to-core 0)))
(bso-layout
(make-cold-layout 'structure!object
(number-to-core 1)
- (vector-in-core t-layout i-layout so-layout)
- (number-to-core 3)
+ (vector-in-core t-layout so-layout)
+ (number-to-core 2)
(number-to-core 0)))
(layout-inherits (vector-in-core t-layout
- i-layout
so-layout
bso-layout)))
Index: primtype.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/primtype.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- primtype.lisp 14 Jul 2005 18:35:36 -0000 1.21
+++ primtype.lisp 9 Sep 2005 14:16:18 -0000 1.22
@@ -321,19 +321,19 @@
;; have an exact primitive type.
(return (part-of function)))
(multiple-value-bind (ptype ptype-exact)
- (primitive-type type)
- (when ptype-exact
- ;; Apart from the previous kludge exact primitive
- ;; types should match, if indeed there are any. It
- ;; may be that this assumption isn't really safe,
- ;; but at least we'll see what breaks. -- NS 20041104
- (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))))))
+ (primitive-type type)
+ (when ptype-exact
+ ;; Apart from the previous kludge exact primitive
+ ;; types should match, if indeed there are any. It
+ ;; may be that this assumption isn't really safe,
+ ;; but at least we'll see what breaks. -- NS 20041104
+ (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))))))
(member-type
(let* ((members (member-type-members type))
(res (primitive-type-of (first members))))
@@ -348,34 +348,33 @@
(named-type
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
+ ((instance) (exactly instance))
+ ((funcallable-instance) (part-of function))
((nil) (any))))
- (character-set-type
- (let ((pairs (character-set-type-pairs type)))
- (if (and (= (length pairs) 1)
- (= (caar pairs) 0)
- (= (cdar pairs) (1- sb!xc:char-code-limit)))
- (exactly character)
- (part-of character))))
- (built-in-classoid
- (case (classoid-name type)
- ((complex function instance
- system-area-pointer weak-pointer)
- (values (primitive-type-or-lose (classoid-name type)) t))
- (funcallable-instance
- (part-of function))
- (cons-type
- (part-of list))
- (t
- (any))))
- (fun-type
- (exactly function))
- (classoid
- (if (csubtypep type (specifier-type 'function))
- (part-of function)
- (part-of instance)))
- (ctype
- (if (csubtypep type (specifier-type 'function))
- (part-of function)
- (any)))))))
+ (character-set-type
+ (let ((pairs (character-set-type-pairs type)))
+ (if (and (= (length pairs) 1)
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (exactly character)
+ (part-of character))))
+ (built-in-classoid
+ (case (classoid-name type)
+ ((complex function system-area-pointer weak-pointer)
+ (values (primitive-type-or-lose (classoid-name type)) t))
+ (cons-type
+ (part-of list))
+ (t
+ (any))))
+ (fun-type
+ (exactly function))
+ (classoid
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (part-of instance)))
+ (ctype
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (any)))))))
(/show0 "primtype.lisp end of file")
|