From: Paul Khuong Date: Fri, 7 Jun 2013 23:01:09 +0000 (-0400) Subject: Enable more modular arithmetic X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=54752bdd733ae3127d6dca2cc9a16413bf0126f3;p=sbcl.git Enable more modular arithmetic The rewrites now trigger when the result type for LOGAND or MASK-SIGNED-FIELD is an union of integer types. --- diff --git a/NEWS b/NEWS index 4e08aee..1f805df 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,8 @@ changes relative to sbcl-1.1.8: * optimization: SLEEP doesn't cons on non-immediate floats and on ratios. * optimization: (mod fixnum) type-checks are performed using one unsigned comparison, instead of two. + * optimization: enable more modular arithmetic transforms in the presence of + conditionals. * bug fix: problems with NCONC type derivation (reported by Jerry James). * bug fix: EXPT type derivation no longer constructs bogus floating-point types. (reported by Vsevolod Dyomkin) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 728e741..713a106 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3052,53 +3052,67 @@ (return-from best-modular-version (values (car ugt) :untagged (cdr ugt)))))))) +(defun integer-type-numeric-bounds (type) + (typecase type + (numeric-type (values (numeric-type-low type) + (numeric-type-high type))) + (union-type + (let ((low nil) + (high nil)) + (dolist (type (union-type-types type) (values low high)) + (unless (and (numeric-type-p type) + (eql (numeric-type-class type) 'integer)) + (return (values nil nil))) + (let ((this-low (numeric-type-low type)) + (this-high (numeric-type-high type))) + (setf low (min this-low (or low this-low)) + high (max this-high (or high this-high))))))))) + (defoptimizer (logand optimizer) ((x y) node) (let ((result-type (single-value-type (node-derived-type node)))) - (when (numeric-type-p result-type) - (let ((low (numeric-type-low result-type)) - (high (numeric-type-high result-type))) - (when (and (numberp low) - (numberp high) - (>= low 0)) - (let ((width (integer-length high))) - (multiple-value-bind (w kind signedp) - (best-modular-version width nil) - (when w - ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). - ;; - ;; FIXME: I think the FIXME (which is from APD) above - ;; implies that CUT-TO-WIDTH should do /everything/ - ;; that's required, including reoptimizing things - ;; itself that it knows are necessary. At the moment, - ;; CUT-TO-WIDTH sets up some new calls with - ;; combination-type :FULL, which later get noticed as - ;; known functions and properly converted. - ;; - ;; We cut to W not WIDTH if SIGNEDP is true, because - ;; signed constant replacement needs to know which bit - ;; in the field is the signed bit. - (let ((xact (cut-to-width x kind (if signedp w width) signedp)) - (yact (cut-to-width y kind (if signedp w width) signedp))) - (declare (ignore xact yact)) - nil) ; After fixing above, replace with T, meaning - ; "don't reoptimize this (LOGAND) node any more". - )))))))) + (multiple-value-bind (low high) + (integer-type-numeric-bounds result-type) + (when (and (numberp low) + (numberp high) + (>= low 0)) + (let ((width (integer-length high))) + (multiple-value-bind (w kind signedp) + (best-modular-version width nil) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). + ;; + ;; FIXME: I think the FIXME (which is from APD) above + ;; implies that CUT-TO-WIDTH should do /everything/ + ;; that's required, including reoptimizing things + ;; itself that it knows are necessary. At the moment, + ;; CUT-TO-WIDTH sets up some new calls with + ;; combination-type :FULL, which later get noticed as + ;; known functions and properly converted. + ;; + ;; We cut to W not WIDTH if SIGNEDP is true, because + ;; signed constant replacement needs to know which bit + ;; in the field is the signed bit. + (let ((xact (cut-to-width x kind (if signedp w width) signedp)) + (yact (cut-to-width y kind (if signedp w width) signedp))) + (declare (ignore xact yact)) + nil) ; After fixing above, replace with T, meaning + ; "don't reoptimize this (LOGAND) node any more". + ))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) (let ((result-type (single-value-type (node-derived-type node)))) - (when (numeric-type-p result-type) - (let ((low (numeric-type-low result-type)) - (high (numeric-type-high result-type))) - (when (and (numberp low) (numberp high)) - (let ((width (max (integer-length high) (integer-length low)))) - (multiple-value-bind (w kind) - (best-modular-version (1+ width) t) - (when w - ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T). - ;; [ see comment above in LOGAND optimizer ] - (cut-to-width x kind w t) - nil ; After fixing above, replace with T. - )))))))) + (multiple-value-bind (low high) + (integer-type-numeric-bounds result-type) + (when (and (numberp low) (numberp high)) + (let ((width (max (integer-length high) (integer-length low)))) + (multiple-value-bind (w kind) + (best-modular-version (1+ width) t) + (when w + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T). + ;; [ see comment above in LOGAND optimizer ] + (cut-to-width x kind w t) + nil ; After fixing above, replace with T. + ))))))) ;;; miscellanous numeric transforms