X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpolicy.lisp;h=d4cd154cd4d1c47147b4a26aa22a0649f3e0ec07;hb=4a0ab5193096ca70dbbf43bb21418544f6d018b7;hp=0d880cce4a32e43e32980afdb02c3432f02624e9;hpb=f392742d2781f42b3bb15b637e5008e10fbbe092;p=sbcl.git diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 0d880cc..d4cd154 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -12,50 +12,36 @@ (in-package "SB!C") ;;; a value for an optimization declaration -(def!type policy-quality () '(or (rational 0 3) null)) +(def!type policy-quality () '(rational 0 3)) ;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent ;;; the state of optimization policy at any point in compilation. This -;;; became a little unwieldy, especially because of cold init issues -;;; for structures and structure accessors, so in SBCL we use an alist -;;; instead. +;;; was a natural choice, but in SBCL it became a little troublesome +;;; because of stupid technicalities involving the cold initialization +;;; of structure LAYOUTs and structure accessors, so now we just use +;;; 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) +;;; names of recognized optimization policy qualities +(defvar *policy-qualities*) ; (initialized at cold init) -;;; 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*) -|# - -(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 quality? +(defun policy-quality-name-p (x) + (memq x *policy-qualities*)) -;;; *DEFAULT-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. -;;; -;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an -;;; OPTIMIZE-INTERFACE declaration. -(declaim (type policy *default-policy* *default-interface-policy*)) -(defvar *default-policy*) ; initialized in cold init -(defvar *default-interface-policy*) ; initialized in cold init +;;; *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. +(declaim (type policy *policy*)) +(defvar *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 @@ -71,61 +57,62 @@ ;; behavior, and should probably become the exact behavior. ;; Perhaps INHIBIT-NOTES? inhibit-warnings)) - (setf *policy-defaulting-qualities* - '((interface-speed . speed) - (interface-safety . safety))) - (setf *default-policy* + (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. (cons name 1)) - *policy-basic-qualities*)) - (setf *default-interface-policy* - *default-policy*)) + *policy-qualities*))) ;;; 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-p (x) - (memq x *policy-basic-qualities*)) - -;;; Look up a named optimization quality in POLICY. -(declaim (ftype (function (policy symbol) policy-quality))) +;;; 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) - (the policy-quality - (cdr (assoc quality-name policy)))) + (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. +;;; +;;; FIXME: Doing this is slightly flaky (since we can't do it right +;;; without all the headaches of true code walking), and it shouldn't +;;; be necessary with modern Python anyway, as long as POLICY-QUALITY +;;; is properly DEFKNOWNed to have no side-effects so that it can be +;;; optimized away if unused. So this should probably go away. (defun policy-qualities-used-by (expr) (let ((result nil)) (labels ((recurse (x) (if (listp x) (map nil #'recurse x) - (when (policy-quality-p x) + (when (policy-quality-name-p x) (pushnew x result))))) (recurse expr) 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 *DEFAULT-POLICY* and *CURRENT-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)) +;;; 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-")) + (used-qualities (policy-qualities-used-by expr)) (binds (mapcar (lambda (name) `(,name (policy-quality ,n-policy ',name))) - (policy-qualities-used-by expr)))) - (/show "in POLICY" expr binds) - `(let* ((,n-policy (lexenv-policy ,(if node - `(node-lexenv ,node) - '*lexenv*))) + used-qualities))) + `(let* ((,n-policy (%coerce-to-policy ,thing)) ,@binds) ,expr)))