X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=aec88cbbe3511ecbe1eb5bf6119234922449c5ca;hb=4d0b87793a047baecf2403455ddca1a82f44a41b;hp=ed2f97b8e3be47544e43294cc9f8e34b126e9bdc;hpb=ca8135a6852cde2206ce9bdaa9b9d57f3b047f4e;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ed2f97b..aec88cb 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -57,6 +57,26 @@ (give-up-ir1-transform "The function doesn't have a fixed argument count."))))) +;;;; 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)) + ;;;; list hackery ;;; Translate CxR into CAR/CDR combos. @@ -399,11 +419,38 @@ (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) @@ -3754,34 +3801,57 @@ ;;;; versions, and degenerate cases are flushed. ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION. -(declaim (ftype (function (symbol t list) list) associate-args)) -(defun associate-args (function first-arg more-args) +(declaim (ftype (sfunction (symbol t list t) list) associate-args)) +(defun associate-args (fun first-arg more-args identity) (let ((next (rest more-args)) (arg (first more-args))) (if (null next) - `(,function ,first-arg ,arg) - (associate-args function `(,function ,first-arg ,arg) next)))) + `(,fun ,first-arg ,(if arg arg identity)) + (associate-args fun `(,fun ,first-arg ,arg) next identity)))) + +;;; Reduce constants in ARGS list. +(declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants)) +(defun reduce-constants (fun args identity one-arg-result-type) + (let ((one-arg-constant-p (ecase one-arg-result-type + (number #'numberp) + (integer #'integerp))) + (reduced-value identity) + (reduced-p nil)) + (collect ((not-constants)) + (dolist (arg args) + (if (funcall one-arg-constant-p arg) + (setf reduced-value (funcall fun reduced-value arg) + reduced-p t) + (not-constants arg))) + ;; It is tempting to drop constants reduced to identity here, + ;; but if X is SNaN in (* X 1), we cannot drop the 1. + (if (not-constants) + (if reduced-p + `(,reduced-value ,@(not-constants)) + (not-constants)) + `(,reduced-value))))) ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to -;;; ensure (with THE) that the argument in one-argument calls is. +;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE) +;;; that the argument in one-argument calls is. +(declaim (ftype (function (symbol list t &optional symbol list) + (values t &optional (member nil t))) + source-transform-transitive)) (defun source-transform-transitive (fun args identity - &optional one-arg-result-type) - (declare (symbol fun) (list args)) + &optional (one-arg-result-type 'number) + (one-arg-prefixes '(values))) (case (length args) (0 identity) - (1 (if one-arg-result-type - `(values (the ,one-arg-result-type ,(first args))) - `(values ,(first args)))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) (2 (values nil t)) - (t - (associate-args fun (first args) (rest args))))) + (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type))) + (associate-args fun (first reduced-args) (rest reduced-args) identity))))) (define-source-transform + (&rest args) - (source-transform-transitive '+ args 0 'number)) + (source-transform-transitive '+ args 0)) (define-source-transform * (&rest args) - (source-transform-transitive '* args 1 'number)) + (source-transform-transitive '* args 1)) (define-source-transform logior (&rest args) (source-transform-transitive 'logior args 0 'integer)) (define-source-transform logxor (&rest args) @@ -3790,41 +3860,30 @@ (source-transform-transitive 'logand args -1 'integer)) (define-source-transform logeqv (&rest args) (source-transform-transitive 'logeqv args -1 'integer)) - -;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM -;;; because when they are given one argument, they return its absolute -;;; value. - (define-source-transform gcd (&rest args) - (case (length args) - (0 0) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'gcd (first args) (rest args))))) - + (source-transform-transitive 'gcd args 0 'integer '(abs))) (define-source-transform lcm (&rest args) - (case (length args) - (0 1) - (1 `(abs (the integer ,(first args)))) - (2 (values nil t)) - (t (associate-args 'lcm (first args) (rest args))))) + (source-transform-transitive 'lcm args 1 'integer '(abs))) ;;; Do source transformations for intransitive n-arg functions such as ;;; /. With one arg, we form the inverse. With two args we pass. ;;; Otherwise we associate into two-arg calls. -(declaim (ftype (function (symbol list t) +(declaim (ftype (function (symbol symbol list t list &optional symbol) (values list &optional (member nil t))) source-transform-intransitive)) -(defun source-transform-intransitive (function args inverse) +(defun source-transform-intransitive (fun fun* args identity one-arg-prefixes + &optional (one-arg-result-type 'number)) (case (length args) ((0 2) (values nil t)) - (1 `(,@inverse ,(first args))) - (t (associate-args function (first args) (rest args))))) + (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args)))) + (t (let ((reduced-args + (reduce-constants fun* (rest args) identity one-arg-result-type))) + (associate-args fun (first args) reduced-args identity))))) (define-source-transform - (&rest args) - (source-transform-intransitive '- args '(%negate))) + (source-transform-intransitive '- '+ args 0 '(%negate))) (define-source-transform / (&rest args) - (source-transform-intransitive '/ args '(/ 1))) + (source-transform-intransitive '/ '* args 1 '(/ 1))) ;;;; transforming APPLY @@ -3834,10 +3893,59 @@ (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))))))) + ;;;; transforming FORMAT ;;;;