diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index d2a4e61a5322f319b1132bbb582cf10986964904..e3962d1ef5f24cfa8211537ce213f7908e1c3811 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.8 1993/05/13 18:20:47 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.9 1993/08/31 11:52:26 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -167,6 +167,17 @@ (logior (ash (descriptor-high des) descriptor-low-bits) (descriptor-low des))) +#+nil; unused +(defun descriptor-eq (x y) + (and (eql (descriptor-high x) (descriptor-high y)) + (eql (descriptor-low x) (descriptor-low y)))) + +(defun descriptor-fixnum (x) + (let ((bits (descriptor-bits x))) + (if (logbitp (1- vm:word-bits) bits) + (logior (ash bits -2) (ash -1 (1- vm:word-bits))) + (ash bits -2)))) + (defun descriptor-sap (des) "Return a SAP pointing to the piece of memory DES refers to. The lowtag bits of DES are ignored." @@ -824,10 +835,16 @@ ;;; 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. +;;; Table mapping from class names to lists of: +;;; (descriptor name length inherits depth) ;;; (defvar *cold-layouts* (make-hash-table :test #'equal)) +;;; Table mapping DESCRIPTOR-BITS of cold layouts to the name, for inverting +;;; mapping. +;;; +(defvar *cold-layout-names* (make-hash-table :test #'eql)) + ;;; The descriptor for layout's layout, which we need when making layouts. ;;; (defvar *layout-layout*) @@ -850,9 +867,45 @@ (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) + (setf (gethash name *cold-layouts*) + (list result name (descriptor-fixnum length) + (listify-cold-inherits inherits) + (descriptor-fixnum depth))) + (setf (gethash (descriptor-bits result) *cold-layout-names*) name) result)) +(defun listify-cold-inherits (x) + (let ((len (descriptor-fixnum (read-indexed x vm:vector-length-slot)))) + (collect ((res)) + (dotimes (i len) + (let* ((des (read-indexed x (+ vm:vector-data-offset i))) + (found (gethash (descriptor-bits des) *cold-layout-names*))) + (if found + (res found) + (res (format nil "Unknown descriptor, bits = ~8,'0X" + (descriptor-bits des)))))) + (res)))) + +(defun cold-layout-redefined (old inherits depth length) + (destructuring-bind (descriptor name olength oinherits-l odepth) + old + (declare (ignore descriptor)) + (let ((result nil)) + (unless (eql (descriptor-fixnum length) olength) + (warn "Changing ~S length from ~D to ~D." + name olength (descriptor-fixnum length)) + (setq result t)) + (unless (eql (descriptor-fixnum depth) odepth) + (warn "Changing ~S inheritance-depth from ~D to ~D." + name odepth (descriptor-fixnum depth)) + (setq result t)) + (let ((inherits-l (listify-cold-inherits inherits))) + (unless (equal inherits-l oinherits-l) + (warn "Changing ~S inherits from:~% ~S~%To:~% ~S" + name oinherits-l inherits-l) + (setq result t))) + result))) + ;;; INITIALIZE-LAYOUTS -- Internal ;;; @@ -866,7 +919,7 @@ (setq *layout-layout* *nil-descriptor*) (setq *layout-layout* (make-cold-layout 'layout (number-to-core target-layout-length) - *nil-descriptor* (number-to-core 3))) + (cold-vector) (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) @@ -878,9 +931,12 @@ (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)))) + (let ((layout-inh (cold-vector t-layout inst-layout so-layout))) + (setf (fourth (gethash 'layout *cold-layouts*)) + (listify-cold-inherits layout-inh)) + (write-indexed *layout-layout* + (+ vm:instance-slots-offset layout-hash-length 1 2) + layout-inh)))) ;;; LIST-ALL-LAYOUTS -- Internal @@ -889,8 +945,9 @@ ;;; (defun list-all-layouts () (let ((result *nil-descriptor*)) - (maphash #'(lambda (key value) - (cold-push (allocate-cons *dynamic* (cold-intern key) value) + (maphash #'(lambda (key stuff) + (cold-push (allocate-cons *dynamic* (cold-intern key) + (first stuff)) result)) *cold-layouts*) result)) @@ -973,13 +1030,48 @@ (write-indexed result (+ index vm:instance-slots-offset) (pop-stack))) result)) +;;; Check for layout redefinition, and possibly clobber old layout w/ new info. +;;; (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)))) + (let* ((length (pop-stack)) + (depth (pop-stack)) + (inherits (pop-stack)) + (name (pop-stack)) + (old (gethash name *cold-layouts*))) + (cond + (old + (when (cold-layout-redefined old inherits depth length) + (restart-case + (error "Loading a reference to class ~S when the compile~ + ~% time definition was incompatible with the current ~ + one." + name) + (use-current () + :report "Ignore the incompatibility, leave class alone." + (warn "Assuming the current definition of ~S is correct, and~@ + that the loaded code doesn't care about the ~ + incompatibility." + name)) + (clobber-it () + :report "Smash current layout, preserving old code." + (warn "Any old ~S instances will be in a bad way.~@ + I hope you know what you're doing..." + name) + + (let ((base (+ vm:instance-slots-offset + kernel:layout-hash-length + 1)) + (desc (first old))) + (write-indexed desc (+ base 2) inherits) + (write-indexed desc (+ base 3) depth) + (write-indexed desc (+ base 4) length) + (setf (gethash name *cold-layouts*) + (list desc name (descriptor-fixnum length) + (listify-cold-inherits inherits) + (descriptor-fixnum depth))))))) + (first old)) + (t + (make-cold-layout name length inherits depth))))) ;;; Loading symbols... @@ -1951,19 +2043,20 @@ (integer (prin1-to-string name)) (list (key (second name)))))) (dolist (fun (sort undefs #'string< :key #'key)) - (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)))))) - + (if (integerp fun) + (format t "~8,'0X~%" fun) + (format t "~S~%" fun)))))) + + (format t "~%~|~%Layout names:~2%") + (collect ((stuff)) + (maphash #'(lambda (name gorp) + (declare (ignore name)) + (stuff (cons (descriptor-bits (car gorp)) + (cdr gorp)))) + *cold-layouts*) + (dolist (x (sort (stuff) #'< :key #'car)) + (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))) + (undefined-value)) @@ -2075,4 +2168,3 @@ (write-long 2))) (format t "done]~%") (force-output)) -