Replace cmp-env-optimization with compiler policies.

src/cmp/cmparray.lsp

@@ -54,34 +54,37 @@
 ;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND
 ;;;
 
-(defun expand-vector-push (whole env)
+(defun expand-vector-push (whole env extend)
   (declare (si::c-local))
-  (let* ((extend (eq (first whole) 'vector-push-extend))
-	 (args (rest whole)))
-    (unless (or ;; Avoid infinite recursion
-		(eq (first args) '.val)
-		(safe-compile)
-		(>= (cmp-env-optimization 'space env) 2))
-      (setf whole
-	    `(let* ((.val ,(car args))
-		    (.vec ,(second args))
-		    (.i (fill-pointer .vec))
-		    (.dim (array-total-size .vec)))
-	       (declare (fixnum .i .dim)
-			(:read-only .vec .val .i .dim))
-	       (cond ((< .i .dim)
-		      (sys::fill-pointer-set .vec (the fixnum (+ 1 .i)))
-		      (sys::aset .val .vec .i)
-		      .i)
-		     (t ,(when extend
-			       `(vector-push-extend .val .vec ,@(cddr args)))))))))
+  (let* ((args (rest whole)))
+    (with-clean-symbols (value vector index dimension)
+      (unless (or (eq (first args) 'value) ; No infinite recursion
+                  (not (policy-open-code-aref/aset)))
+        (setf whole
+              `(let* ((value ,(car args))
+                      (vector ,(second args)))
+                 (declare (:read-only value vector)
+                          (optimize (safety 0)))
+                 ,@(unless (policy-assume-right-type)
+                     `((check-vectorp vector)))
+                 (let ((index (fill-pointer vector))
+                       (dimension (array-total-size vector)))
+                   (declare (fixnum index dimension)
+                            (:read-only index dimension))
+                   (cond ((< index dimension)
+                          (sys::fill-pointer-set vector (the fixnum (+ 1 index)))
+                          (sys::aset value vector index)
+                          index)
+                         (t ,(if extend
+                               `(vector-push-extend value vector ,@(cddr args))
+                               nil)))))))))
   whole)
 
 (define-compiler-macro vector-push (&whole whole &rest args &environment env)
-  (expand-vector-push whole env))
+  (expand-vector-push whole env nil))
 
 (define-compiler-macro vector-push-extend (&whole whole &rest args &environment env)
-  (expand-vector-push whole env))
+  (expand-vector-push whole env t))
 
 ;;;
 ;;; AREF/ASET

src/cmp/cmpopt.lsp

@@ -46,13 +46,9 @@
   ;; returns the original form. Note that for successful recursion we
   ;; have to output indeed the ORIGINAL FORM, not some intermediate
   ;; step. Otherwise the compiler macro will enter an infinite loop.
-  (let* ((space (cmp-env-optimization 'space env))
-	 (speed (cmp-env-optimization 'speed env))
-	 (safety (cmp-env-optimization 'safety env))
-	 (orig-type type)
+  (let* ((orig-type type)
 	 aux function
 	 first rest)
-    (declare (si::fixnum space speed))
     (cond ((not (and (constantp type) (setf type (cmp-eval type)) t))
 	   form)
 	  ;; Type is not known
@@ -68,7 +64,7 @@
 	  ;; safety, we will simply assume the user knows what she's doing.
 	  ((subtypep type NIL)
 	   (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type)
-	   (if (< safety 1)
+	   (if (policy-assume-no-errors)
 	       NIL
 	       form))
 	  ;;
@@ -97,7 +93,7 @@
 	   (expand-typep form object `',(funcall function) env))
 	  ;;
 	  ;; No optimizations that take up too much space unless requested.
-	  ((and (>= space 2) (> space speed))
+	  ((policy-open-code-type-checks)
 	   form)
 	  ;;
 	  ;; CONS types. They must be checked _before_ sequence types. We
@@ -212,10 +208,7 @@
   ;; returns the original form. Note that for successful recursion we
   ;; have to output indeed the ORIGINAL FORM, not some intermediate
   ;; step. Otherwise the compiler macro will enter an infinite loop.
-  (let* ((space (cmp-env-optimization 'space env))
-	 (speed (cmp-env-optimization 'speed env))
-	 (safety (cmp-env-optimization 'safety env))
-	 (orig-type type)
+  (let* ((orig-type type)
 	 first rest)
     (cond ((not (and (constantp type) (setf type (cmp-eval type))))
 	   form)
@@ -229,7 +222,7 @@
 	   (cmperror "Cannot COERCE an expression to an empty type."))
 	  ;;
 	  ;; No optimizations that take up too much space unless requested.
-	  ((and (>= space 2) (> space speed))
+	  ((policy-open-code-type-checks)
 	   form)
 	  ;;
 	  ;; Search for a simple template above, replacing X by the value.
@@ -298,7 +291,7 @@
 			   DOUBLE-FLOAT #+long-float LONG-FLOAT
 			   #+short-float SHORT-FLOAT))
 	   (let ((unchecked (expand-coerce form value `',first env)))
-	     (if (< safety 1)
+	     (if (policy-assume-no-errors)
 		 unchecked
 		 `(let ((x ,unchecked))
 		    (declare (,first x))

src/cmp/cmppolicy.lsp

@@ -55,13 +55,13 @@
          into expressions
          finally
            (return
-(print
              `(progn
                 (defparameter ,constant-name ,test ,@(and doc (list doc)))
                 (defun ,function-name (&optional (env *cmp-env*))
                   ,@(and doc (list doc))
                   (and ,@expressions))))))))
-)
+
+(define-policy assume-no-errors :off safety 2)
 
 (define-policy assume-right-type :off safety 2)
 
@@ -176,8 +176,9 @@
 (define-policy check-nargs :on safety 1
   "Check that the number of arguments a function receives is within bounds")
 
-(defun policy-check-nargs (&optional (env *cmp-env*))
-  (>= (cmp-env-optimization 'safety) 1))
+(define-policy open-code-type-checks :off space 2
+  "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP,
+INTGERP, STRINGP.")
 
 (defun safe-compile ()
   (>= (cmp-env-optimization 'safety) 2))