From b04a647c2ec6eef53c5385ea40131f8107664bbd Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 9 May 2010 09:59:53 +0200 Subject: [PATCH] Replace cmp-env-optimization with compiler policies. --- src/cmp/cmparray.lsp | 47 +++++++++++++++++++++++-------------------- src/cmp/cmpopt.lsp | 19 ++++++----------- src/cmp/cmppolicy.lsp | 9 +++++---- 3 files changed, 36 insertions(+), 39 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 73f4193c4..d99f2f28b 100644 --- a/src/cmp/cmparray.lsp +++ b/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 diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index eb7cce837..84701389a 100644 --- a/src/cmp/cmpopt.lsp +++ b/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)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 12cdcd90c..6ceff49e0 100644 --- a/src/cmp/cmppolicy.lsp +++ b/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))