X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=0e7a4ebe08e2e58c75d64427a5e5aa1d4e40c4e5;hb=3ea6f2688adf11331a7a9c243f77a602785d1e1b;hp=3402be1b8b752f90e6cae00074ebcfbeb70b9458;hpb=2c02791374610c991b56439b7c277b770b5311a3;p=sbcl.git

diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
index 3402be1..0e7a4eb 100644
--- a/src/compiler/policy.lisp
+++ b/src/compiler/policy.lisp
@@ -22,17 +22,15 @@
 ;;; alists instead.
 (def!type policy () 'list)
 
-(eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute)
-  (defstruct policy-dependent-quality
-    name
-    expression
-    getter
-    values-documentation))
+(defstruct policy-dependent-quality
+  name
+  expression
+  getter
+  values-documentation)
 
 ;;; names of recognized optimization policy qualities
 (defvar *policy-qualities*) ; (initialized at cold init)
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *policy-dependent-qualities* nil)) ; alist of POLICY-DEPENDENT-QUALITYs
+(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs
 
 ;;; Is X the name of an optimization policy quality?
 (defun policy-quality-name-p (x)
@@ -44,7 +42,7 @@
 ;;; Inside the scope of declarations, new entries are added at the
 ;;; head of the alist.
 (declaim (type policy *policy*))
-(defvar *policy*)	   ; initialized in cold init
+(defvar *policy*)          ; initialized in cold init
 
 ;;; This is to be called early in cold init to set things up, and may
 ;;; also be called again later in cold init in order to reset default
@@ -52,27 +50,32 @@
 ;;; OPTIMIZE forms have messed with it.
 (defun !policy-cold-init-or-resanify ()
   (setf *policy-qualities*
-	'(;; ANSI standard qualities
-	  compilation-speed
-	  debug
-	  safety
-	  space
-	  speed
-	  ;; SBCL extensions
-	  ;;
-	  ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
-	  ;; Perhaps BREVITY would be better. But the ideal name would
-	  ;; have connotations of suppressing not warnings but only
-	  ;; optimization-related notes, which is already mostly the
-	  ;; behavior, and should probably become the exact behavior.
-	  ;; Perhaps INHIBIT-NOTES?
-	  inhibit-warnings))
+        '(;; ANSI standard qualities
+          compilation-speed
+          debug
+          safety
+          space
+          speed
+          ;; SBCL extensions
+          ;;
+          ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
+          ;; Perhaps BREVITY would be better. But the ideal name would
+          ;; have connotations of suppressing not warnings but only
+          ;; optimization-related notes, which is already mostly the
+          ;; behavior, and should probably become the exact behavior.
+          ;; Perhaps INHIBIT-NOTES?
+          inhibit-warnings))
   (setf *policy*
-	(mapcar (lambda (name)
-		  ;; CMU CL didn't use 1 as the default for everything,
-		  ;; but since ANSI says 1 is the ordinary value, we do.
-		  (cons name 1))
-		*policy-qualities*)))
+        (mapcar (lambda (name)
+                  ;; CMU CL didn't use 1 as the default for
+                  ;; everything, but since ANSI says 1 is the ordinary
+                  ;; value, we do.
+                  (cons name 1))
+                *policy-qualities*))
+  ;; not actually POLICY, but very similar
+  (setf *handled-conditions* nil
+        *disabled-package-locks* nil))
+
 ;;; On the cross-compilation host, we initialize immediately (not
 ;;; waiting for "cold init", since cold init doesn't exist on
 ;;; cross-compilation host).
@@ -82,6 +85,7 @@
 ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
 ;;; it's an error if it's called for a quality which isn't defined.
 (defun policy-quality (policy quality-name)
+  (aver (policy-quality-name-p quality-name))
   (let* ((acons (assoc quality-name policy))
          (result (or (cdr acons) 1)))
     result))
@@ -93,21 +97,20 @@
 ;;; referring to them by name, e.g. (> SPEED SPACE).
 (defmacro policy (thing expr)
   (let* ((n-policy (gensym "N-POLICY-"))
-	 (binds (mapcar (lambda (name)
-			  `(,name (policy-quality ,n-policy ',name)))
-			*policy-qualities*))
+         (binds (mapcar (lambda (name)
+                          `(,name (policy-quality ,n-policy ',name)))
+                        *policy-qualities*))
          (dependent-binds
           (loop for (name . info) in *policy-dependent-qualities*
-               collect `(,name (policy-quality ,n-policy ',name))
-               collect `(,name (if (= ,name 1)
-                                   ,(policy-dependent-quality-expression info)
-                                   ,name)))))
-    `(let* ((,n-policy (%coerce-to-policy ,thing))
-	    ,@binds
-            ,@dependent-binds)
-       (declare (ignorable ,@*policy-qualities*
-                           ,@(mapcar #'car *policy-dependent-qualities*)))
-       ,expr)))
+               collect `(,name (let ((,name (policy-quality ,n-policy ',name)))
+                                 (if (= ,name 1)
+                                     ,(policy-dependent-quality-expression info)
+                                     ,name))))))
+    `(let* ((,n-policy (%coerce-to-policy ,thing)))
+       (declare (ignorable ,n-policy))
+       (symbol-macrolet (,@binds
+                         ,@dependent-binds)
+         ,expr))))
 
 ;;; Dependent qualities
 (defmacro define-optimization-quality
@@ -121,6 +124,6 @@
                   :values-documentation ',documentation)))
        (if acons
            (setf (cdr acons) item)
-           (push `(,',name . ,item) *policy-dependent-qualities*)))
+           (setf *policy-dependent-qualities*
+                 (nconc *policy-dependent-qualities* (list `(,',name . ,item))))))
      ',name))
-