X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=d3bfe865c1684cc29a8dc76f81c76fd4e23bc7b1;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=40998b113903dc8a2b05ea97dabc0dbb8add50e8;hpb=6c765578c8dc4bcc7798e37c9918715f198b30da;p=sbcl.git

diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
index 40998b1..d3bfe86 100644
--- a/src/compiler/policy.lisp
+++ b/src/compiler/policy.lisp
@@ -12,7 +12,7 @@
 (in-package "SB!C")
 
 ;;; a value for an optimization declaration
-(def!type policy-quality () '(rational 0 3))
+(def!type policy-quality () '(integer 0 3))
 
 ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
 ;;; the state of optimization policy at any point in compilation. This
@@ -22,12 +22,20 @@
 ;;; alists instead.
 (def!type policy () 'list)
 
+(defstruct policy-dependent-quality
+  name
+  expression
+  getter
+  values-documentation)
+
 ;;; names of recognized optimization policy qualities
 (defvar *policy-qualities*) ; (initialized at cold init)
+(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs
 
-;;; Is X the name of an optimization quality?
+;;; Is X the name of an optimization policy quality?
 (defun policy-quality-name-p (x)
-  (memq x *policy-qualities*))
+  (or (memq x *policy-qualities*)
+      (assq x *policy-dependent-qualities*)))
 
 ;;; *POLICY* holds the current global compiler policy information, as
 ;;; an alist mapping from optimization quality name to quality value.
@@ -59,10 +67,15 @@
 	  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.
+		  ;; 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*)))
+		*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).
@@ -71,48 +84,46 @@
 ;;; Look up a named optimization quality in POLICY. This is only
 ;;; 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.
-;;;
-;;; FIXME: After this is debugged, it should get a DEFKNOWN.
-#+nil (declaim (ftype (function (policy symbol) policy-quality)))
 (defun policy-quality (policy quality-name)
-  (let ((acons (assoc quality-name policy)))
-    (unless acons
-      (error "Argh! no such optimization quality ~S in~%  ~S"
-	     quality-name policy))
-    (let ((result (cdr acons)))
-      (unless (typep result '(rational 0 3))
-	(error "Argh! bogus optimization quality ~S" acons))
-      result)))
-
-;;; Return a list of symbols naming the optimization qualities which
-;;; appear in EXPR.
-(defun policy-qualities-used-by (expr)
-  (let ((result nil))
-    (labels ((recurse (x)
-	       (if (listp x)
-		   (map nil #'recurse x)
-		   (when (policy-quality-name-p x)
-		     (pushnew x result)))))
-      (recurse expr)
-      result)))
+  (aver (policy-quality-name-p quality-name))
+  (let* ((acons (assoc quality-name policy))
+         (result (or (cdr acons) 1)))
+    result))
 
 ;;; syntactic sugar for querying optimization policy qualities
 ;;;
-;;; Evaluate EXPR in terms of the current optimization policy for
-;;; NODE, or if NODE is NIL, in terms of the current policy as defined
-;;; by *POLICY*. (Using NODE=NIL is only well-defined during
-;;; IR1 conversion.)
-;;;
-;;; EXPR is a form which accesses the policy values by referring to
-;;; them by name, e.g. (> SPEED SPACE).
-(defmacro policy (node expr)
-  (let* ((n-policy (gensym))
-	 (used-qualities (policy-qualities-used-by expr))
+;;; Evaluate EXPR in terms of the optimization policy associated with
+;;; THING. EXPR is a form which accesses optimization qualities by
+;;; 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)))
-			used-qualities)))
-    `(let* ((,n-policy (lexenv-policy ,(if node
-					   `(node-lexenv ,node)
-					   '*lexenv*)))
-	    ,@binds)
+			*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)))
+
+;;; Dependent qualities
+(defmacro define-optimization-quality
+    (name expression &optional documentation)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (let ((acons (assoc ',name *policy-dependent-qualities*))
+           (item (make-policy-dependent-quality
+                  :name ',name
+                  :expression ',expression
+                  :getter (lambda (policy) (policy policy ,expression))
+                  :values-documentation ',documentation)))
+       (if acons
+           (setf (cdr acons) item)
+           (push `(,',name . ,item) *policy-dependent-qualities*)))
+     ',name))