From c789d1ffc22f28a09e4b7bded6e11e5af83eeede Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 23 Dec 2011 11:37:54 +0100 Subject: [PATCH] When safety level is above 2, calls to fdefinition and access to global variables is compiled even if the value is discarded. This is done for the side effect of checking whether the function or the variable is bound. --- src/cmp/cmploc.lsp | 24 ++++++++++++++++++------ src/cmp/cmppolicy.lsp | 4 ++-- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 072d77767..cb4460a6b 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -234,10 +234,22 @@ (wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; cl_env_copy->nvalues=1;")))) -(defun set-trash-loc (loc) - (cond ((uses-values loc) (wt-nl "(void)" loc ";")) - ((and (consp loc) - (eq (first loc) 'C-INLINE) - (fifth loc)) ; side effects? - (wt-nl loc ";")))) +(defun loc-with-side-effects-p (loc &aux name) + (cond ((var-p loc) + (and (global-var-p loc) + (policy-global-var-checking))) + ((atom loc) + nil) + ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) + :test #'eq) + t) + ((eq name 'FDEFINITION) + (policy-global-function-checking)) + ((eq name 'C-INLINE) + (or (eq (sixth loc) 'VALUES) ;; Uses VALUES + (fifth loc))))) ;; or side effects +(defun set-trash-loc (loc) + (when (loc-with-side-effects-p loc) + (wt-nl loc ";") + t)) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp index 5e771e3f3..599f6ccef 100644 --- a/src/cmp/cmppolicy.lsp +++ b/src/cmp/cmppolicy.lsp @@ -257,10 +257,10 @@ (define-policy array-bounds-check :on safety 1 "Check out of bounds access to arrays") -(define-policy global-var-checking :alias assume-no-errors +(define-policy global-var-checking :on safety 3 "Read the value of a global variable even if it is discarded, ensuring it is bound") -(define-policy global-function-checking :alias assume-no-errors +(define-policy global-function-checking :on safety 3 "Read the binding of a global function even if it is discarded") (define-policy check-nargs :on safety 1 :only-on ext:check-arguments-type 1