From 951c8b24023c6f444b903a64b5e00d5cb2ae2ac9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 18 Jul 2003 13:52:37 +0000 Subject: [PATCH] 0.8.1.43: Get SB-MOP:CLASS-PROTOTYPE right in more cases ... new :PROTOTYPE-FORM property in SB-KERNEL:*BUILT-IN-CLASSES* list; ... use it to generate the prototype in SB-PCL::*BUILT-IN-CLASSES*; bonus: since this means we have an instance of almost every built-in-class by SAVE-LISP-AND-DIE time, we can detect longstanding bugs in PURIFY ... make complex bit-vectors and simple-array-nils purifyable. --- NEWS | 4 ++ src/code/class.lisp | 138 +++++++++++++++++++++++++++++++++----------------- src/pcl/defs.lisp | 89 ++++---------------------------- src/runtime/purify.c | 9 ++++ version.lisp-expr | 2 +- 5 files changed, 117 insertions(+), 125 deletions(-) diff --git a/NEWS b/NEWS index 0adda5f..337069c 100644 --- a/NEWS +++ b/NEWS @@ -1920,6 +1920,10 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1: of ARRAY-DIMENSION-LIMIT and ARRAY-TOTAL-SIZE-LIMIT no longer leak into the newly-built SBCL. (reported by Eric Marsden on #lisp, test case from Patrik Nordebo) + * improved the ability of the disassembler on the PPC platform to + provide helpful disassembly notes. + * SB-MOP:CLASS-PROTOTYPE on built-in-classes returns an instance of + the class in more cases than previously. * fixed some bugs revealed by Paul Dietz' test suite: ** LAST and [N]BUTLAST should accept a bignum. ** condition slot accessors are methods. diff --git a/src/code/class.lisp b/src/code/class.lisp index 5ccc7ac..8da8e98 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -928,25 +928,32 @@ (setq *built-in-classes* '((t :state :read-only :translation t) - (character :enumerable t :translation base-char) + (character :enumerable t :translation base-char + :prototype-form (code-char 42)) (base-char :enumerable t :inherits (character) - :codes (#.sb!vm:base-char-widetag)) - (symbol :codes (#.sb!vm:symbol-header-widetag)) + :codes (#.sb!vm:base-char-widetag) + :prototype-form (code-char 42)) + (symbol :codes (#.sb!vm:symbol-header-widetag) + :prototype-form '#:mu) (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-widetag)) - (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)) + (system-area-pointer :codes (#.sb!vm:sap-widetag) + :prototype-form (sb!sys:int-sap 42)) + (weak-pointer :codes (#.sb!vm:weak-pointer-widetag) + :prototype-form (sb!ext:make-weak-pointer (find-package "CL"))) (code-component :codes (#.sb!vm:code-header-widetag)) (lra :codes (#.sb!vm:return-pc-header-widetag)) - (fdefn :codes (#.sb!vm:fdefn-widetag)) + (fdefn :codes (#.sb!vm:fdefn-widetag) + :prototype-form (sb!kernel:make-fdefn "42")) (random-class) ; used for unknown type codes (function :codes (#.sb!vm:closure-header-widetag #.sb!vm:simple-fun-header-widetag) - :state :read-only) + :state :read-only + :prototype-form (function (lambda () 42))) (funcallable-instance :inherits (function) :state :read-only) @@ -955,20 +962,24 @@ (complex :translation complex :inherits (number) - :codes (#.sb!vm:complex-widetag)) + :codes (#.sb!vm:complex-widetag) + :prototype-form (complex 42 42)) (complex-single-float :translation (complex single-float) :inherits (complex number) - :codes (#.sb!vm:complex-single-float-widetag)) + :codes (#.sb!vm:complex-single-float-widetag) + :prototype-form (complex 42f0 42f0)) (complex-double-float :translation (complex double-float) :inherits (complex number) - :codes (#.sb!vm:complex-double-float-widetag)) + :codes (#.sb!vm:complex-double-float-widetag) + :prototype-form (complex 42d0 42d0)) #!+long-float (complex-long-float :translation (complex long-float) :inherits (complex number) - :codes (#.sb!vm:complex-long-float-widetag)) + :codes (#.sb!vm:complex-long-float-widetag) + :prototype-form (complex 42l0 42l0)) (real :translation real :inherits (number)) (float :translation float @@ -976,23 +987,27 @@ (single-float :translation single-float :inherits (float real number) - :codes (#.sb!vm:single-float-widetag)) + :codes (#.sb!vm:single-float-widetag) + :prototype-form 42f0) (double-float :translation double-float :inherits (float real number) - :codes (#.sb!vm:double-float-widetag)) + :codes (#.sb!vm:double-float-widetag) + :prototype-form 42d0) #!+long-float (long-float :translation long-float :inherits (float real number) - :codes (#.sb!vm:long-float-widetag)) + :codes (#.sb!vm:long-float-widetag) + :prototype-form 42l0) (rational :translation rational :inherits (real number)) (ratio :translation (and rational (not integer)) :inherits (rational real number) - :codes (#.sb!vm:ratio-widetag)) + :codes (#.sb!vm:ratio-widetag) + :prototype-form 1/42) (integer :translation integer :inherits (rational real number)) @@ -1000,17 +1015,22 @@ :translation (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) :inherits (integer rational real number) - :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) + :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag) + :prototype-form 42) (bignum :translation (and integer (not fixnum)) :inherits (integer rational real number) - :codes (#.sb!vm:bignum-widetag)) + :codes (#.sb!vm:bignum-widetag) + ;; FIXME: wrong for 64-bit! + :prototype-form (expt 2 42)) (array :translation array :codes (#.sb!vm:complex-array-widetag) - :hierarchical-p nil) + :hierarchical-p nil + :prototype-form (make-array nil :adjustable t)) (simple-array :translation simple-array :codes (#.sb!vm:simple-array-widetag) - :inherits (array)) + :inherits (array) + :prototype-form (make-array nil)) (sequence :translation (or cons (member nil) vector)) (vector @@ -1020,92 +1040,110 @@ (simple-vector :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0)) (bit-vector :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) - :inherits (vector array sequence)) + :inherits (vector array sequence) + :prototype-form (make-array 0 :element-type 'bit :fill-pointer t)) (simple-bit-vector :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array - array sequence)) + array sequence) + :prototype-form (make-array 0 :element-type 'bit)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 2))) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 4))) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 8))) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) :codes (#.sb!vm:simple-array-signed-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 8))) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) :codes (#.sb!vm:simple-array-signed-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 16))) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) :codes (#.sb!vm:simple-array-signed-byte-30-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 30))) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) :codes (#.sb!vm:simple-array-signed-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 32))) (simple-array-single-float :translation (simple-array single-float (*)) :codes (#.sb!vm:simple-array-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'single-float)) (simple-array-double-float :translation (simple-array double-float (*)) :codes (#.sb!vm:simple-array-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'double-float)) #!+long-float (simple-array-long-float :translation (simple-array long-float (*)) :codes (#.sb!vm:simple-array-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'long-float)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) :codes (#.sb!vm:simple-array-complex-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex single-float))) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) :codes (#.sb!vm:simple-array-complex-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex double-float))) #!+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) :codes (#.sb!vm:simple-array-complex-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex long-float))) (string :translation string :direct-superclasses (vector) @@ -1115,43 +1153,50 @@ :direct-superclasses (string simple-array) :inherits (string vector simple-array array sequence)) (vector-nil - ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))? :translation (vector nil) :codes (#.sb!vm:complex-vector-nil-widetag) :direct-superclasses (string) - :inherits (string vector array sequence)) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'nil :fill-pointer t)) (simple-array-nil :translation (simple-array nil (*)) :codes (#.sb!vm:simple-array-nil-widetag) :direct-superclasses (vector-nil simple-string) - :inherits (vector-nil simple-string string vector simple-array array sequence)) + :inherits (vector-nil simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'nil)) (base-string :translation base-string :codes (#.sb!vm:complex-base-string-widetag) :direct-superclasses (string) - :inherits (string vector array sequence)) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t)) (simple-base-string :translation simple-base-string :codes (#.sb!vm:simple-base-string-widetag) :direct-superclasses (base-string simple-string) :inherits (base-string simple-string string vector simple-array - array sequence)) + array sequence) + :prototype-form (make-array 0 :element-type 'base-char)) (list :translation (or cons (member nil)) :inherits (sequence)) (cons :codes (#.sb!vm:list-pointer-lowtag) :translation cons - :inherits (list sequence)) + :inherits (list sequence) + :prototype-form (cons nil nil)) (null :translation (member nil) :inherits (symbol list sequence) - :direct-superclasses (symbol list)) + :direct-superclasses (symbol list) + :prototype-form 'nil) (stream :state :read-only :depth 3 - :inherits (instance))))) + :inherits (instance) + :prototype-form (make-broadcast-stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the ;;; translations for built-in types. @@ -1166,12 +1211,13 @@ enumerable state depth + prototype-form (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) '(t)))) x - (declare (ignore codes state translation)) + (declare (ignore codes state translation prototype-form)) (let ((inherits-list (if (eq name t) () (cons t (reverse inherits)))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 2bdeb05..89177ba 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -302,58 +302,6 @@ ;;;; built-in classes -;;; FIXME: This was the portable PCL way of setting up -;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost -;;; entirely wasted motion, since it's immediately overwritten by a -;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However, -;;; we can't just delete it, since the fifth element from each entry -;;; (a prototype of the class) is still in the final result. It would -;;; be nice to clean this up so that the other, never-used stuff is -;;; gone, perhaps finding a tidier way to represent examples of each -;;; class, too. -;;; -;;; FIXME: This can probably be blown away after bootstrapping. -;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too.. -#| -(defvar *built-in-classes* - ;; name supers subs cdr of cpl - ;; prototype - '(;(t () (number sequence array character symbol) ()) - (number (t) (complex float rational) (t)) - (complex (number) () (number t) - #c(1 1)) - (float (number) () (number t) - 1.0) - (rational (number) (integer ratio) (number t)) - (integer (rational) () (rational number t) - 1) - (ratio (rational) () (rational number t) - 1/2) - - (sequence (t) (list vector) (t)) - (list (sequence) (cons null) (sequence t)) - (cons (list) () (list sequence t) - (nil)) - - (array (t) (vector) (t) - #2A((nil))) - (vector (array - sequence) (string bit-vector) (array sequence t) - #()) - (string (vector) () (vector array sequence t) - "") - (bit-vector (vector) () (vector array sequence t) - #*1) - (character (t) () (t) - #\c) - - (symbol (t) (null) (t) - symbol) - (null (symbol - list) () (symbol list sequence t) - nil))) -|# - ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set ;;; SB-PCL:*BUILT-IN-CLASSES*. (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") @@ -377,34 +325,13 @@ (/noshow sub) (when (member class (direct-supers sub)) (res sub))))) - (res))) - (prototype (class-name) - (let ((assoc (assoc class-name - '((complex . #c(1 1)) - (float . 1.0) - (integer . 1) - (ratio . 1/2) - (sequence . nil) - (list . nil) - (cons . (nil)) - (array . #2a((nil))) - (vector . #()) - (string . "") - (bit-vector . #*1) - (character . #\c) - (symbol . symbol) - (null . nil))))) - (if assoc - (cdr assoc) - ;; This is the default prototype value which was - ;; used, without explanation, by the CMU CL code - ;; we're derived from. Evidently it's safe in all - ;; relevant cases. - 42)))) + (res)))) (mapcar (lambda (kernel-bic-entry) (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) - (class (find-classoid name))) + (class (find-classoid name)) + (prototype-form + (getf (cdr kernel-bic-entry) :prototype-form))) (/noshow name class) `(,name ,(mapcar #'classoid-name (direct-supers class)) @@ -416,7 +343,13 @@ (reverse (layout-inherits (classoid-layout class)))) - ,(prototype name)))) + ,(if prototype-form + (eval prototype-form) + ;; This is the default prototype value which + ;; was used, without explanation, by the CMU CL + ;; code we're derived from. Evidently it's safe + ;; in all relevant cases. + 42)))) (remove-if (lambda (kernel-bic-entry) (member (first kernel-bic-entry) ;; I'm not sure why these are removed from diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 7c04ed9..c4309e2 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -284,6 +284,7 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) #ifdef LONG_FLOAT_WIDETAG case LONG_FLOAT_WIDETAG: #endif + case SIMPLE_ARRAY_NIL_WIDETAG: case SIMPLE_BASE_STRING_WIDETAG: case SIMPLE_BIT_VECTOR_WIDETAG: case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: @@ -924,6 +925,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) case COMPLEX_WIDETAG: case SIMPLE_ARRAY_WIDETAG: case COMPLEX_BASE_STRING_WIDETAG: + case COMPLEX_BIT_VECTOR_WIDETAG: case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_VECTOR_WIDETAG: case COMPLEX_ARRAY_WIDETAG: @@ -936,6 +938,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant) case SYMBOL_HEADER_WIDETAG: return ptrans_boxed(thing, header, 0); + case SIMPLE_ARRAY_NIL_WIDETAG: + return ptrans_vector(thing, 0, 0, 0, constant); + case SIMPLE_BASE_STRING_WIDETAG: return ptrans_vector(thing, 8, 1, 0, constant); @@ -1147,6 +1152,10 @@ pscav(lispobj *addr, int nwords, boolean constant) count = 1; break; + case SIMPLE_ARRAY_NIL_WIDETAG: + count = 2; + break; + case SIMPLE_BASE_STRING_WIDETAG: vector = (struct vector *)addr; count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2); diff --git a/version.lisp-expr b/version.lisp-expr index 6ad7cb7..80bb600 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.1.42" +"0.8.1.43" -- 1.7.10.4