From c705f0cb8b1eaf60edf0066ba08406b3e7503af9 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Thu, 4 Jan 2001 05:49:10 +0000 Subject: [PATCH] o Rework the 'ash derive-type optimizer so better handle large negative bounds. Based on suggestions from Raymond Toy. --- compiler/srctran.lisp | 121 +++++++++++++++++++++++++++--------------- 1 file changed, 77 insertions(+), 44 deletions(-) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index e4ea72390..e2c472711 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.103 2000/09/26 15:13:31 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.104 2001/01/04 05:49:10 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1484,58 +1484,91 @@ ) ;end progn +;;; 'ash derive type optimizer. +;;; +;;; Large resulting bounds are easy to generate but are not particularly +;;; useful, so an open outer bound is returned for a shift greater than 64 - +;;; the largest word size of any of the ports. Large negative shifts are also +;;; problematic as the 'ash implementation only accepts shifts greater than +;;; the most-negative-fixnum. These issues are handled by two local functions: +;;; +;;; ash-outer: performs the shift when within an acceptable range, otherwise +;;; returns an open bound. +;;; +;;; ash-inner: performs the shift when within range, limited to a maximum of +;;; 64, otherwise returns the inner limit. +;;; #-propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) - (or (let ((n-type (continuation-type n))) - (when (numeric-type-p n-type) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type))) - (if (constant-continuation-p shift) - (let ((shift (continuation-value shift))) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low (ash n-low shift)) - :high (when n-high (ash n-high shift)))) - (let ((s-type (continuation-type shift))) - (when (numeric-type-p s-type) - (let ((s-low (numeric-type-low s-type)) - (s-high (numeric-type-high s-type))) - (if (and s-low s-high (<= s-low 64) (<= s-high 64)) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (min (ash n-low s-high) - (ash n-low s-low))) - :high (when n-high - (max (ash n-high s-high) - (ash n-high s-low)))) - (make-numeric-type :class 'integer - :complexp :real))))))))) - *universal-type*)) - + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s most-negative-fixnum)) + (ash n s))) + (ash-inner (n s) + (if (and (fixnump s) + (> s most-negative-fixnum)) + (ash n (min s 64)) + (if (minusp n) -1 0)))) + (or (let ((n-type (continuation-type n))) + (when (numeric-type-p n-type) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type))) + (if (constant-continuation-p shift) + (let ((shift (continuation-value shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low (ash n-low shift)) + :high (when n-high (ash n-high shift)))) + (let ((s-type (continuation-type shift))) + (when (numeric-type-p s-type) + (let ((s-low (numeric-type-low s-type)) + (s-high (numeric-type-high s-type))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low))) + :high (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high))))))))))) + *universal-type*))) +;;; #+propagate-fun-type (defun ash-derive-type-aux (n-type shift same-arg) (declare (ignore same-arg)) - (or (and (csubtypep n-type (specifier-type 'integer)) - (csubtypep shift (specifier-type 'integer)) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type)) - (s-low (numeric-type-low shift)) - (s-high (numeric-type-high shift))) - (if (and s-low s-high (<= s-low 64) (<= s-high 64)) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (min (ash n-low s-high) - (ash n-low s-low))) - :high (when n-high - (max (ash n-high s-high) - (ash n-high s-low)))) - (make-numeric-type :class 'integer - :complexp :real)))) - *universal-type*)) - + (flet ((ash-outer (n s) + (when (and (fixnump s) + (<= s 64) + (> s most-negative-fixnum)) + (ash n s))) + (ash-inner (n s) + (if (and (fixnump s) + (> s most-negative-fixnum)) + (ash n (min s 64)) + (if (minusp n) -1 0)))) + (or (and (csubtypep n-type (specifier-type 'integer)) + (csubtypep shift (specifier-type 'integer)) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type)) + (s-low (numeric-type-low shift)) + (s-high (numeric-type-high shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low))) + :high (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high)))))) + *universal-type*))) +;;; #+propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) + #-propagate-float-type (macrolet ((frob (fun) `#'(lambda (type type2) -- GitLab