Commit 5f6bcb37 authored by ram's avatar ram
Browse files

new structure branch & tuning, see new_struct

parent fc102581
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.47 1993/01/13 18:09:43 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.48 1993/02/26 08:38:17 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -835,7 +835,10 @@
(unless (equal-check-table x file)
(dump-list x file)
(equal-save-object x file)))
(structure
(layout
(dump-layout x file)
(eq-save-object x file))
(instance
(dump-structure x file)
(eq-save-object x file))
(array
......@@ -923,7 +926,7 @@
;;; overhead on types of objects that might be circular.
;;;
(defun dump-object (x file)
(if (or (array-header-p x) (simple-vector-p x) (consp x) (structurep x))
(if (or (array-header-p x) (simple-vector-p x) (consp x) (%instancep x))
(let ((*circularities-detected* ())
(circ (fasl-file-circularity-table file)))
(clrhash circ)
......@@ -1421,11 +1424,16 @@
struct)))
(note-potential-circularity struct file)
(do ((index 0 (1+ index))
(length (structure-length struct))
(length (%instance-length struct))
(circ (fasl-file-circularity-table file)))
((= index length)
(dump-fop* length lisp::fop-small-struct lisp::fop-struct file))
(let* ((obj (structure-ref struct index))
(let* ((obj #+ns-boot
(if (zerop index)
(%instance-layout struct)
(%instance-ref struct index))
#-ns-boot
(%instance-ref struct index))
(ref (gethash obj circ)))
(cond (ref
(push (make-circularity :type :struct-set
......@@ -1438,3 +1446,17 @@
(t
(sub-dump-object obj file))))))
(defun dump-layout (obj file)
(unless (member (layout-invalid obj) '(nil :compiler))
(compiler-error "Dumping reference to obsolete class: ~S"
(layout-class obj)))
(let ((name (class-name (layout-class obj))))
(assert name)
(dump-fop 'lisp::fop-normal-load file)
(let ((*cold-load-dump* t))
(dump-object name file))
(dump-fop 'lisp::fop-maybe-cold-load file))
(sub-dump-object (layout-inherits obj) file)
(sub-dump-object (layout-inheritance-depth obj) file)
(sub-dump-object (layout-length obj) file)
(dump-fop 'lisp::fop-layout file))
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.53 1993/01/17 20:37:22 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.54 1993/02/26 08:38:24 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -93,6 +93,18 @@
(defknown (eq eql) (t t) boolean (movable foldable flushable))
(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
;;;; Classes:
(deftype name-for-class () 't)
(defknown class-name (class) name-for-class (flushable))
(defknown find-class (name-for-class &optional t lexical-environment)
(or class null) ())
(defknown class-of (t) class (flushable))
(defknown layout-of (t) layout (flushable))
(defknown copy-structure (structure-object) structure-object
(flushable unsafe))
;;;; In the "Control Structure" chapter:
......@@ -1150,7 +1162,7 @@
;;; into non-standard unary predicates.
(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
long-float-p base-char-p %standard-char-p structurep
long-float-p base-char-p %standard-char-p %instancep
array-header-p)
(t) boolean (movable foldable flushable))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.2 1992/03/22 17:30:26 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.3 1993/02/26 08:42:49 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -147,9 +147,11 @@
"Object is not of type COMPLEX.")
(object-not-weak-pointer
"Object is not a WEAK-POINTER.")
(object-not-structure
"Object is not a STRUCTURE.")
(object-not-instance
"Object is not a INSTANCE.")
(object-not-base-char
"Object is not of type BASE-CHAR.")
(nil-function-returned
"Function with declared result type NIL returned."))
"Function with declared result type NIL returned.")
(layout-invalid
"Layout is invalid (instance obsolete.)"))
......@@ -6,7 +6,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.3 1992/12/17 09:29:25 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.4 1993/02/26 08:42:50 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -176,7 +176,7 @@
(high (descriptor-high des))
(low (descriptor-low des)))
(when (or (eql lowtag vm:function-pointer-type)
(eql lowtag vm:structure-pointer-type)
(eql lowtag vm:instance-pointer-type)
(eql lowtag vm:list-pointer-type)
(eql lowtag vm:other-pointer-type))
(dolist (space (list *dynamic* *static* *read-only*)
......@@ -463,6 +463,18 @@
"Generates code to push the THING onto the given cold load LIST."
`(setq ,list (allocate-cons *dynamic* ,thing ,list)))
;;; COLD-VECTOR -- Internal
;;;
;;; Make a simple-vector that holds the specified Objects and return its
;;; decriptor.
;;;
(defun cold-vector (&rest objects)
(let* ((size (length objects))
(result (allocate-vector-object *dynamic* vm:word-bits size
vm:simple-vector-type)))
(dotimes (index size)
(write-indexed result (+ index vm:vector-data-offset) (pop objects)))
result))
;;;; Symbol magic.
......@@ -627,6 +639,8 @@
(frob *free-interrupt-context-index* (make-fixnum-descriptor 0))
(frob *initial-layouts* (list-all-layouts))
(let ((res *nil-descriptor*))
(dolist (cpkg *cold-packages*)
(let* ((pkg (car cpkg))
......@@ -668,8 +682,6 @@
(frob *lisp-initialization-functions* *current-init-functions-cons*)
;; Nothing should be allocated after this.
;;
(frob *read-only-space-free-pointer*
......@@ -802,6 +814,86 @@
*fdefn-objects*)
result))
;;;; Layouts & type system pre-initialization:
;;;
;;; Since we want to be able to dump structure constants and predicates with
;;; reference layouts, we need to create layouts at cold-load time. We use the
;;; name to intern layouts by, and dump a list of all cold layouts in
;;; *INITIAL-LAYOUTS* so that type-system initialization can find them. The
;;; only thing that's tricky is initializing layout's layout, which must point
;;; to itself.
;;; Table mapping from class names to descriptors for their layouts.
;;;
(defvar *cold-layouts* (make-hash-table :test #'equal))
;;; The descriptor for layout's layout, which we need when making layouts.
;;;
(defvar *layout-layout*)
(defparameter target-layout-length 16)
(defun make-cold-layout (name length inherits depth)
(let ((result (allocate-boxed-object *dynamic* (1+ target-layout-length)
vm:instance-pointer-type)))
(write-memory result (make-other-immediate-descriptor
target-layout-length vm:instance-header-type))
(write-indexed result vm:instance-slots-offset *layout-layout*)
(let ((base (+ vm:instance-slots-offset
kernel:layout-hash-length
1)))
;0 class uninitialized
(write-indexed result (+ base 1) *nil-descriptor*); invalid
(write-indexed result (+ base 2) inherits)
(write-indexed result (+ base 3) depth)
(write-indexed result (+ base 4) length)
(write-indexed result (+ base 5) *nil-descriptor*); info
(write-indexed result (+ base 6) *nil-descriptor*)); pure
(setf (gethash name *cold-layouts*) result)
result))
;;; INITIALIZE-LAYOUTS -- Internal
;;;
;;; Clear the layout table and set *layout-layout*. We initially create
;;; LAYOUT with NIL as the LAYOUT and INHERITS, then back-patch with itself and
;;; the correct INHERITS vector (which includes T, INSTANCE and
;;; STRUCTURE-OBJECT).
;;;
(defun initialize-layouts ()
(clrhash *cold-layouts*)
(setq *layout-layout* *nil-descriptor*)
(setq *layout-layout*
(make-cold-layout 'layout (number-to-core target-layout-length)
*nil-descriptor* (number-to-core 3)))
(write-indexed *layout-layout* vm:instance-slots-offset *layout-layout*)
(let* ((t-layout
(make-cold-layout 't (number-to-core 0)
(cold-vector) (number-to-core 0)))
(inst-layout
(make-cold-layout 'instance (number-to-core 0)
(cold-vector t-layout) (number-to-core 1)))
(so-layout
(make-cold-layout 'structure-object (number-to-core 1)
(cold-vector t-layout inst-layout)
(number-to-core 2))))
(write-indexed *layout-layout*
(+ vm:instance-slots-offset layout-hash-length 1 2)
(cold-vector t-layout inst-layout so-layout))))
;;; LIST-ALL-LAYOUTS -- Internal
;;;
;;; Return a cold alist that we're going to store in *INITIAL-LAYOUTS*.
;;;
(defun list-all-layouts ()
(let ((result *nil-descriptor*))
(maphash #'(lambda (key value)
(cold-push (allocate-cons *dynamic* (cold-intern key) value)
result))
*cold-layouts*)
result))
;;;; Reading FASL files.
......@@ -872,15 +964,23 @@
(fop-small-struct)
(let* ((size (clone-arg))
(result (allocate-boxed-object *dynamic* (1+ size)
vm:structure-pointer-type)))
vm:instance-pointer-type)))
(write-memory result (make-other-immediate-descriptor
size vm:structure-header-type))
size vm:instance-header-type))
(do ((index (1- size) (1- index)))
((minusp index))
(declare (fixnum index))
(write-indexed result (+ index vm:structure-slots-offset) (pop-stack)))
(write-indexed result (+ index vm:instance-slots-offset) (pop-stack)))
result))
(define-cold-fop (fop-layout)
(let ((length (pop-stack))
(depth (pop-stack))
(inherits (pop-stack))
(name (pop-stack)))
(or (gethash name *cold-layouts*)
(make-cold-layout name length inherits depth))))
;;; Loading symbols...
......@@ -1193,7 +1293,7 @@
(write-indexed obj
(+ idx
(ecase (descriptor-lowtag obj)
(#.vm:structure-pointer-type 1)
(#.vm:instance-pointer-type 1)
(#.vm:other-pointer-type 2)))
(pop-stack))))
......@@ -1775,6 +1875,7 @@
(let ((version (load-foreign-symbol-table symbol-table)))
(initialize-spaces)
(initialize-symbols)
(initialize-layouts)
(setf *current-init-functions-cons* *nil-descriptor*)
(initialize-static-fns)
(dolist (file (if (listp file-list)
......@@ -1838,17 +1939,29 @@
(push (cons name (descriptor-bits addr))
funs)))))
*fdefn-objects*)
(format t "~2%Initially defined functions:~2%")
(format t "~%~|~%Initially defined functions:~2%")
(dolist (info (sort funs #'< :key #'cdr))
(format t "#x~8,'0X: ~S~%" (cdr info) (car info)))
(format t "~2%Undefined function references:~2%")
(format t "~%~|~%Undefined function references:~2%")
(labels ((key (name)
(etypecase name
(symbol (symbol-name name))
(integer (prin1-to-string name))
(list (key (second name))))))
(dolist (fun (sort undefs #'string< :key #'key))
(format t "~S~%" fun)))))
(format t "~S~%" fun)))
(format t "~%~|~%Layout names:~2%")
(collect ((stuff))
(maphash #'(lambda (name desc)
(stuff (cons (logior (ash (descriptor-high desc)
descriptor-low-bits)
(descriptor-low desc))
name)))
*cold-layouts*)
(dolist (x (sort (stuff) #'< :key #'car))
(format t "~8,'0X: ~S~%" (car x) (cdr x))))))
(undefined-value))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.23 1992/12/16 21:36:27 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.24 1993/02/26 08:42:54 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -21,7 +21,7 @@
(export '(lowtag-bits lowtag-mask lowtag-limit type-bits type-mask
target-most-positive-fixnum target-most-negative-fixnum
even-fixnum-type function-pointer-type other-immediate-0-type
list-pointer-type odd-fixnum-type structure-pointer-type
list-pointer-type odd-fixnum-type instance-pointer-type
other-immediate-1-type other-pointer-type bignum-type ratio-type
single-float-type double-float-type complex-type
simple-array-type simple-string-type simple-bit-vector-type
......@@ -38,7 +38,7 @@
dylan-function-header-type
value-cell-header-type symbol-header-type base-char-type
sap-type unbound-marker-type weak-pointer-type
structure-header-type funcallable-instance-header-type
instance-header-type funcallable-instance-header-type
fdefn-type vector-normal-subtype
vector-valid-hashing-subtype vector-must-rehash-subtype
forwarding-pointer-type scavenger-hook-type))
......@@ -93,7 +93,7 @@
other-immediate-0
list-pointer
odd-fixnum
structure-pointer
instance-pointer
other-immediate-1
other-pointer)
......@@ -141,7 +141,7 @@
sap
unbound-marker
weak-pointer
structure-header
instance-header
fdefn
#+gengc scavenger-hook
)
......@@ -163,9 +163,9 @@
(car :ref-trans car :set-trans c::%rplaca :init :arg)
(cdr :ref-trans cdr :set-trans c::%rplacd :init :arg))
(define-primitive-object (structure :lowtag structure-pointer-type
:header structure-header-type
:alloc-trans make-structure)
(define-primitive-object (instance :lowtag instance-pointer-type
:header instance-header-type
:alloc-trans %make-instance)
(slots :rest-p t))
(define-primitive-object (bignum :lowtag other-pointer-type
......
;;; -*- Package: C; Log: C.Log -*-
;;; -*- Package: VM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
......@@ -7,12 +7,10 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.8 1992/12/05 22:11:35 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.9 1993/02/26 08:42:55 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.8 1992/12/05 22:11:35 wlott Exp $
;;;
;;; This file contains the machine independent aspects of the object
;;; representation and primitive types.
;;;
......@@ -60,7 +58,7 @@
;;;
(def-primitive-type function (descriptor-reg))
(def-primitive-type list (descriptor-reg))
(def-primitive-type structure (descriptor-reg))
(def-primitive-type instance (descriptor-reg))
;;; Primitive other-pointer number types.
;;;
......@@ -241,27 +239,26 @@
(unless (eq (primitive-type-of mem) res)
(return (values *any-primitive-type* nil))))))
(named-type
(case (named-type-name type)
((t bignum ratio complex function structure
system-area-pointer weak-pointer)
(values (primitive-type-or-lose (named-type-name type) *backend*) t))
((character base-char string-char)
(ecase (named-type-name type)
((t *) (values *any-primitive-type* t))
((nil) (values *any-primitive-type* nil))))
(built-in-class
(case (class-name type)
((complex function generic-function instance
system-area-pointer weak-pointer)
(values (primitive-type-or-lose (class-name type) *backend*) t))
(base-char
(exactly base-char))
(standard-char
(part-of base-char))
(cons
(part-of list))
((dylan::dylan-function dylan::generic-function dylan::exit-function
dylan::next-method-func dylan::method dylan::defined-method
dylan::builtin-method dylan::slot-accessor-method
dylan::slot-setter-method dylan::slot-getter-method)
(part-of function))
(t
(any))))
(function-type
(exactly function))
(structure-type
(part-of structure))
(class
(if (csubtypep type (specifier-type 'function))
(part-of function)
(part-of instance)))
(ctype
(any)))))
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.47 1992/12/17 09:30:26 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.48 1993/02/26 08:42:56 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -47,7 +47,7 @@
;;; into non-standard unary predicates.
(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
long-float-p base-char-p %string-char-p %standard-char-p structurep
long-float-p base-char-p %string-char-p %standard-char-p %instancep
array-header-p simple-array-p simple-array-unsigned-byte-2-p
simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
......@@ -89,18 +89,29 @@
(unsafe))
(defknown make-structure (structure-index) structure
(defknown %make-instance (index) instance
(unsafe))
(defknown structure-type (structure) t
(defknown %instance-layout (instance) layout
(foldable flushable))
(defknown structure-length (structure) structure-index
(defknown %set-instance-layout (instance layout) layout
(unsafe))
(defknown %instance-length (instance) index
(foldable flushable))
(defknown structure-ref (structure structure-index) t
(defknown %instance-ref (instance index) t
(flushable))
(defknown structure-set (structure structure-index t) t
(defknown %instance-set (instance index t) t
(unsafe))
(defknown %layout-invalid-error (t layout) nil)
(deftype raw-vector () '(simple-array (unsigned-byte 32) (*)))
(defknown %raw-ref-single (raw-vector index) single-float
(foldable flushable))
(defknown %raw-ref-double (raw-vector index) double-float
(foldable flushable))
(defknown %raw-set-single (raw-vector index single-float) single-float
(unsafe))
(defknown %raw-set-double (raw-vector index double-float) double-float
(unsafe))
(defknown %raw-bits (t fixnum) (unsigned-byte 32)
(foldable flushable))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.28 1993/01/15 22:42:16 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.29 1993/02/26 08:42:57 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -33,6 +33,14 @@
(deftransform abs ((x) (rational))
'(if (< x 0) (- x) x))
;;; For now, the layout is stored in slot 0.
;;;
(def-source-transform %instance-layout (x)
`(truly-the layout (%instance-ref ,x 0)))
;;;
(def-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
;;;; Charater support.
......@@ -41,7 +49,6 @@
(def-source-transform characterp (obj)
`(base-char-p ,obj))
;;;; Transforms for data-vector-ref for strange array types.
......@@ -112,8 +119,6 @@
(frob (simple-array (unsigned-byte 2) (*)) 2)
(frob (simple-array (unsigned-byte 4) (*)) 4))
;;;; Simple string transforms:
......
......@@ -7,12 +7,10 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.28 1991/12/16 10:09:55 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.29 1993/02/26 08:42:59 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.28 1991/12/16 10:09:55 wlott Exp $
;;;
;;; This file contains implementation-dependent parts of the type support
;;; code. This is stuff which deals with the mapping from types defined in
;;; Common Lisp to types actually supported by an implementation.
......@@ -36,15 +34,6 @@
(deftype short-float (&optional low high)
`(single-float ,low ,high))
;;; Compiled-function is the same as function in this implementation.
;;;
(deftype compiled-function () 'function)
;;; Character is the same as base-char.
(setf (info type builtin 'character) nil)
(setf (info type kind 'character) :defined)
(deftype character () 'base-char)
;;;
;;; An index into an integer.
(deftype bit-index () `(integer 0 ,most-positive-fixnum))
......@@ -86,8 +75,11 @@
(deftype bignum-type () 'bignum)
(deftype bignum-index () 'index)
#+ns-boot
(deftype structure-index () `(unsigned-byte ,(- vm:word-bits vm:type-bits)))
(deftype instance-index () `(unsigned-byte ,(- vm:word-bits vm:type-bits)))
;;;; Hooks into type system:
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.26 1992/12/17 11:31:24 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.27 1993/02/26 08:38:31 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -526,6 +526,7 @@
;;;
(defstruct (compact-info-env
(:include info-env)
(:pure t)
(:print-function %print-info-environment))
;;
;; If this value is EQ to the name we want to look up, then the