Skip to content
Snippets Groups Projects
Commit 9793164a authored by dtc's avatar dtc
Browse files

o Add the new function order-layout-inherits to correctly order the

  layouts within the layout-inherits vector. This ensures that
  the compiler can generate inline type tests for hierarchical classes.

o Modify the definition of the stream class to be hierarchical.

o Have the condition classes correctly order their layout-inherits
  so that the hierarchical condition class is placed at it specified depth.

o Enhance the compiler instance typep transform to generate inline
  type tests for hierarchical classes, not just for structures.
parent ad770090
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.43 2000/05/02 04:44:03 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.44 2000/08/06 19:12:17 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -174,6 +174,51 @@
(1+ (random layout-hash-max seed)))))
layout)
;;; order-layout-inherits -- Interface
;;;
;;; Arrange the inherited layouts to appear at their expected depth, ensuring
;;; that hierarchical type tests succeed. Layouts with a specific depth are
;;; placed first, then the non-hierarchical layouts fill remaining elements.
;;; Any empty elements are filled with layout copies ensuring that all
;;; elements have a valid layout. This re-ordering may destroy CPL ordering so
;;; the inherits should not be read as being in CPL order, and further
;;; duplicates may be introduced.
;;;
(defun order-layout-inherits (layouts)
(declare (simple-vector layouts))
(let ((length (length layouts))
(max-depth -1))
(dotimes (i length)
(let ((depth (layout-inheritance-depth (svref layouts i))))
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
(inherits (make-array new-length)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-inheritance-depth layout)))
(unless (eql depth -1)
(unless (eql (svref inherits depth) 0)
(error "Layout depth confict: ~S~%" layouts))
(setf (svref inherits depth) layout))))
(do ((i 0 (1+ i))
(j 0))
((>= i length))
(declare (type index i j))
(let* ((layout (svref layouts i))
(depth (layout-inheritance-depth layout)))
(when (eql depth -1)
(loop (when (eql (svref inherits j) 0)
(return))
(incf j))
(setf (svref inherits j) layout))))
(do ((i (1- new-length) (1- i)))
((< i 0))
(declare (type fixnum i))
(when (eql (svref inherits i) 0)
(setf (svref inherits i) (svref inherits (1+ i)))))
inherits)))
;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a
;;; CTYPE structure as recognized by the type system.
......@@ -758,8 +803,7 @@
generic-sequence collection symbol)
:direct-superclasses (list symbol))
(stream :hierarchical nil :state :read-only
:inherits (instance t)))))
(stream :state :read-only :depth 3 :inherits (instance)))))
;;; See also type-init.lisp where we finish setting up the translations for
;;; built-in types.
......@@ -767,7 +811,7 @@
(cold-load-init
(dolist (x built-in-classes)
(destructuring-bind (name &key (translation nil trans-p) inherits codes
enumerable state (hierarchical t)
enumerable state (hierarchical t) depth
(direct-superclasses
(if inherits (list (car inherits)) '(t))))
x
......@@ -787,7 +831,9 @@
(setf (class-cell-class (find-class-cell name)) class)
(unless trans-p
(setf (info type builtin name) class))
(let* ((inheritance-depth (if hierarchical (length inherits) -1))
(let* ((inheritance-depth (if hierarchical
(or depth (length inherits))
-1))
(inherit-layouts
(map 'vector
#'(lambda (x)
......@@ -804,20 +850,20 @@
;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
;;; is loaded and the class defined.
(cold-load-init
(dolist (x '((fundamental-stream (t instance stream))))
(dolist (x '((fundamental-stream (t instance stream stream))))
(let* ((name (first x))
(inherits (second x))
(class (lisp::make-standard-class :name name))
(class-cell (lisp::find-class-cell name)))
(setf (lisp::class-cell-class class-cell) class)
(class (make-standard-class :name name))
(class-cell (find-class-cell name)))
(setf (class-cell-class class-cell) class)
(setf (info type class name) class-cell)
(setf (info type kind name) :instance)
(let ((inherit-layouts
(map 'vector #'(lambda (x)
(lisp::class-layout (lisp:find-class x)))
(class-layout (lisp:find-class x)))
inherits)))
(lisp::register-layout (lisp::find-layout name 0 inherit-layouts -1)
:invalidate nil)))))
(register-layout (find-layout name 0 inherit-layouts -1)
:invalidate nil)))))
;;; Now that we have set up the class heterarchy, seal the sealed classes.
;;; This must be done after the subclasses have been set up.
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.55 2000/07/11 04:19:45 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.56 2000/08/06 19:12:17 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -420,10 +420,10 @@
parent-types)))))
(cond-layout (info type compiler-layout 'condition))
(olayout (info type compiler-layout name))
(new-inherits
(concatenate 'simple-vector
(layout-inherits cond-layout)
(mapcar #'class-layout cpl))))
(new-inherits
(order-layout-inherits (concatenate 'simple-vector
(layout-inherits cond-layout)
(mapcar #'class-layout cpl)))))
(if (and olayout
(not (mismatch (layout-inherits olayout) new-inherits)))
olayout
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.170 2000/07/31 09:53:39 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.171 2000/08/06 19:12:18 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -1573,7 +1573,8 @@
"OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-SYMBOL-ERROR"
"OBJECT-NOT-TYPE-ERROR" "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR"
"OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR"
"ODD-KEYWORD-ARGUMENTS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
"ODD-KEYWORD-ARGUMENTS-ERROR" "ORDER-LAYOUT-INHERITS"
"OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
"PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
"PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DEVICE"
"PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME"
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.37 2000/05/23 06:52:09 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.38 2000/08/06 19:12:27 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -470,7 +470,7 @@
(%layout-invalid-error object ',layout))))
(eq ,n-layout ',layout)))))
((and (typep class 'basic-structure-class) layout)
;; Structure type tests; hierarchal layout depths.
;; Structure type tests; hierarchical layout depths.
(let ((idepth (layout-inheritance-depth layout))
(n-layout (gensym)))
`(and (,pred object)
......@@ -485,6 +485,22 @@
(eq (svref (layout-inherits ,n-layout)
,idepth)
',layout))))))))
((and layout (>= (layout-inheritance-depth layout) 0))
;; Hierarchical layout depths.
(let ((idepth (layout-inheritance-depth layout))
(n-layout (gensym)))
`(and (,pred object)
(let ((,n-layout (,get-layout object)))
,@(when (policy nil (>= safety speed))
`((when (layout-invalid ,n-layout)
(%layout-invalid-error object ',layout))))
(if (eq ,n-layout ',layout)
t
(and (> (length (layout-inherits ,n-layout)) ,idepth)
(locally (declare (optimize (safety 0)))
(eq (svref (layout-inherits ,n-layout)
,idepth)
',layout))))))))
(t
`(and (,pred object)
(class-cell-typep (,get-layout object)
......
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.17 2000/08/06 19:11:13 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.18 2000/08/06 19:12:33 dtc Exp $")
;;;
;;; Bootstrapping the meta-braid.
;;;
......@@ -563,8 +563,9 @@
(let ((lclass (kernel:layout-class layout)))
(unless (eq (kernel:class-layout lclass) layout)
(setf (kernel:layout-inherits layout)
(map 'vector #'class-wrapper
(reverse (rest (class-precedence-list class)))))
(kernel:order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class))))))
(kernel:register-layout layout :invalidate nil)
;; Subclasses of formerly forward-referenced-class may be unknown
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment