From 66be5edfba534a117ea16be4679a6dc266f4a283 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gustavo=20Henrique=20Milar=C3=A9?= Date: Mon, 20 Feb 2012 01:54:49 -0200 Subject: Add support for (optimize sb-ext:type-check-clos-slots) declaration. lp#485718 --- package-data-list.lisp-expr | 2 +- src/code/cross-misc.lisp | 3 +++ src/compiler/policy.lisp | 4 +++- src/pcl/compiler-support.lisp | 6 ++++++ src/pcl/ctor.lisp | 2 +- src/pcl/defclass.lisp | 2 +- src/pcl/fixup.lisp | 3 ++- src/pcl/slots.lisp | 2 +- src/pcl/vector.lisp | 4 ++-- tests/clos-typechecking.impure.lisp | 2 +- 10 files changed, 21 insertions(+), 9 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 09532f1..1347d89 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -718,7 +718,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; extended declarations.. "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS" - "MAYBE-INLINE" + "MAYBE-INLINE" "TYPE-CHECK-CLOS-SLOTS" ;; ..and variables to control compiler policy "*INLINE-EXPANSION-LIMIT*" diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 1753e34..07de0a0 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -25,6 +25,9 @@ ;;; may then have to wade through some irrelevant warnings). (declaim (declaration inhibit-warnings)) +;;; TYPE-CHECK-CLOS-SLOTS declarations can also be ignored. +(declaim (declaration type-check-clos-slots)) + ;;; Interrupt control isn't an issue in the cross-compiler: we don't ;;; use address-dependent (and thus GC-dependent) hashes, and we only ;;; have a single thread of control. diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 413e425..3db02c9 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -114,7 +114,9 @@ EXPERIMENTAL INTERFACE: Subject to change." ;; optimization-related notes, which is already mostly the ;; behavior, and should probably become the exact behavior. ;; Perhaps INHIBIT-NOTES? - inhibit-warnings)) + inhibit-warnings + ;; Type-checking for CLOS slots + type-check-clos-slots)) (setf *policy* (sort-policy (mapcar (lambda (name) ;; CMU CL didn't use 1 as the default for diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 846f82a..b0e16aa 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -52,6 +52,12 @@ (policy (lexenv-policy lexenv))) (eql (cdr (assoc 'safety policy)) 3))) +(defun sb-pcl::clos-type-check-p (&optional env) + (let* ((lexenv (or env (make-null-lexenv))) + (policy (lexenv-policy lexenv))) + (or (eql (cdr (assoc 'safety policy)) 3) + (eql (cdr (assoc 'type-check-clos-slots policy)) 3)))) + (define-source-context defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index f73b658..e839bc3 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -353,7 +353,7 @@ ;; compiling a lambda with (MAKE-INSTANCE # ...) in it ;; -- need to make sure we don't recurse there. (or (unless *compiling-optimized-constructor* - (make-instance->constructor-call form (safe-code-p env))) + (make-instance->constructor-call form (clos-type-check-p env))) form)) (defun make-instance->constructor-call (form safe-code-p) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 33bfd0b..23ad425 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -73,7 +73,7 @@ ',*writers-for-this-defclass* ',*slot-names-for-this-defclass* (sb-c:source-location) - ',(safe-code-p env))))) + ',(clos-type-check-p env))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp index d4e0257..6efc4c8 100644 --- a/src/pcl/fixup.lisp +++ b/src/pcl/fixup.lisp @@ -73,7 +73,8 @@ (find c-slot-name (dd-slots dd) :key #'dsd-name)))) (cond (dsd `(setf (,(dsd-accessor-name dsd) object) new-value)) - ((policy node (= safety 3)) + ((policy node (or (= safety 3) + (= type-check-clos-slots 3))) ;; Safe code wants to check the type, and the global ;; accessor won't do that. Also see the comment in the ;; compiler-macro. diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 26a8355..3212228 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -172,7 +172,7 @@ ;; accessor, which won't do typechecking. (SLOT-OBJECT ;; won't have been compiled with SAFETY 3, so SAFE-P will ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION). - (not (safe-code-p env))) + (not (clos-type-check-p env))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 2fa4b85..ade89a3 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -241,7 +241,7 @@ (if sparameter (let ((optimized-form (optimize-instance-access slots :write sparameter - slot-name new-value (safe-code-p env)))) + slot-name new-value (clos-type-check-p env)))) ;; See OPTIMIZE-SLOT-VALUE `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form)) `(accessor-set-slot-value ,@(cdr form))))) @@ -251,7 +251,7 @@ (cond ((parameter-modified-p parameter-name env) ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking, ;; so we need to use SAFE-SET-SLOT-VALUE. - (if (safe-code-p env) + (if (clos-type-check-p env) `(safe-set-slot-value ,@(cdr form))) `(accessor-set-slot-value ,@(cdr form))) (t diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp index a8bc8d4..dc3a68f 100644 --- a/tests/clos-typechecking.impure.lisp +++ b/tests/clos-typechecking.impure.lisp @@ -14,7 +14,7 @@ (shadow 'slot) -(declaim (optimize safety)) +(declaim (optimize sb-ext:type-check-clos-slots)) (defclass foo () ((slot :initarg :slot :type fixnum :accessor slot))) -- 1.7.5.4