From b6aed043108ac99142b124306a346d18a99d21ef Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 30 Jun 2007 09:21:24 +0000 Subject: [PATCH] 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. --- NEWS | 16 +++++++----- package-data-list.lisp-expr | 1 + src/code/bignum.lisp | 2 +- src/code/early-extensions.lisp | 56 +--------------------------------------- src/compiler/fndb.lisp | 4 ++- src/compiler/policy.lisp | 42 +++++++++++++++++++++++++++++- src/compiler/srctran.lisp | 4 +-- version.lisp-expr | 2 +- 8 files changed, 59 insertions(+), 68 deletions(-) diff --git a/NEWS b/NEWS index 40b05d7..afa7fe6 100644 --- a/NEWS +++ b/NEWS @@ -1,11 +1,15 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.8 relative to sbcl-1.0.7: - * enhancement: closed over variables can be stack-allocated on x86 and - x86-64. - * performance bug fix: GETHASH and (SETF GETHASH) are once again non-consing. - * bug fix: backtrace construction is now more careful when - making lisp-objects from pointers on the stack, to avoid creating - bogus objects that can be seen by the GC. + * enhancement: experimental function SB-EXT:RESTRICT-COMPILER-POLICY + allows assining a global minimum value to optimization qualities + (overriding proclamations and declarations). + * enhancement: closed over variables can be stack-allocated on x86 + and x86-64. + * performance bug fix: GETHASH and (SETF GETHASH) are once again + non-consing. + * bug fix: backtrace construction is now more careful when making + lisp-objects from pointers on the stack, to avoid creating bogus + objects that can be seen by the GC. changes in sbcl-1.0.7 relative to sbcl-1.0.6: * MOP improvement: support for user-defined subclasses of diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2e312de..925842f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -654,6 +654,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; ..and inspector of compiler policy "DESCRIBE-COMPILER-POLICY" + "RESTRICT-COMPILER-POLICY" ;; a special form for breaking out of our "declarations ;; are assertions" default diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index 1f4a85c..7f54a05 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -550,7 +550,7 @@ ;;; it, we pay a heavy price in BIGNUM-GCD when compiled by the ;;; cross-compiler. -- CSR, 2004-07-19 (declaim (ftype (sfunction (bignum-type bignum-index bignum-type bignum-index) - sb!vm::positive-fixnum) + (and unsigned-byte fixnum)) bignum-factors-of-two)) (defun bignum-factors-of-two (a len-a b len-b) (declare (type bignum-index len-a len-b) (type bignum-type a b)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 2281678..833adb7 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -934,61 +934,6 @@ (t (error "unknown operator in feature expression: ~S." x))) (not (null (memq x *features*))))) - -;;; Given a list of keyword substitutions `(,OLD ,NEW), and a -;;; &KEY-argument-list-style list of alternating keywords and -;;; arbitrary values, return a new &KEY-argument-list-style list with -;;; all substitutions applied to it. -;;; -;;; Note: If efficiency mattered, we could do less consing. (But if -;;; efficiency mattered, why would we be using &KEY arguments at -;;; all, much less renaming &KEY arguments?) -;;; -;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201 -(defun rename-key-args (rename-list key-args) - (declare (type list rename-list key-args)) - ;; Walk through RENAME-LIST modifying RESULT as per each element in - ;; RENAME-LIST. - (do ((result (copy-list key-args))) ; may be modified below - ((null rename-list) result) - (destructuring-bind (old new) (pop rename-list) - ;; ANSI says &KEY arg names aren't necessarily KEYWORDs. - (declare (type symbol old new)) - ;; Walk through RESULT renaming any OLD key argument to NEW. - (do ((in-result result (cddr in-result))) - ((null in-result)) - (declare (type list in-result)) - (when (eq (car in-result) old) - (setf (car in-result) new)))))) - -;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the -;;; other ANSI input functions, is defined to communicate end of file -;;; status with its return value, not by signalling. That is not the -;;; behavior that we usually want. This function is a wrapper which -;;; restores the behavior that we usually want, causing READ-SEQUENCE -;;; to communicate end-of-file status by signalling. -(defun read-sequence-or-die (sequence stream &key start end) - ;; implementation using READ-SEQUENCE - #-no-ansi-read-sequence - (let ((read-end (read-sequence sequence - stream - :start start - :end end))) - (unless (= read-end end) - (error 'end-of-file :stream stream)) - (values)) - ;; workaround for broken READ-SEQUENCE - #+no-ansi-read-sequence - (progn - (aver (<= start end)) - (let ((etype (stream-element-type stream))) - (cond ((equal etype '(unsigned-byte 8)) - (do ((i start (1+ i))) - ((>= i end) - (values)) - (setf (aref sequence i) - (read-byte stream)))) - (t (error "unsupported element type ~S" etype)))))) ;;;; utilities for two-VALUES predicates @@ -1306,3 +1251,4 @@ to :INTERPRET, an interpreter will be used.") bind)) bindings))) ,@forms))) + diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 071c8e9..7ba684b 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -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) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 0e7a4eb..d0beebe 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -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 ;;; diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 359e2f3..709b1d6 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -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)) diff --git a/version.lisp-expr b/version.lisp-expr index 86f1d87..53ef74f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.7.3" +"1.0.7.4" -- 1.7.10.4