X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=5ae92bef8b04e86932b4645539e8b845ed408e33;hb=9627f5a03e642fa950e1557fef17c506dfd386a6;hp=d93c0825b6e274aba736cbdb38efd0b042dac705;hpb=fd63d6aad4a5a3b171eafb56b1b6bd502e501281;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index d93c082..5ae92be 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -123,10 +123,15 @@ (t (values nil t)))) ;;; And similarly for LIST*. -(define-source-transform list* (&rest args) - (case (length args) - (2 `(cons ,(first args) ,(second args))) - (t (values nil t)))) +(define-source-transform list* (arg &rest others) + (cond ((not others) arg) + ((not (cdr others)) `(cons ,arg ,(car others))) + (t (values nil t)))) + +(defoptimizer (list* derive-type) ((arg &rest args)) + (if args + (specifier-type 'cons) + (lvar-type arg))) ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) @@ -142,10 +147,25 @@ (define-source-transform nth (n l) `(car (nthcdr ,n ,l))) -(define-source-transform last (x) `(sb!impl::last1 ,x)) +(deftransform last ((list &optional n) (t &optional t)) + (let ((c (constant-lvar-p n))) + (cond ((or (not n) + (and c (eql 1 (lvar-value n)))) + '(%last1 list)) + ((and c (eql 0 (lvar-value n))) + '(%last0 list)) + (t + (let ((type (lvar-type n))) + (cond ((csubtypep type (specifier-type 'fixnum)) + '(%lastn/fixnum list n)) + ((csubtypep type (specifier-type 'bignum)) + '(%lastn/bignum list n)) + (t + (give-up-ir1-transform "second argument type too vague")))))))) + (define-source-transform gethash (&rest args) (case (length args) - (2 `(sb!impl::gethash2 ,@args)) + (2 `(sb!impl::gethash3 ,@args nil)) (3 `(sb!impl::gethash3 ,@args)) (t (values nil t)))) (define-source-transform get (&rest args) @@ -511,15 +531,13 @@ ;;; 1] and Y = [1, 2] to determine intersection. (defun interval-intersect-p (x y &optional closed-intervals-p) (declare (type interval x y)) - (multiple-value-bind (intersect diff) - (interval-intersection/difference (if closed-intervals-p - (interval-closure x) - x) - (if closed-intervals-p - (interval-closure y) - y)) - (declare (ignore diff)) - intersect)) + (and (interval-intersection/difference (if closed-intervals-p + (interval-closure x) + x) + (if closed-intervals-p + (interval-closure y) + y)) + t)) ;;; Are the two intervals adjacent? That is, is there a number ;;; between the two intervals that is not an element of either @@ -563,27 +581,44 @@ (if (listp p) (first p) (list p))) - (test-number (p int) + (test-number (p int bound) ;; Test whether P is in the interval. - (when (interval-contains-p (type-bound-number p) - (interval-closure int)) - (let ((lo (interval-low int)) - (hi (interval-high int))) + (let ((pn (type-bound-number p))) + (when (interval-contains-p pn (interval-closure int)) ;; Check for endpoints. - (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) - (not (and (consp p) (numberp lo)))) - ((and hi (= (type-bound-number p) (type-bound-number hi))) - (not (and (numberp p) (consp hi)))) - (t t))))) + (let* ((lo (interval-low int)) + (hi (interval-high int)) + (lon (type-bound-number lo)) + (hin (type-bound-number hi))) + (cond + ;; Interval may be a point. + ((and lon hin (= lon hin pn)) + (and (numberp p) (numberp lo) (numberp hi))) + ;; Point matches the low end. + ;; [P] [P,?} => TRUE [P] (P,?} => FALSE + ;; (P [P,?} => TRUE P) [P,?} => FALSE + ;; (P (P,?} => TRUE P) (P,?} => FALSE + ((and lon (= pn lon)) + (or (and (numberp p) (numberp lo)) + (and (consp p) (eq :low bound)))) + ;; [P] {?,P] => TRUE [P] {?,P) => FALSE + ;; P) {?,P] => TRUE (P {?,P] => FALSE + ;; P) {?,P) => TRUE (P {?,P) => FALSE + ((and hin (= pn hin)) + (or (and (numberp p) (numberp hi)) + (and (consp p) (eq :high bound)))) + ;; Not an endpoint, all is well. + (t + t)))))) (test-lower-bound (p int) ;; P is a lower bound of an interval. (if p - (test-number p int) + (test-number p int :low) (not (interval-bounded-p int 'below)))) (test-upper-bound (p int) ;; P is an upper bound of an interval. (if p - (test-number p int) + (test-number p int :high) (not (interval-bounded-p int 'above))))) (let ((x-lo-in-y (test-lower-bound x-lo y)) (x-hi-in-y (test-upper-bound x-hi y)) @@ -687,8 +722,9 @@ ;; Multiply by closed zero is special. The result ;; is always a closed bound. But don't replace this ;; with zero; we want the multiplication to produce - ;; the correct signed zero, if needed. - (* (type-bound-number x) (type-bound-number y))) + ;; the correct signed zero, if needed. Use SIGNUM + ;; to avoid trying to multiply huge bignums with 0.0. + (* (signum (type-bound-number x)) (signum (type-bound-number y)))) ((or (and (floatp x) (float-infinity-p x)) (and (floatp y) (float-infinity-p y))) ;; Infinity times anything is infinity @@ -816,6 +852,24 @@ (>= (type-bound-number (interval-low x)) (type-bound-number (interval-high y))))) +;;; Return T if X = Y. +(defun interval-= (x y) + (declare (type interval x y)) + (and (interval-bounded-p x 'both) + (interval-bounded-p y 'both) + (flet ((bound (v) + (if (numberp v) + v + ;; Open intervals cannot be = + (return-from interval-= nil)))) + ;; Both intervals refer to the same point + (= (bound (interval-high x)) (bound (interval-low x)) + (bound (interval-high y)) (bound (interval-low y)))))) + +;;; Return T if X /= Y +(defun interval-/= (x y) + (not (interval-intersect-p x y))) + ;;; Return an interval that is the absolute value of X. Thus, if ;;; X = [-1 10], the result is [0, 10]. (defun interval-abs (x) @@ -891,11 +945,13 @@ (if (member-type-p arg) ;; Run down the list of members and convert to a list of ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) + (mapc-member-type-members + (lambda (member) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + arg) (push arg new-args))) (unless (member *empty-type* new-args) new-args))))) @@ -1054,25 +1110,23 @@ ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. (defun make-canonical-union-type (type-list) - (let ((members '()) + (let ((xset (alloc-xset)) + (fp-zeroes '()) (misc-types '())) (dolist (type type-list) - (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) - #!+long-float - (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) - (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (cond ((member-type-p type) + (mapc-member-type-members + (lambda (member) + (if (fp-zero-p member) + (unless (member member fp-zeroes) + (pushnew member fp-zeroes)) + (add-to-xset member xset))) + type)) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -2782,19 +2836,20 @@ ;;; ;;; and similar for other arguments. -(defun make-modular-fun-type-deriver (prototype class width) +(defun make-modular-fun-type-deriver (prototype kind width signedp) + (declare (ignore kind)) #!-sb-fluid (binding* ((info (info :function :info prototype) :exit-if-null) (fun (fun-info-derive-type info) :exit-if-null) (mask-type (specifier-type - (ecase class - (:unsigned (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) (lambda (call) (let ((res (funcall fun call))) (when res - (if (eq class :unsigned) + (if (eq signedp nil) (logand-derive-type-aux res mask-type)))))) #!+sb-fluid (lambda (call) @@ -2802,11 +2857,11 @@ (fun (fun-info-derive-type info) :exit-if-null) (res (funcall fun call) :exit-if-null) (mask-type (specifier-type - (ecase class - (:unsigned (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - (:signed `(signed-byte ,width)))))) - (if (eq class :unsigned) + (ecase signedp + ((nil) (let ((mask (1- (ash 1 width)))) + `(integer ,mask ,mask))) + ((t) `(signed-byte ,width)))))) + (if (eq signedp nil) (logand-derive-type-aux res mask-type))))) ;;; Try to recursively cut all uses of LVAR to WIDTH bits. @@ -2821,12 +2876,13 @@ ;;; modular version, if it exists, or NIL. If we have changed ;;; anything, we need to flush old derived types, because they have ;;; nothing in common with the new code. -(defun cut-to-width (lvar class width) +(defun cut-to-width (lvar kind width signedp) (declare (type lvar lvar) (type (integer 0) width)) (let ((type (specifier-type (if (zerop width) '(eql 0) - `(,(ecase class (:unsigned 'unsigned-byte) - (:signed 'signed-byte)) + `(,(ecase signedp + ((nil) 'unsigned-byte) + ((t) 'signed-byte)) ,width))))) (labels ((reoptimize-node (node name) (setf (node-derived-type node) @@ -2842,7 +2898,7 @@ (eq (basic-combination-kind node) :known)) (let* ((fun-ref (lvar-use (combination-fun node))) (fun-name (leaf-source-name (ref-leaf fun-ref))) - (modular-fun (find-modular-version fun-name class width))) + (modular-fun (find-modular-version fun-name kind signedp width))) (when (and modular-fun (not (and (eq fun-name 'logand) (csubtypep @@ -2875,6 +2931,30 @@ did-something)) (cut-lvar lvar)))) +(defun best-modular-version (width signedp) + ;; 1. exact width-matched :untagged + ;; 2. >/>= width-matched :tagged + ;; 3. >/>= width-matched :untagged + (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*)) + (uswidths (modular-class-widths *untagged-signed-modular-class*)) + (uwidths (merge 'list uuwidths uswidths #'< :key #'car)) + (twidths (modular-class-widths *tagged-modular-class*))) + (let ((exact (find (cons width signedp) uwidths :test #'equal))) + (when exact + (return-from best-modular-version (values width :untagged signedp)))) + (flet ((inexact-match (w) + (cond + ((eq signedp (cdr w)) (<= width (car w))) + ((eq signedp nil) (< width (car w)))))) + (let ((tgt (find-if #'inexact-match twidths))) + (when tgt + (return-from best-modular-version + (values (car tgt) :tagged (cdr tgt))))) + (let ((ugt (find-if #'inexact-match uwidths))) + (when ugt + (return-from best-modular-version + (values (car ugt) :untagged (cdr ugt)))))))) + (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) (when (numeric-type-p result-type) @@ -2884,13 +2964,14 @@ (numberp high) (>= low 0)) (let ((width (integer-length high))) - (when (some (lambda (x) (<= width x)) - (modular-class-widths *unsigned-modular-class*)) - ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x :unsigned width) - (cut-to-width y :unsigned width) - nil ; After fixing above, replace with T. - ))))))) + (multiple-value-bind (w kind signedp) + (best-modular-version width nil) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). + (cut-to-width x kind width signedp) + (cut-to-width y kind width signedp) + nil ; After fixing above, replace with T. + )))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) (let ((result-type (single-value-type (node-derived-type node)))) @@ -2899,12 +2980,13 @@ (high (numeric-type-high result-type))) (when (and (numberp low) (numberp high)) (let ((width (max (integer-length high) (integer-length low)))) - (when (some (lambda (x) (<= width x)) - (modular-class-widths *signed-modular-class*)) - ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). - (cut-to-width x :signed width) - nil ; After fixing above, replace with T. - ))))))) + (multiple-value-bind (w kind) + (best-modular-version width t) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). + (cut-to-width x kind width t) + nil ; After fixing above, replace with T. + )))))))) ;;; miscellanous numeric transforms @@ -3281,6 +3363,10 @@ (def eq) (def char=)) +;;; True if EQL comparisons involving type can be simplified to EQ. +(defun eq-comparable-type-p (type) + (csubtypep type (specifier-type '(or fixnum (not number))))) + ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also ;;; try to convert to a type-specific predicate or EQ: ;;; -- If both args are characters, convert to CHAR=. This is better than @@ -3301,9 +3387,7 @@ (let ((x-type (lvar-type x)) (y-type (lvar-type y)) (char-type (specifier-type 'character))) - (flet ((simple-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - (fixnum-type-p (type) + (flet ((fixnum-type-p (type) (csubtypep type (specifier-type 'fixnum)))) (cond ((same-leaf-ref-p x y) t) @@ -3314,7 +3398,7 @@ '(char= x y)) ((or (fixnum-type-p x-type) (fixnum-type-p y-type)) (commutative-arg-swap node)) - ((or (simple-type-p x-type) (simple-type-p y-type)) + ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type)) '(eq x y)) ((and (not (constant-lvar-p y)) (or (constant-lvar-p x) @@ -3353,41 +3437,48 @@ ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. -(deftransform = ((x y) * *) +(deftransform = ((x y) (number number) *) "open code" (let ((x-type (lvar-type x)) (y-type (lvar-type y))) - (if (and (csubtypep x-type (specifier-type 'number)) - (csubtypep y-type (specifier-type 'number))) - (cond ((or (and (csubtypep x-type (specifier-type 'float)) - (csubtypep y-type (specifier-type 'float))) - (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) - ;; They are both floats. Leave as = so that -0.0 is - ;; handled correctly. - (give-up-ir1-transform)) - ((or (and (csubtypep x-type (specifier-type 'rational)) - (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type - (specifier-type '(complex rational))) - (csubtypep y-type - (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. - ;; Convert to EQL. - '(eql x y)) - (t - (give-up-ir1-transform - "The operands might not be the same type."))) - (give-up-ir1-transform - "The operands might not be the same type.")))) - -;;; If LVAR's type is a numeric type, then return the type, otherwise -;;; GIVE-UP-IR1-TRANSFORM. -(defun numeric-type-or-lose (lvar) - (declare (type lvar lvar)) - (let ((res (lvar-type lvar))) - (unless (numeric-type-p res) (give-up-ir1-transform)) - res)) + (cond ((or (and (csubtypep x-type (specifier-type 'float)) + (csubtypep y-type (specifier-type 'float))) + (and (csubtypep x-type (specifier-type '(complex float))) + (csubtypep y-type (specifier-type '(complex float))))) + ;; They are both floats. Leave as = so that -0.0 is + ;; handled correctly. + (give-up-ir1-transform)) + ((or (and (csubtypep x-type (specifier-type 'rational)) + (csubtypep y-type (specifier-type 'rational))) + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. + '(eql x y)) + (t + (give-up-ir1-transform + "The operands might not be the same type."))))) + +(defun maybe-float-lvar-p (lvar) + (neq *empty-type* (type-intersection (specifier-type 'float) + (lvar-type lvar)))) + +(flet ((maybe-invert (node op inverted x y) + ;; Don't invert if either argument can be a float (NaNs) + (cond + ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) + (delay-ir1-transform node :constraint) + `(or (,op x y) (= x y))) + (t + `(if (,inverted x y) nil t))))) + (deftransform >= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '> '< x y)) + (deftransform <= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '< '> x y))) ;;; See whether we can statically determine (< X Y) using type ;;; information. If X's high bound is < Y's low, then X < Y. @@ -3395,7 +3486,14 @@ ;;; NIL). If not, at least make sure any constant arg is second. (macrolet ((def (name inverse reflexive-p surely-true surely-false) `(deftransform ,name ((x y)) - (if (same-leaf-ref-p x y) + "optimize using intervals" + (if (and (same-leaf-ref-p x y) + ;; For non-reflexive functions we don't need + ;; to worry about NaNs: (non-ref-op NaN NaN) => false, + ;; but with reflexive ones we don't know... + ,@(when reflexive-p + '((and (not (maybe-float-lvar-p x)) + (not (maybe-float-lvar-p y)))))) ,reflexive-p (let ((ix (or (type-approximate-interval (lvar-type x)) (give-up-ir1-transform))) @@ -3410,6 +3508,8 @@ `(,',inverse y x)) (t (give-up-ir1-transform)))))))) + (def = = t (interval-= ix iy) (interval-/= ix iy)) + (def /= /= nil (interval-/= ix iy) (interval-= ix iy)) (def < > nil (interval-< ix iy) (interval->= ix iy)) (def > < nil (interval-< iy ix) (interval->= iy ix)) (def <= >= t (interval->= iy ix) (interval-< iy ix)) @@ -3448,15 +3548,16 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean t) *) multi-compare)) -(defun multi-compare (predicate args not-p type) +(defun multi-compare (predicate args not-p type &optional force-two-arg-p) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) + (if force-two-arg-p + `(,predicate ,(first args) ,(second args)) + (values nil t)))) (t (do* ((i (1- nargs) (1- i)) (last nil current) @@ -3474,8 +3575,13 @@ (define-source-transform = (&rest args) (multi-compare '= args nil 'number)) (define-source-transform < (&rest args) (multi-compare '< args nil 'real)) (define-source-transform > (&rest args) (multi-compare '> args nil 'real)) -(define-source-transform <= (&rest args) (multi-compare '> args t 'real)) -(define-source-transform >= (&rest args) (multi-compare '< args t 'real)) +;;; We cannot do the inversion for >= and <= here, since both +;;; (< NaN X) and (> NaN X) +;;; are false, and we don't have type-inforation available yet. The +;;; deftransforms for two-argument versions of >= and <= takes care of +;;; the inversion to > and < when possible. +(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real)) +(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real)) (define-source-transform char= (&rest args) (multi-compare 'char= args nil 'character)) @@ -3489,15 +3595,15 @@ 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 @@ -3726,7 +3832,6 @@ #+sb-xc-host ; Only we should be using these (progn (def style-warn) - (def compiler-abort) (def compiler-error) (def compiler-warn) (def compiler-style-warn) @@ -3833,17 +3938,16 @@ ;; we're prepared to handle which is basically something ;; that array-element-type can return. (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) + (eql 1 (member-type-size cons-type)) (null (first (member-type-members cons-type)))) (let ((car-type (cons-type-car-type cons-type))) (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) + (eql 1 (member-type-members car-type)) + (let ((elt (first (member-type-members car-type)))) + (or (symbolp elt) + (numberp elt) + (and (listp elt) + (numberp (first elt))))) (good-cons-type-p (cons-type-cdr-type cons-type)))))) (unconsify-type (good-cons-type) ;; Convert the "printed" respresentation of a cons @@ -3894,10 +3998,15 @@ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just ;; double-float. (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) + (block punt + (let (members) + (mapc-member-type-members + (lambda (member) + (if (coerceable-p member) + (push member members) + (return-from punt *universal-type*))) + type) + (specifier-type `(or ,@members))))) ((and (cons-type-p type) (good-cons-type-p type)) (let ((c-type (unconsify-type (type-specifier type)))) @@ -4072,7 +4181,4 @@ (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))