;;;; -*- 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
;; ..and inspector of compiler policy
"DESCRIBE-COMPILER-POLICY"
+ "RESTRICT-COMPILER-POLICY"
;; a special form for breaking out of our "declarations
;; are assertions" default
;;; 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))
(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))))))
\f
;;;; utilities for two-VALUES predicates
bind))
bindings)))
,@forms)))
+
(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)
;;; 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
;; 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))
;;; 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
;;;
(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))
;;; 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"
projects / sbcl.git / commitdiff