Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv21848/src/compiler

Modified Files:
	fndb.lisp policy.lisp srctran.lisp 
Log Message:
1.0.7.4: RESTRICT-COMPILER-POLICY

 * Allow users to set a global minimum for optimization qualities,
   overriding declarations and proclamations.

   The intended use is to make it easy to recompile large bodies of
   code with many local optimization declarations with a minimum
   SAFETY or DEBUG everywhere.

 * Changes to SBCL itself to allow building with SBCL that has minimum
   safety set to 3:

    -- Second argument of %MORE-KW-ARG is a negative: DEFKNOWN it as a
       FIXNUM, not INDEX.

    -- We don't have a deftype for SB-VM::POSITIVE-FIXNUM -- it's only
       a backend type. Use (AND UNSIGNED-BYTE FIXNUM) instead.

 * Delete some unused functions: READ-SEQUENCE-OR-DIE,
   RENAME-KEY-ARGS.


Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.135
retrieving revision 1.136
diff -u -d -r1.135 -r1.136
--- fndb.lisp	11 Jun 2007 04:23:11 -0000	1.135
+++ fndb.lisp	30 Jun 2007 09:21:26 -0000	1.136
@@ -1401,7 +1401,9 @@
 (defknown %more-arg-context (t t) (values t index) (flushable))
 (defknown %more-arg (t index) t)
 #!+stack-grows-downward-not-upward
-(defknown %more-kw-arg (t index) (values t t))
+;;; FIXME: The second argument here should really be NEGATIVE-INDEX, but doing that
+;;; breaks the build, and I cannot seem to figure out why. --NS 2006-06-29
+(defknown %more-kw-arg (t fixnum) (values t t))
 (defknown %more-arg-values (t index index) * (flushable))
 (defknown %verify-arg-count (index index) (values))
 (defknown %arg-count-error (t) nil)

Index: policy.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policy.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- policy.lisp	13 May 2006 18:33:40 -0000	1.17
+++ policy.lisp	30 Jun 2007 09:21:26 -0000	1.18
@@ -14,6 +14,41 @@
 ;;; a value for an optimization declaration
 (def!type policy-quality () '(integer 0 3))
 
+;;; global policy restrictions
+(defvar *policy-restrictions* nil)
+
+(defun restrict-compiler-policy (&optional quality (min 0))
+  #!+sb-doc
+  "Assing a minimum value to an optimization quality. QUALITY is the name of
+the optimization quality to restrict, and MIN (defaulting to zero) is the
+minimum allowed value.
+
+Returns the alist describing the current policy restrictions.
+
+If QUALITY is NIL or not given, nothing is done.
+
+Otherwise, if MIN is zero or not given, any existing restrictions of QUALITY
+are removed. If MIN is between one and three inclusive, it becomes the new
+minimum value for the optimization quality: any future proclamations or
+declarations of the quality with a value less then MIN behave as if the value
+was MIN instead.
+
+This is intended to be used interactively, to facilitate recompiling large
+bodies of code with eg. a known minimum safety.
+
+EXPERIMENTAL INTERFACE: Subject to change."
+  (declare (policy-quality min))
+  (when quality
+    (aver (policy-quality-name-p quality))
+    (if (zerop min)
+        (setf *policy-restrictions*
+              (remove quality *policy-restrictions* :key #'car))
+        (let ((cell (assoc quality *policy-restrictions*)))
+          (if cell
+              (setf (cdr cell) min)
+              (push (cons quality min) *policy-restrictions*)))))
+  *policy-restrictions*)
+
 ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
 ;;; the state of optimization policy at any point in compilation. This
 ;;; was a natural choice, but in SBCL it became a little troublesome
@@ -72,6 +107,7 @@
                   ;; value, we do.
                   (cons name 1))
                 *policy-qualities*))
+  (setf *policy-restrictions* nil)
   ;; not actually POLICY, but very similar
   (setf *handled-conditions* nil
         *disabled-package-locks* nil))
@@ -86,9 +122,13 @@
 ;;; 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))
+  (%policy-quality policy quality-name))
+
+(defun %policy-quality (policy quality-name)
   (let* ((acons (assoc quality-name policy))
+         (min (or (cdr (assoc quality-name *policy-restrictions*)) 0))
          (result (or (cdr acons) 1)))
-    result))
+    (max result min)))
 
 ;;; syntactic sugar for querying optimization policy qualities
 ;;;

Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.149
retrieving revision 1.150
diff -u -d -r1.149 -r1.150
--- srctran.lisp	2 Jun 2007 10:51:03 -0000	1.149
+++ srctran.lisp	30 Jun 2007 09:21:26 -0000	1.150
@@ -4127,7 +4127,5 @@
   (unless (and (constant-lvar-p quality-name)
                (policy-quality-name-p (lvar-value quality-name)))
     (give-up-ir1-transform))
-  `(let* ((acons (assoc quality-name policy))
-          (result (or (cdr acons) 1)))
-     result))
+  '(%policy-quality policy quality-name))