Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler aliencomp.lisp, 1.31, 1.32 srctran.lisp, 1.153, 1.154
|
From: Christophe R. <cr...@us...> - 2008-03-07 12:27:21
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19916/src/compiler Modified Files: aliencomp.lisp srctran.lisp Log Message: 1.0.15.16: New modular arithmetic representation decision Prefers any exactly-matching modular implementation, then tagged if possible, then untagged. Should make code of the form (logand xxx most-positive-fixnum) more tolerable. Also includes better lognot/fixnum implementation on all platforms. Squashed commit of the following: commit 81776d9aab531db20711320ecea920453e058cef Author: Christophe Rhodes <cs...@ca...> Date: Fri Mar 7 04:54:03 2008 -0700 Fix lognot for fixnums on alpha. commit 27ce80579851bf9227d7d1121cf1554dc383049d Author: SBCL devs <sbc...@al...> Date: Thu Mar 6 15:02:03 2008 -0700 New modular arithmetic ported to alpha (as yet untested beyond make-genesis-2: lognot/fixnum is buggy) commit d6ae6339374983ae874d85f3c52103c77ccad222 Author: Christophe Rhodes <csr21@localhost.localdomain> Date: Fri Jan 11 17:38:19 2008 +0000 New modular arithmetic ported to mips. Tested by Thiemo Seufer. commit 50e2e51d25bb3d3997e4b884b7a15f7ba1992391 Author: Christophe Rhodes <csr21@localhost.localdomain> Date: Fri Jan 11 17:37:41 2008 +0000 Make find-modular-class get signed and unsigned the right way round. As it happened, this all worked by accident anyway, because the only other user of the *foo-modular-class* specials didn't rely on the separation between the classes, but instead used other data. Hmm... (Noticed by Nikodemus Siivola) commit d3de3d27b212999672644d8a4fccfce9676dbf4f Author: Christophe Rhodes <cs...@ze...> Date: Tue Jan 1 14:25:33 2008 +0000 New modular arithmetic ported to sparc. As with ppc, the signed modular arithmetic is not terribly useful, as only good functions have been implemented (so no +, -, * and ash) commit e99c204ab165139f4c8f8aacb59d4a825b90b7d1 Author: Christophe Rhodes <ma...@gi...> Date: Mon Dec 31 18:15:41 2007 +0000 Fix for fixnum LOGNOT on PPC Use subfic res, x, -4 rather than xori res, x, -4 -- xori's immediate argument is not sign-extended. (Thanks to Andy Hefner for the idea to use subfic rather than xori+xoris) commit db8ffb719750c8bc655519b03c2081cc3b8d0b2e Author: Christophe Rhodes <ma...@gi...> Date: Mon Dec 31 18:13:21 2007 +0000 New modular arithmetic ported to ppc. Simple modifications only. It remains for someone to add signed modular definitions of +, -, * and so on for this to become useful on ppc. commit 5c7562fc1e2a96a81d9bc32fb77ad70ed1794e6e Author: Christophe Rhodes <cr...@gi...> Date: Mon Dec 31 10:12:26 2007 +0000 New modular arithmetic choice for x86-64 Simply adapt x86-64/arith.lisp by * removing logxor implementation (as it's now :good) * adapting %LEA implementation commit 39054fae6e5a2e55856a506ad497978adcbbd6c2 Author: Christophe Rhodes <csr21@omega.localdomain> Date: Sun Dec 30 21:50:16 2007 +0000 Better fixnum LOGNOT implementations. Apparently inherited from cmucl, our fixnum and signed LOGNOT VOPs had generator costs that preferred the signed representation over the tagged. Fix this (on all backends; tested only on x86) commit 6eee19de7a49762ea2f3bbfe89d9ea1b0dcee47f Author: Christophe Rhodes <csr21@omega.localdomain> Date: Sun Dec 30 21:29:39 2007 +0000 Better signed modular arithmetic. All the LOGFOO functions are :good modular functions for signed modular arithmetic. LOGXOR is a :good modular function for untagged unsigned modular arithmetic. commit 32961ecb51bcfea655f985d1f774a8fc46bd155b Author: Christophe Rhodes <csr21@omega.localdomain> Date: Sun Dec 30 19:30:57 2007 +0000 Split untagged modular class into unsigned and signed variants. FIND-MODULAR-VERSION now takes both KIND and SIGNEDP arguments. commit e3b88693c3721cd84d9fb4a01d624d450c120cdd Author: Christophe Rhodes <csr21@omega.localdomain> Date: Sun Dec 30 17:58:49 2007 +0000 Choice of modular version, initial commit Commit of approximately September vintage work, x86-only. Index: aliencomp.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/aliencomp.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- aliencomp.lisp 6 May 2007 17:56:28 -0000 1.31 +++ aliencomp.lisp 7 Mar 2008 12:26:44 -0000 1.32 @@ -527,7 +527,7 @@ (count-low-order-zeros (lvar-uses thing)))) (combination (case (let ((name (lvar-fun-name (combination-fun thing)))) - (or (modular-version-info name :unsigned) name)) + (or (modular-version-info name :untagged nil) name)) ((+ -) (let ((min most-positive-fixnum) (itype (specifier-type 'integer))) @@ -584,7 +584,7 @@ (give-up-ir1-transform)) (let ((inside-fun-name (lvar-fun-name (combination-fun value-node)))) (multiple-value-bind (prototype width) - (modular-version-info inside-fun-name :unsigned) + (modular-version-info inside-fun-name :untagged nil) (unless (eq (or prototype inside-fun-name) 'ash) (give-up-ir1-transform)) (when (and width (not (constant-lvar-p amount))) Index: srctran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v retrieving revision 1.153 retrieving revision 1.154 diff -u -d -r1.153 -r1.154 --- srctran.lisp 3 Mar 2008 01:47:54 -0000 1.153 +++ srctran.lisp 7 Mar 2008 12:26:44 -0000 1.154 @@ -2816,19 +2816,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) @@ -2836,11 +2837,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. @@ -2855,12 +2856,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) @@ -2876,7 +2878,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 @@ -2909,6 +2911,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) @@ -2918,13 +2944,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)))) @@ -2933,12 +2960,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 @@ -4134,4 +4162,3 @@ (policy-quality-name-p (lvar-value quality-name))) (give-up-ir1-transform)) '(%policy-quality policy quality-name)) - |