Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl ctor.lisp,1.14,1.14.2.1 dfun.lisp,1.34,1.34.6.1 slots-boot.lisp,1.22,1.22.10.1 slots.lisp,1.20,1.20.4.1 std-class.lisp,1.70,1.70.4.1 vector.lisp,1.33,1.33.2.1
|
From: Christophe R. <cr...@us...> - 2005-01-03 15:49:47
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12494/src/pcl Modified Files: Tag: clos-typechecking-branch ctor.lisp dfun.lisp slots-boot.lisp slots.lisp std-class.lisp vector.lisp Log Message: 0.8.18.11.clos-typechecking.1: Initial checkin of typechecking code in PCL. There are still some cases #+niled out in the clos-typechecking.impure.lisp test file which fail, for reasons moderately unknown; No sanity-checking is done on the types at defclass type; this is particularly bad for compound function types; My recollection is a bit hazy but I think I only implemented typechecking in those cases where there wouldn't be a full call to typep at runtime. This should be checked (as well as other performance implications). Ideally untyped slots would have no performance impact at all. Teaching the compiler to infer types might be tricky, because of the natural dynamicity of CLOS. Index: ctor.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/ctor.lisp,v retrieving revision 1.14 retrieving revision 1.14.2.1 diff -u -d -r1.14 -r1.14.2.1 --- ctor.lisp 31 Dec 2004 12:30:13 -0000 1.14 +++ ctor.lisp 3 Jan 2005 15:49:33 -0000 1.14.2.1 @@ -493,14 +493,14 @@ ((integerp location) (not (null (aref slot-vector location)))) (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) + (class-init (location kind val type) (aver (consp location)) (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) + (push (list location kind val type) class-inits))) + (instance-init (location kind val type) (aver (integerp location)) (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) + (setf (aref slot-vector location) (list kind val type)))) (default-init-var-name (i) (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) @@ -509,16 +509,12 @@ ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as kind = (if (constantp value) 'constant 'param) + as locations = (initarg-locations key) + do (loop for (location . type) in locations + do (if (consp location) + (class-init location kind value type) + (instance-init location kind value type)))) ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied @@ -527,27 +523,28 @@ ;; if not actually used for initializing a slot. (loop for (key initfn initform) in default-initargs and i from 0 unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (ecase type + (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind (constant (push key defaulting-initargs) (push initform defaulting-initargs)) (var (push key defaulting-initargs) (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) + (when (eq kind 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (loop for (location . type) in (initarg-locations key) + do (if (consp location) + (class-init location kind init type) + (instance-init location kind init type))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) as location = (slot-definition-location slotd) + as type = (slot-definition-type slotd) as allocation = (slot-definition-allocation slotd) as initfn = (slot-definition-initfunction slotd) as initform = (slot-definition-initform slotd) do @@ -555,45 +552,57 @@ (null initfn) (initializedp location)) (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + (instance-init location 'initform initform type) + (instance-init location 'initform/initfn initfn type)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type + as (kind value type) = slot-entry collect + (ecase kind ((nil) (unless before-method-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ,value)))) (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type (funcall ,value))))) (initform/initfn (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) + (locally (declare (optimize (safety 3))) + (the ,type (funcall ,value))))) `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) + (locally (declare (optimize (safety 3))) + (the ,type (funcall ,value)))))) (initform (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - ',(eval value))) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value))))) `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value)))))) (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) + `(setf (clos-slots-ref .slots. ,i) + (locally (declare (optimize (safety 3))) + (the ,type ',(eval value)))))))) (class-init-forms - (loop for (location type value) in class-inits collect + (loop for (location kind value type) in class-inits collect `(setf (cdr ',location) - ,(ecase type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value))))))) + (locally (declare (optimize (safety 3))) + (the ,type + ,(ecase kind + (constant `',(eval value)) + ((param var) `,value) + (initfn `(funcall ,value))))))))) (multiple-value-bind (vars bindings) (loop for (var . initfn) in (nreverse default-inits) collect var into vars @@ -603,15 +612,18 @@ `(,@(delete nil instance-init-forms) ,@class-init-forms))))))) -;;; Return an alist of lists (KEY LOCATION ...) telling, for each -;;; key in INITKEYS, which locations the initarg initializes. -;;; CLASS is the class of the instance being initialized. +;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...) +;;; telling, for each key in INITKEYS, which locations the initarg +;;; initializes and the associated type with the location. CLASS is +;;; the class of the instance being initialized. (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) for key in initkeys collect (loop for slot in slots if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations + collect (cons (slot-definition-location slot) + (slot-definition-type slot)) + into locations else collect slot into remaining-slots finally Index: dfun.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v retrieving revision 1.34 retrieving revision 1.34.6.1 diff -u -d -r1.34 -r1.34.6.1 --- dfun.lisp 19 Sep 2004 09:32:27 -0000 1.34 +++ dfun.lisp 3 Jan 2005 15:49:33 -0000 1.34.6.1 @@ -906,7 +906,11 @@ (if (consp method) (eq *the-class-standard-writer-method* (early-method-class method)) - (standard-writer-method-p method))) + (and + (standard-writer-method-p method) + (eq (slot-definition-type + (accessor-method-slot-definition method)) + t)))) methods) 'writer)))) @@ -1282,7 +1286,9 @@ (find-slot-definition accessor-class slot-name))))) (when (and slotd (or early-p - (slot-accessor-std-p slotd accessor-type))) + (slot-accessor-std-p slotd accessor-type)) + (or early-p + (eq (slot-definition-type slotd) t))) (values (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)) Index: slots-boot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v retrieving revision 1.22 retrieving revision 1.22.10.1 diff -u -d -r1.22 -r1.22.10.1 --- slots-boot.lisp 12 Jul 2004 19:34:04 -0000 1.22 +++ slots-boot.lisp 3 Jan 2005 15:49:33 -0000 1.22.10.1 @@ -236,28 +236,51 @@ (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location) (declare #.*optimize-speed*) - (set-fun-name - (etypecase location - (fixnum (if fsc-p + (let ((type (or (not slotd) (slot-definition-type slotd)))) + (set-fun-name + (etypecase location + (fixnum (if fsc-p + (if (eq type t) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv))) + (if (eq type t) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv))))) + (cons (if (eq type t) (lambda (nv instance) (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - location) - nv)) + (setf (cdr location) nv)) (lambda (nv instance) (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) - location) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr location) nv))) - (null - (lambda (nv instance) - (declare (ignore nv)) - (instance-structure-protocol-error slotd - '(setf slot-value-using-class))))) - `(writer ,slot-name))) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (cdr location) nv)))) + (null + (lambda (nv instance) + (declare (ignore nv)) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class))))) + `(writer ,slot-name)))) (defun make-optimized-std-boundp-method-function (fsc-p slotd slot-name location) @@ -385,24 +408,51 @@ (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) - (let ((location (slot-definition-location slotd))) + (let ((location (slot-definition-location slotd)) + (type (slot-definition-type slotd))) (etypecase location (fixnum (if fsc-p - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) location) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) location) - nv)))) - (cons (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (cdr location) nv))) + (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + ;; FIXME: this is going to make a mockery of the + ;; "optimized" bit. Full call to typep on every slot + ;; write? Still, let's see if it works... + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv))) + (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv))))) + (cons (if (eq type t) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (cdr location) nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (unless (typep nv type) + (error 'type-error :datum nv :expected-type type)) + (setf (cdr location) nv)))) (null (lambda (nv class instance slotd) (declare (ignore nv class instance)) (instance-structure-protocol-error @@ -499,15 +549,32 @@ (defun make-std-writer-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) + (type (or (not (eq *boot-state* 'complete)) + (let ((slotd (find-slot-definition (find-class class-name) slot-name))) + (or (not slotd) (slot-definition-type slotd))))) + ;; FIXME: how expensive is this? + (typecheckfun (lambda (nv) (unless (typep nv type) + (error 'type-error + :datum nv :expected-type type)))) (initargs (copy-tree - (make-method-function - (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 1 nv - (setf (slot-value instance slot-name) nv)))))))) + (if (eq type t) + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv))))) + (make-method-function + (lambda (nv instance) + (funcall typecheckfun nv) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv))))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list nil (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) Index: slots.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v retrieving revision 1.20 retrieving revision 1.20.4.1 diff -u -d -r1.20 -r1.20.4.1 --- slots.lisp 19 Nov 2004 15:13:53 -0000 1.20 +++ slots.lisp 3 Jan 2005 15:49:33 -0000 1.20.4.1 @@ -179,22 +179,30 @@ (object std-object) (slotd standard-effective-slot-definition)) (check-obsolete-instance object) - (let ((location (slot-definition-location slotd))) - (typecase location - (fixnum - (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) - (cons - (setf (cdr location) new-value)) - (t - (instance-structure-protocol-error slotd - '(setf slot-value-using-class)))))) + (let ((location (slot-definition-location slotd)) + (type (slot-definition-type slotd))) + (flet ((check (new-value type) + (cond + ((eq type t) new-value) + (t (if (typep new-value type) + new-value + (error 'type-error + :datum new-value :expected-type type)))))) + (typecase location + (fixnum + (cond ((std-instance-p object) + (setf (clos-slots-ref (std-instance-slots object) location) + (check new-value type))) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + (check new-value type))) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) + (cons + (setf (cdr location) (check new-value type))) + (t + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defmethod slot-boundp-using-class ((class std-class) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.70 retrieving revision 1.70.4.1 diff -u -d -r1.70 -r1.70.4.1 --- std-class.lisp 19 Nov 2004 16:29:06 -0000 1.70 +++ std-class.lisp 3 Jan 2005 15:49:33 -0000 1.70.4.1 @@ -1184,9 +1184,10 @@ (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) -;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT -;;; part of the standard protocol. They are however useful, PCL makes -;;; use of them internally and documents them for PCL users. +;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION +;;; function are NOT part of the standard protocol. They are however +;;; useful; PCL makes use of them internally and documents them for +;;; PCL users. (FIXME: but SBCL certainly doesn't) ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor Index: vector.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v retrieving revision 1.33 retrieving revision 1.33.2.1 diff -u -d -r1.33 -r1.33.2.1 --- vector.lisp 31 Dec 2004 15:53:51 -0000 1.33 +++ vector.lisp 3 Jan 2005 15:49:33 -0000 1.33.2.1 @@ -655,10 +655,10 @@ (eq *boot-state* 'complete) (not (slot-accessor-std-p slotd type))))) -(defmacro instance-read-internal (pv slots pv-offset default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type :default) +(defmacro instance-read-internal (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind)) + (if (eq kind :default) default (let* ((index (gensym)) (value index)) @@ -676,11 +676,11 @@ ;; to shut it up. (see also mail Rudi ;; Schlatte sbcl-devel 2003-09-21) -- CSR, ;; 2003-11-30 - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots ; KLUDGE (clos-slots-ref ,slots ,index))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) (if (eq ,value +slot-unbound+) @@ -703,21 +703,26 @@ :instance)) (defmacro instance-write-internal (pv slots pv-offset new-value default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type :default) + &optional kind (type t)) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots (setf (clos-slots-ref ,slots ,index) - ,new-value))))) - ,@(when (or (null type) (eq type :class)) - `((cons (setf (cdr ,index) ,new-value)))) + (locally + (declare (optimize (safety 3))) + (the ,type ,new-value))))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (setf (cdr ,index) + (locally + (declare (optimize (safety 3))) + (the ,type ,new-value)))))) (t ,default))))))) (defmacro instance-write (pv-offset @@ -732,7 +737,16 @@ ,pv-offset ,new-value (accessor-set-slot-value ,parameter ,slot-name ,new-value) ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + :class :instance) + ,(if (and (eq *boot-state* 'complete) + (constantp class) + (constantp slot-name) + (standard-class-p (eval class)) + (not (eq (eval class) *the-class-t*))) + (let ((slotd (find-slot-definition (eval class) (eval slot-name)))) + (or (not slotd) + (slot-definition-type slotd))) + t)))) (defmacro instance-writer (pv-offset parameter @@ -751,20 +765,20 @@ :instance)) (defmacro instance-boundp-internal (pv slots pv-offset default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (not (and ,slots (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) |