From b9ec1808bb690fe4dc1f11c54692389d5aa222fa Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sun, 24 Jan 1993 19:22:12 +0000 Subject: [PATCH] New structure hax. --- compiler/generic/new-genesis.lisp | 119 +++++++++++++++++++++++++++--- 1 file changed, 108 insertions(+), 11 deletions(-) diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 2bcd73327..b6b285914 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -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.3.1.1 1993/01/24 19:22:12 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*) @@ -459,10 +459,19 @@ (write-indexed dest 1 cdr) dest)) -(defmacro cold-push (thing list) - "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 +636,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 +679,6 @@ (frob *lisp-initialization-functions* *current-init-functions-cons*) - - ;; Nothing should be allocated after this. ;; (frob *read-only-space-free-pointer* @@ -802,6 +811,85 @@ *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 15) + +(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 + (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 *nil-handle* + (number-to-core target-layout-length) + (number-to-core 3))) + (write-indexed *layout-layout* vm:instance-slots-offset *layout-layout*) + (let* ((t-layout + (make-cold-layout 't (cold-vector) + (number-to-core 0) (number-to-core 0))) + (inst-layout + (make-cold-layout 'instance (cold-vector t-layout) + (number-to-core 0) (number-to-core 1))) + (so-layout + (make-cold-layout 'structure-object + (cold-vector t-layout inst-layout) + (number-to-core 1) (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 (cold-cons (cold-intern key) value) result)) + *cold-layouts*) + result)) ;;;; Reading FASL files. @@ -872,15 +960,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 +1289,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 +1871,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) -- GitLab