(give-up-ir1-transform
"The function doesn't have a fixed argument count.")))))
\f
+;;;; SYMBOL-VALUE &co
+(defun derive-symbol-value-type (lvar node)
+ (if (constant-lvar-p lvar)
+ (let* ((sym (lvar-value lvar))
+ (var (maybe-find-free-var sym))
+ (local-type (when var
+ (let ((*lexenv* (node-lexenv node)))
+ (lexenv-find var type-restrictions))))
+ (global-type (info :variable :type sym)))
+ (if local-type
+ (type-intersection local-type global-type)
+ global-type))
+ *universal-type*))
+
+(defoptimizer (symbol-value derive-type) ((symbol) node)
+ (derive-symbol-value-type symbol node))
+
+(defoptimizer (symbol-global-value derive-type) ((symbol) node)
+ (derive-symbol-value-type symbol node))
+\f
;;;; list hackery
;;; Translate CxR into CAR/CDR combos.
(t (,op ,x ,y))))
(defmacro bound-binop (op x y)
- `(and ,x ,y
- (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- (set-bound (safely-binop ,op (type-bound-number ,x)
- (type-bound-number ,y))
- (or (consp ,x) (consp ,y))))))
+ (with-unique-names (xb yb res)
+ `(and ,x ,y
+ (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
+ (let* ((,xb (type-bound-number ,x))
+ (,yb (type-bound-number ,y))
+ (,res (safely-binop ,op ,xb ,yb)))
+ (set-bound ,res
+ (and (or (consp ,x) (consp ,y))
+ ;; Open bounds can very easily be messed up
+ ;; by FP rounding, so take care here.
+ ,(case op
+ (*
+ ;; Multiplying a greater-than-zero with
+ ;; less than one can round to zero.
+ `(or (not (fp-zero-p ,res))
+ (cond ((and (consp ,x) (fp-zero-p ,xb))
+ (>= (abs ,yb) 1))
+ ((and (consp ,y) (fp-zero-p ,yb))
+ (>= (abs ,xb) 1)))))
+ (/
+ ;; Dividing a greater-than-zero with
+ ;; greater than one can round to zero.
+ `(or (not (fp-zero-p ,res))
+ (cond ((and (consp ,x) (fp-zero-p ,xb))
+ (<= (abs ,yb) 1))
+ ((and (consp ,y) (fp-zero-p ,yb))
+ (<= (abs ,xb) 1)))))
+ ((+ -)
+ ;; Adding or subtracting greater-than-zero
+ ;; can end up with identity.
+ `(and (not (fp-zero-p ,xb))
+ (not (fp-zero-p ,yb))))))))))))
(defun coerce-for-bound (val type)
(if (consp val)
(define-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
- ,@(mapcar (lambda (x)
- `(values ,x))
- (butlast args))
+ ,@(mapcar (lambda (x) `(values ,x)) (butlast args))
(values-list ,(car (last args))))))
+
+;;; When &REST argument are at play, we also have extra context and count
+;;; arguments -- convert to %VALUES-LIST-OR-CONTEXT when possible, so that the
+;;; deftransform can decide what to do after everything has been converted.
+(define-source-transform values-list (list)
+ (if (symbolp list)
+ (let* ((var (lexenv-find list vars))
+ (info (when (lambda-var-p var)
+ (lambda-var-arg-info var))))
+ (if (and info
+ (eq :rest (arg-info-kind info))
+ (consp (arg-info-default info)))
+ (destructuring-bind (context count &optional used) (arg-info-default info)
+ (declare (ignore used))
+ `(%values-list-or-context ,list ,context ,count))
+ (values nil t)))
+ (values nil t)))
+
+(deftransform %values-list-or-context ((list context count) * * :node node)
+ (let* ((use (lvar-use list))
+ (var (when (ref-p use) (ref-leaf use)))
+ (home (when (lambda-var-p var) (lambda-var-home var)))
+ (info (when (lambda-var-p var) (lambda-var-arg-info var))))
+ (flet ((ref-good-for-more-context-p (ref)
+ (let ((dest (principal-lvar-end (node-lvar ref))))
+ (and (combination-p dest)
+ ;; Uses outside VALUES-LIST will require a &REST list anyways,
+ ;; to it's no use saving effort here -- plus they might modify
+ ;; the list destructively.
+ (eq '%values-list-or-context (lvar-fun-name (combination-fun dest)))
+ ;; If the home lambda is different and isn't DX, it might
+ ;; escape -- in which case using the more context isn't safe.
+ (let ((clambda (node-home-lambda dest)))
+ (or (eq home clambda)
+ (leaf-dynamic-extent clambda)))))))
+ (let ((context-ok
+ (and info
+ (consp (arg-info-default info))
+ (not (lambda-var-specvar var))
+ (not (lambda-var-sets var))
+ (every #'ref-good-for-more-context-p (lambda-var-refs var)))))
+ (cond (context-ok
+ (destructuring-bind (context count &optional used) (arg-info-default info)
+ (declare (ignore used))
+ (setf (arg-info-default info) (list context count t)))
+ `(%more-arg-values context 0 count))
+ (t
+ (when info
+ (setf (arg-info-default info) t))
+ `(values-list list)))))))
+
\f
;;;; transforming FORMAT
;;;;