X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=bef5b88cc17cc01ebef50745518b1d9f0e59fe2e;hb=2253ebaef8a0a1527d2282a1c10f48c62e0d4a83;hp=9cd204afad82828193d9e48f96b485cfbae0d274;hpb=fa8962d732057015fbb9a2f8a08ea8d5299b50dd;p=sbcl.git diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 9cd204a..bef5b88 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,41 +22,34 @@ ;;; alists instead. (def!type policy () 'list) -;;; names of recognized optimization qualities which don't have -;;; special defaulting behavior -(defvar *policy-basic-qualities*) ; (initialized at cold init) +(defstruct policy-dependent-quality + name + expression + getter + values-documentation) -;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor -;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))). -#| -;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities -;;; which default to other qualities when undefined, e.g. interface -;;; speed defaulting to basic speed -(defvar *policy-defaulting-qualities*) -|# +;;; names of recognized optimization policy qualities +(defvar *policy-qualities*) ; (initialized at cold init) +(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs -(defun optimization-quality-p (name) - (or (member name *policy-basic-qualities*) - ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away. - #|(member name *policy-defaulting-qualities* :key #'car)|#)) +;;; Is X the name of an optimization policy quality? +(defun policy-quality-name-p (x) + (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. ;;; Inside the scope of declarations, new entries are added at the ;;; head of the alist. -;;; -;;; *INTERFACE-POLICY* holds global interface policy, represented the -;;; same way as in *DEFAULT-POLICY*. -(declaim (type policy *policy* *interface-policy*)) +(declaim (type policy *policy*)) (defvar *policy*) ; initialized in cold init -(defvar *interface-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 ;;; optimization policy back to default values after toplevel PROCLAIM ;;; OPTIMIZE forms have messed with it. (defun !policy-cold-init-or-resanify () - (setf *policy-basic-qualities* + (setf *policy-qualities* '(;; ANSI standard qualities compilation-speed debug @@ -72,73 +65,66 @@ ;; behavior, and should probably become the exact behavior. ;; Perhaps INHIBIT-NOTES? inhibit-warnings)) - #| - (setf *policy-defaulting-qualities* - '((interface-speed . speed) - (interface-safety . safety))) - |# (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-basic-qualities*)) - (setf *interface-policy* - *policy*)) + *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). #+sb-xc-host (!policy-cold-init-or-resanify) -;;; Is X the name of an optimization quality? -(defun policy-quality-name-p (x) - (memq x *policy-basic-qualities*)) - ;;; 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) + (setf *policy-dependent-qualities* + (nconc *policy-dependent-qualities* (list `(,',name . ,item)))))) + ',name))