X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=a3a8169c6ef34dbca89b099e746eaf03d07da0ac;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=14532ed64bf42438d940d9629c0c0e27ba0cf1ab;hpb=94743c6e54d28544f72565e52a56877fa91f180c;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 14532ed..a3a8169 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -84,7 +84,7 @@ ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM ;;; in order to guarantee that several hash values can be added without ;;; overflowing into a bignum. -(def!constant layout-clos-hash-max (ash most-positive-fixnum -3) +(def!constant layout-clos-hash-max (ash sb!xc:most-positive-fixnum -3) #!+sb-doc "the inclusive upper bound on LAYOUT-CLOS-HASH values") @@ -113,12 +113,6 @@ ;;; type checking and garbage collection. Whenever a class is ;;; incompatibly redefined, a new layout is allocated. If two object's ;;; layouts are EQ, then they are exactly the same type. -;;; -;;; KLUDGE: The genesis code has raw offsets of slots in this -;;; structure hardwired into it. It would be good to rewrite that code -;;; so that it looks up those offsets in the compiler's tables, but -;;; for now if you change this structure, lucky you, you get to grovel -;;; over the genesis code by hand.:-( -- WHN 19990820 (def!struct (layout ;; KLUDGE: A special hack keeps this from being ;; called when building code for the @@ -173,9 +167,9 @@ ;; and PCL has made it invalid and made a note to itself about it (invalid :uninitialized :type (or cons (member nil t :uninitialized))) ;; the layouts for all classes we inherit. If hierarchical, i.e. if - ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS, - ;; so that each inherited layout appears at its expected depth, - ;; i.e. at its LAYOUT-DEPTHOID value. + ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS + ;; (least to most specific), so that each inherited layout appears + ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value. ;; ;; Remaining elements are filled by the non-hierarchical layouts or, ;; if they would otherwise be empty, by copies of succeeding layouts. @@ -201,8 +195,11 @@ ;; substructure (and hence can be copied into read-only space by ;; PURIFY). ;; - ;; KLUDGE: This slot is known to the C runtime support code. - (pure nil :type (member t nil 0))) + ;; This slot is known to the C runtime support code. + (pure nil :type (member t nil 0)) + ;; Number of raw words at the end. + ;; This slot is known to the C runtime support code. + (n-untagged-slots 0 :type index)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) @@ -278,16 +275,19 @@ ;;; preexisting class slot value is OK, and if it's not initialized, ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This ;;; is no longer true, :UNINITIALIZED used instead. -(declaim (ftype (function (layout classoid index simple-vector layout-depthoid) +(declaim (ftype (function (layout classoid index simple-vector layout-depthoid + index) layout) init-or-check-layout)) -(defun init-or-check-layout (layout classoid length inherits depthoid) +(defun init-or-check-layout + (layout classoid length inherits depthoid nuntagged) (cond ((eq (layout-invalid layout) :uninitialized) ;; There was no layout before, we just created one which ;; we'll now initialize with our information. (setf (layout-length layout) length (layout-inherits layout) inherits (layout-depthoid layout) depthoid + (layout-n-untagged-slots layout) nuntagged (layout-classoid layout) classoid (layout-invalid layout) nil)) ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this @@ -299,7 +299,7 @@ ;; information, and we'll now check that old information ;; which was known with certainty is consistent with current ;; information which is known with certainty. - (check-layout layout classoid length inherits depthoid))) + (check-layout layout classoid length inherits depthoid nuntagged))) layout) ;;; In code for the target Lisp, we don't use dump LAYOUTs using the @@ -338,7 +338,8 @@ ',(layout-classoid layout) ',(layout-length layout) ',(layout-inherits layout) - ',(layout-depthoid layout))))) + ',(layout-depthoid layout) + ',(layout-n-untagged-slots layout))))) ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. @@ -347,10 +348,11 @@ simple-string index simple-vector - layout-depthoid)) + layout-depthoid + index)) redefine-layout-warning)) (defun redefine-layout-warning (old-context old-layout - context length inherits depthoid) + context length inherits depthoid nuntagged) (declare (type layout old-layout) (type simple-string old-context context)) (let ((name (layout-proper-name old-layout))) (or (let ((old-inherits (layout-inherits old-layout))) @@ -358,8 +360,8 @@ inherits :key #'layout-proper-name) (warn "change in superclasses of class ~S:~% ~ - ~A superclasses: ~S~% ~ - ~A superclasses: ~S" + ~A superclasses: ~S~% ~ + ~A superclasses: ~S" name old-context (map 'list #'layout-proper-name old-inherits) @@ -370,8 +372,8 @@ (when diff (warn "in class ~S:~% ~ - ~:(~A~) definition of superclass ~S is incompatible with~% ~ - ~A definition." + ~:(~A~) definition of superclass ~S is incompatible with~% ~ + ~A definition." name old-context (layout-proper-name (svref old-inherits diff)) @@ -380,27 +382,37 @@ (let ((old-length (layout-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ - ~A length: ~W~% ~ - ~A length: ~W" + ~A length: ~W~% ~ + ~A length: ~W" name old-context old-length context length) t)) + (let ((old-nuntagged (layout-n-untagged-slots old-layout))) + (unless (= old-nuntagged nuntagged) + (warn "change in instance layout of class ~S:~% ~ + ~A untagged slots: ~W~% ~ + ~A untagged slots: ~W" + name + old-context old-nuntagged + context nuntagged) + t)) (unless (= (layout-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ - between the ~A definition and the ~A definition" + between the ~A definition and the ~A definition" name old-context context) t)))) ;;; Require that LAYOUT data be consistent with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID. (declaim (ftype (function - (layout classoid index simple-vector layout-depthoid)) + (layout classoid index simple-vector layout-depthoid index)) check-layout)) -(defun check-layout (layout classoid length inherits depthoid) +(defun check-layout (layout classoid length inherits depthoid nuntagged) (aver (eq (layout-classoid layout) classoid)) (when (redefine-layout-warning "current" layout - "compile time" length inherits depthoid) + "compile time" length inherits depthoid + nuntagged) ;; Classic CMU CL had more options here. There are several reasons ;; why they might want more options which are less appropriate for ;; us: (1) It's hard to fit the classic CMU CL flexible approach @@ -415,7 +427,7 @@ ;; system from scratch, so we no longer need this functionality in ;; order to maintain the SBCL system by modifying running images. (error "The class ~S was not changed, and there's no guarantee that~@ - the loaded code (which expected another layout) will work." + the loaded code (which expected another layout) will work." (layout-proper-name layout))) (values)) @@ -425,16 +437,18 @@ ;;; Used by the loader to forward-reference layouts for classes whose ;;; definitions may not have been loaded yet. This allows type tests ;;; to be loaded when the type definition hasn't been loaded yet. -(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout) +(declaim (ftype (function (symbol index simple-vector layout-depthoid index) + layout) find-and-init-or-check-layout)) -(defun find-and-init-or-check-layout (name length inherits depthoid) +(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged) (let ((layout (find-layout name))) (init-or-check-layout layout (or (find-classoid name nil) - (make-undefined-classoid name)) + (layout-classoid layout)) length inherits - depthoid))) + depthoid + nuntagged))) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a @@ -480,6 +494,7 @@ (layout-inherits destruct-layout) (layout-inherits layout) (layout-depthoid destruct-layout)(layout-depthoid layout) (layout-length destruct-layout) (layout-length layout) + (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) (layout-info destruct-layout) (layout-info layout) (classoid-layout classoid) destruct-layout) (setf (layout-invalid layout) nil @@ -702,13 +717,17 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun find-classoid (name &optional (errorp t) environment) #!+sb-doc - "Return the class with the specified NAME. If ERRORP is false, then NIL is - returned when no such class exists." + "Return the class with the specified NAME. If ERRORP is false, then +NIL is returned when no such class exists." (declare (type symbol name) (ignore environment)) (let ((res (classoid-cell-classoid (find-classoid-cell name)))) (if (or res (not errorp)) res - (error "class not yet defined:~% ~S" name)))) + (error 'simple-type-error + :datum nil + :expected-type 'class + :format-control "class not yet defined:~% ~S" + :format-arguments (list name))))) (defun (setf find-classoid) (new-value name) #-sb-xc (declare (type (or null classoid) new-value)) (cond @@ -931,11 +950,9 @@ (setq *built-in-classes* '((t :state :read-only :translation t) - (character :enumerable t :translation base-char - :prototype-form (code-char 42)) - (base-char :enumerable t - :inherits (character) - :codes (#.sb!vm:base-char-widetag) + (character :enumerable t + :codes (#.sb!vm:character-widetag) + :translation (character-set) :prototype-form (code-char 42)) (symbol :codes (#.sb!vm:symbol-header-widetag) :prototype-form '#:mu) @@ -1024,8 +1041,7 @@ :translation (and integer (not fixnum)) :inherits (integer rational real number) :codes (#.sb!vm:bignum-widetag) - ;; FIXME: wrong for 64-bit! - :prototype-form (expt 2 42)) + :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2)))) (array :translation array :codes (#.sb!vm:complex-array-widetag) :hierarchical-p nil @@ -1091,6 +1107,7 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) (simple-array-unsigned-byte-29 :translation (simple-array (unsigned-byte 29) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag) @@ -1109,6 +1126,27 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-60 + :translation (simple-array (unsigned-byte 60) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 60))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-63 + :translation (simple-array (unsigned-byte 63) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 63))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-64 + :translation (simple-array (unsigned-byte 64) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 64))) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) :codes (#.sb!vm:simple-array-signed-byte-8-widetag) @@ -1121,6 +1159,7 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) :codes (#.sb!vm:simple-array-signed-byte-30-widetag) @@ -1133,6 +1172,20 @@ :direct-superclasses (vector simple-array) :inherits (vector simple-array array sequence) :prototype-form (make-array 0 :element-type '(signed-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-61 + :translation (simple-array (signed-byte 61) (*)) + :codes (#.sb!vm:simple-array-signed-byte-61-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 61))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-64 + :translation (simple-array (signed-byte 64) (*)) + :codes (#.sb!vm:simple-array-signed-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 64))) (simple-array-single-float :translation (simple-array single-float (*)) :codes (#.sb!vm:simple-array-single-float-widetag) @@ -1205,6 +1258,21 @@ :inherits (base-string simple-string string vector simple-array array sequence) :prototype-form (make-array 0 :element-type 'base-char)) + #!+sb-unicode + (character-string + :translation (vector character) + :codes (#.sb!vm:complex-character-string-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'character :fill-pointer t)) + #!+sb-unicode + (simple-character-string + :translation (simple-array character (*)) + :codes (#.sb!vm:simple-character-string-widetag) + :direct-superclasses (character-string simple-string) + :inherits (character-string simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'character)) (list :translation (or cons (member nil)) :inherits (sequence)) @@ -1218,12 +1286,18 @@ :inherits (symbol list sequence) :direct-superclasses (symbol list) :prototype-form 'nil) - (stream :state :read-only :depth 3 - :inherits (instance) - :prototype-form (make-broadcast-stream))))) + :inherits (instance)) + (file-stream + :state :read-only + :depth 5 + :inherits (stream)) + (string-stream + :state :read-only + :depth 5 + :inherits (stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the ;;; translations for built-in types. @@ -1276,7 +1350,8 @@ (find-and-init-or-check-layout name 0 inherits-vector - depthoid) + depthoid + 0) :invalidate nil))))) (/show0 "done with loop over *BUILT-IN-CLASSES*")) @@ -1320,7 +1395,7 @@ (classoid-layout (find-classoid x))) inherits-list))) #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) - (register-layout (find-and-init-or-check-layout name 0 inherits -1) + (register-layout (find-and-init-or-check-layout name 0 inherits -1 0) :invalidate nil)))) (/show0 "done defining temporary STANDARD-CLASSes")) @@ -1380,11 +1455,6 @@ name layout)))))) -;;; a vector that maps type codes to layouts, used for quickly finding -;;; the layouts of built-in classes -(defvar *built-in-class-codes*) ; initialized in cold load -(declaim (type simple-vector *built-in-class-codes*)) - (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq *built-in-class-codes*