From 92d1290de42d16249bbe473ca3f7cfba448e6586 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 26 Dec 2011 22:59:09 +0100 Subject: [PATCH] Turn CHECKED-VALUE into a special form to speed up a bit processing and also to generate less compiled forms. --- src/cmp/cmpprop.lsp | 7 ++++ src/cmp/cmptables.lsp | 8 +++- src/cmp/cmptype-assert.lsp | 76 +++++++++++++++++++++++--------------- 3 files changed, 60 insertions(+), 31 deletions(-) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 6b032c671..89517fe0c 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -244,6 +244,13 @@ of the occurrences in those lists." do (setf output-type c1form-type) finally (return (values output-type assumptions))))) +(defun p1checked-value (c1form assumptions type value let-form) + (let* ((value-type (p1propagate value assumptions)) + (alt-type (p1propagate let-form assumptions))) + (if (subtypep value-type type) + value-type + type))) + (defun p1progv (c1form assumptions variables values body) (let (type) (multiple-value-setq (type assumptions) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 3b46da477..2253db412 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -63,7 +63,8 @@ :side-effects) (MAKE-FORM vv-loc value-c1form :side-effects) (INIT-FORM vv-loc value-c1form :side-effects) - (EXT:COMPILER-TYPECASE var expressions)))) + (EXT:COMPILER-TYPECASE var expressions) + (CHECKED-VALUE type value-c1form let-form)))) (defconstant +c1-form-hash+ #.(loop with hash = (make-hash-table :size 128 :test #'eq) @@ -114,6 +115,7 @@ (multiple-value-bind . c1multiple-value-bind) ; c1 (ext:compiler-typecase . c1compiler-typecase) ; c1special + (checked-value . c1checked-value) ; c1special (quote . c1quote) ; c1special (function . c1function) ; c1special @@ -247,6 +249,7 @@ (sys:structure-set . c2structure-set) ; c2 (ext:compiler-typecase . c2compiler-typecase) + (checked-value . c2checked-value) )) (defconstant +t2-dispatch-alist+ @@ -295,7 +298,8 @@ (c::with-stack . p1with-stack) (c::stack-push-values . p1stack-push-values) (sys::structure-set . p1structure-set) - (ext:compiler-typecase . p1compiler-typecase) ; c1special + (ext:compiler-typecase . p1compiler-typecase) + (checked-value . p1checked-value) )) (defun make-dispatch-table (alist) diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index e7e41d721..5a90740c6 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -66,13 +66,7 @@ FEwrong_type_argument(#1,#2);" :one-liner nil)))) (defun expand-type-assertion (value type env compulsory) - (cond ((constantp value env) - ;; For constant values, we simply verify the assertion directly - (unless (typep (cmp-eval value env) type) - (cmpwarning "Failed type assertion for value ~A and type ~A" - value type)) - t) - ((or (not (symbolp value)) + (cond ((or (not (symbolp value)) (special-variable-p value) (symbol-macro-p value)) ;; If multiple references to the value cost time and space, @@ -92,33 +86,57 @@ (,type) (t ,(simple-type-assertion value type env)))))) +(defun c1checked-value (args) + (let* ((value (pop args)) + (type (pop args)) + form form-type and-type) + (cond ((or (trivial-type-p args) (not (policy-type-assertions))) + (c1expr value)) + ((and (policy-evaluate-forms) (constantp value)) + (unless (typep (cmp-eval value) type) + (cmpwarning "Failed type assertion for value ~A and type ~A" + value type)) + (c1expr value)) + ;; Is the form type contained in the test? + ((progn + (setf form (c1expr value) + form-type (c1form-primary-type form) + and-type (type-and form-type type)) + (eq and-type form-type)) + form) + ;; Are the form type and the test disjoint types? + ((null and-type) + (cmpwarn "The expression ~S is not of the expected type ~S" + value type) + form) + ;; Otherwise, emit a full test + (t + (cmpnote "Checking type of ~S to be ~S" value type) + (let ((full-check + (with-clean-symbols (%checked-value) + `(let* ((%checked-value ,value)) + (declare (:read-only %checked-value)) + ,(expand-type-assertion '%checked-value type *cmp-env* nil) + %checked-value)))) + (make-c1form* 'CHECKED-VALUE + :type type + :args type form (c1expr full-check))))))) + +(defun c2checked-value (type value let-form) + (c2expr (if (subtypep (c1form-primary-type value) type) + value + let-form))) + (defmacro optional-type-assertion (&whole whole value type &environment env) - "Generates a type check on an expression, ensuring that it is satisfied." + "If safety settings are high enough, generates a type check on an +expression, ensuring that it is satisfied." (when (and (policy-type-assertions env) (not (trivial-type-p type))) - (cmpnote "Checking type ~A for expression~&~A" type value) - (expand-type-assertion value type env nil))) + (cmpnote "Checking type of ~A to be ~A" value type) + `(checked-value ,value ,type))) (defmacro type-assertion (&whole whole value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." - (cmpnote "Checking type ~A for expression~&~A" type value) + (cmpnote "Checking type of ~A to be ~A" value type) (unless (trivial-type-p type) (expand-type-assertion value type env t))) - -(defmacro checked-value (&whole whole value type &environment env) - (cond ((trivial-type-p type) - value) - ((not (policy-type-assertions env)) - `(the ,type ,value)) - ((or (constantp value type) - (and (symbolp value) (local-variable-p value env))) - `(progn - ,(expand-type-assertion value type env nil) - (the ,type ,value))) - (t - (with-clean-symbols (%checked-value) - `(let* ((%checked-value ,value)) - (declare (:read-only %checked-value)) - ,(expand-type-assertion '%checked-value type env nil) - (the ,type %checked-value)))))) -