Turn CHECKED-VALUE into a special form to speed up a bit processing and also to generate less compiled forms.

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)

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)

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))))))
-