From 4e46efac3fdacb5fda192d0ca71bd6afdf891be3 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Mon, 12 May 2008 08:16:44 +0000 Subject: [PATCH] Automatically generate type checks for arguments of a lambda form if the safety settings are high enough --- src/CHANGELOG | 4 ++++ src/clos/change.lsp | 5 +++-- src/clos/defclass.lsp | 3 ++- src/clos/method.lsp | 10 +++++----- src/clos/standard.lsp | 1 + src/cmp/cmpdefs.lsp | 3 +++ src/cmp/cmpenv.lsp | 9 +++++---- src/cmp/cmpffi.lsp | 10 ++++++++-- src/cmp/cmplam.lsp | 28 ++++++++++++++++++++++++++-- src/cmp/cmptype.lsp | 13 +++++++++++++ src/lsp/arraylib.lsp | 6 ++++-- src/lsp/pprint.lsp | 19 ------------------- src/lsp/seqlib.lsp | 5 ++++- 13 files changed, 78 insertions(+), 38 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 7b7db0765..07966c345 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -22,6 +22,10 @@ ECL 0.9k: * Visible changes: + - When (>= SAFETY 1), for each compiled function, the compiler will + automatically generate CHECK-TYPE forms to ensure that the arguments have + the values that the user declared. + - The documentation is slowly disappearing form this source tree, as there is a different tree (ecl-doc) which contains the XML sources for a more complete manual. diff --git a/src/clos/change.lsp b/src/clos/change.lsp index d491cfb28..782de4337 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -199,8 +199,9 @@ class) (defun remove-optional-slot-accessors (class) - (declare (si::c-local) - (class class)) + (declare (class class) + (optimize (safety 0)) + (si::c-local)) (let ((class-name (class-name class))) (dolist (slotd (class-slots class)) ;; remove previous defined reader methods diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 8cba04c9d..bb415232d 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -250,7 +250,8 @@ (declare (si::c-local)) (setq path (cons element (reverse (member element (reverse path) :test #'eq)))) (flet ((pretty (class) - (declare (type class class)) + (declare (type class class) + (optimize (safety 0))) (or (class-name class) class))) (let ((explanations ())) (do ((tail path (cdr tail))) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index bee42648c..f3c5a3f19 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -79,11 +79,11 @@ '(&allow-other-keys) (and x (subseq lambda-list x)))))) (let* ((class-declarations - (nconc (mapcan #'(lambda (p s) (and (symbolp s) s - (not (eq s 't)) - `((type ,s ,p)))) - required-parameters - specializers) + (nconc (loop for name in required-parameters + for type in specializers + when (and (not (eq type t)) (symbolp type)) + nconc `((type ,name ,type) + (si::no-check-type ,name))) (cdar declarations))) (method-lambda ;; Remove the documentation string and insert the diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 35fa3e606..8f77ecc77 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -491,6 +491,7 @@ because it contains a reference to the undefined class~% ~A" (defun unbound-slot-error (object index) (declare (type standard-object object) (type fixnum index) + (optimize (safety 0)) (si::c-local)) (let* ((class (class-of object)) (slotd (find index (class-slots class) :key #'slot-definition-location))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index b75be6d41..92c427252 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -297,6 +297,9 @@ The default value is NIL.") (defvar *space* 0) (defvar *debug* 0) +;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms. +(defvar *automatic-check-type-in-lambda* t) + ;;; ;;; Compiled code uses the following kinds of variables: ;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index cd75802fd..76e2f3948 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -331,7 +331,7 @@ (:READ-ONLY (push decl others)) ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL - DYNAMIC-EXTENT IGNORABLE VALUES) + DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE) (push decl others)) (otherwise (if (member decl-name si::*alien-declarations*) @@ -404,7 +404,7 @@ (cmperr "Not a valid function name ~s in declaration ~s" fun decl)))) (DECLARATION (do-declaration (rest decl) #'cmperr)) - ((SI::C-LOCAL SI::C-GLOBAL)) + ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE)) ((DYNAMIC-EXTENT IGNORABLE) ;; FIXME! SOME ARE IGNORED! ) @@ -591,6 +591,7 @@ "Do we assume that arguments are the right type?" (> (cmp-env-optimization 'safety env) 1)) -(defun policy-automatic-type-checks-p (&optional env) +(defun policy-automatic-check-type-p (&optional env) "Do we generate CHECK-TYPE forms for function arguments with type declarations?" - (>= (cmp-env-optimization 'safety env) 1)) + (and *automatic-check-type-in-lambda* + (>= (cmp-env-optimization 'safety env) 1))) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 2ed02ca88..3edd8061c 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -152,7 +152,10 @@ (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) ((:object) (ensure-valid-object-type dest-type) - (wt (if (subtypep (loc-type loc) 'fixnum) "fix(" "ecl_to_fixnum(") + (wt (if (or (subtypep (loc-type loc) 'fixnum) + (not (policy-check-all-arguments-p))) + "fix(" + "ecl_to_fixnum(") loc ")")) (otherwise (coercion-error)))) @@ -163,7 +166,10 @@ (wt "((" (rep-type-name dest-rep-type) ")" loc ")")) ((:object) (ensure-valid-object-type dest-type) - (wt (if (subtypep (loc-type loc) 'fixnum) "fix(" "ecl_to_unsigned_integer(") + (wt (if (or (subtypep (loc-type loc) 'fixnum) + (not (policy-check-all-arguments-p))) + "fix(" + "ecl_to_unsigned_integer(") loc ")")) (otherwise (coercion-error)))) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index a28415a76..42e5e0ca7 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -149,6 +149,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." &aux doc body ss is ts other-decls new-variables + (type-checks '()) (*permanent-data* t) (old-env *cmp-env*) (*cmp-env* (cmp-env-copy))) @@ -168,8 +169,11 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." (do ((specs (setq requireds (cdr requireds)) (cdr specs))) ((endp specs)) - (let* ((name (first specs))) - (push-vars (setf (first specs) (c1make-var name ss is ts))))) + (let* ((name (first specs)) + (var (c1make-var name ss is ts))) + (push var type-checks) + (setf (first specs) var) + (push-vars var))) (do ((specs (setq optionals (cdr optionals)) (cdddr specs))) ((endp specs)) @@ -181,6 +185,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." (and-form-type (var-type var) (c1expr init) init :safe "In (LAMBDA ~a...)" block-name) (default-init var))) + (push var type-checks) (push-vars var) (when flag (push-vars (setq flag (c1make-var flag ss is ts)))) @@ -202,6 +207,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." (and-form-type (var-type var) (c1expr init) init :safe "In (LAMBDA ~a...)" block-name) (default-init var))) + (push var type-checks) (push-vars var) (when flag (push-vars (setq flag (c1make-var flag ss is ts)))) @@ -224,6 +230,24 @@ The function thus belongs to the type of functions that cl_make_cfun accepts." (loop for (var . type) in ts unless (member var new-variable-names) do (push `(type ,type ,var) declarations)) + ;; We generate automatic type checks for function arguments that + ;; are declared These checks can be deactivated by appropriate + ;; safety settings which are checked by OPTIONAL-CHECK-TYPE + ;; + (let* ((type-checks (loop for var in type-checks + unless (or (eq (var-type var) t) + (loop for decl in other-decls + when (and (consp decl) + (eq (first decl) 'si::no-check-type) + (member (var-name var) (rest decl))) + do (return t))) + collect var))) + (when (and type-checks (policy-automatic-check-type-p)) + (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}." + block-name + (mapcar #'var-name type-checks)) + (loop for var in (nreverse type-checks) + do (push `(optional-check-type ,(var-name var) ,(var-type var)) body)))) (setq body (cond (aux-vars (let ((let nil)) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 83201ab6a..e950701c8 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -407,3 +407,16 @@ `(put-sysprop ',fname 'C1TYPE-PROPAGATOR #'(ext:lambda-block ,fname ,lambda-list ,body))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; TYPE CHECKING +;; + +(defmacro optional-check-type (&whole whole var-name type &environment env) + "Generates a type check that is only activated for the appropriate +safety settings and when the type is not trivial." + (unless (policy-automatic-check-type-p env) + (cmpnote "Unable to emit check for variable ~A" whole)) + (when (policy-automatic-check-type-p env) + (unless (subtypep 't type) + `(check-type ,var-name ,type)))) diff --git a/src/lsp/arraylib.lsp b/src/lsp/arraylib.lsp index ee1a61b9f..c656751a7 100644 --- a/src/lsp/arraylib.lsp +++ b/src/lsp/arraylib.lsp @@ -71,7 +71,8 @@ contiguous block." (declare (si::c-local)) (labels ((iterate-over-contents (array contents dims written) (declare (fixnum written) - (array array)) + (array array) + (optimize (safety 0))) (when (/= (length contents) (first dims)) (error "In MAKE-ARRAY: the elements in :INITIAL-CONTENTS do not match the array dimensions")) (if (= (length dims) 1) @@ -285,7 +286,8 @@ pointer is 0 already." (aref vector (the fixnum (1- fp))))) (defun copy-array-contents (dest orig) - (declare (si::c-local)) + (declare (si::c-local) + (optimize (safety 0))) (labels ((do-copy (dest orig dims1 dims2 start1 start2) (declare (array dest orig) diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp index b55b193d7..6c94ad029 100644 --- a/src/lsp/pprint.lsp +++ b/src/lsp/pprint.lsp @@ -358,10 +358,6 @@ (declare (si::c-local) (type string prefix) (type pretty-stream stream)) - #+ecl - (progn - (check-type prefix string) - (check-type suffix string)) (let ((prefix-len (length prefix))) (when (plusp prefix-len) (pretty-sout stream prefix 0 prefix-len)) @@ -932,10 +928,6 @@ (declare (type (member :linear :miser :fill :mandatory) kind) (type (or stream (member t nil)) stream) (values null)) - #+ecl - (progn - (check-type kind (member :linear :miser :fill :mandatory)) - (check-type stream (or stream (member t nil)))) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) @@ -958,11 +950,6 @@ (type real n) (type (or stream (member t nil)) stream) (values null)) - #+ecl - (progn - (check-type relative-to (member :block :current)) - (check-type n real) - (check-type stream (or stream (member t nil)))) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) @@ -987,12 +974,6 @@ (type unsigned-byte colnum colinc) (type (or stream (member t nil)) stream) (values null)) - #+ecl - (progn - (check-type kind (member :line :section :line-relative - :section-relative)) - (check-type colinc unsigned-byte) - (check-type colnum unsigned-byte)) (let ((stream (case stream ((t) *terminal-io*) ((nil) *standard-output*) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index cb7180c98..e06e35f43 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -558,6 +558,7 @@ evaluates to NIL. See STABLE-SORT." (defun list-merge-sort (l predicate key) + (declare (si::c-local)) (unless key (setq key #'identity)) (labels ((sort (l) @@ -613,7 +614,9 @@ evaluates to NIL. See STABLE-SORT." (defun quick-sort (seq start end pred key) - (declare (fixnum start end)) + (declare (fixnum start end) + (optimize (safety 0)) + (si::c-local)) (unless key (setq key #'identity)) (if (<= end (the fixnum (1+ start))) seq