From: Alexey Dejneka Date: Thu, 9 Oct 2003 19:55:08 +0000 (+0000) Subject: 0.8.4.15: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1e9966d5f24709d227e20911b4e1ddd27c87a00e;p=sbcl.git 0.8.4.15: * Change modularization of ASH ... add per-function cutter; ... s/ash-left-constant-modxx/ash-left-modxx/; ... put DEFKNOWN and modular function optimizer for ASH-LEFT-MODxx to src/compiler/generic/sm-tran.lisp; ... compile src/compiler/generic/vm-tran.lisp before src/compiler/target/arith.lisp (in fact, immediately after src/compiler/srctran.lisp); * strength reducer for * wraps LOGAND around the whole form. --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 55a52cf..22b6411 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -474,6 +474,7 @@ ("src/compiler/float-tran") ("src/compiler/saptran") ("src/compiler/srctran") + ("src/compiler/generic/vm-tran") ("src/compiler/locall") ("src/compiler/dfo") ("src/compiler/checkgen") @@ -580,7 +581,6 @@ ("src/compiler/copyprop") ("src/compiler/represent") - ("src/compiler/generic/vm-tran") ("src/compiler/pack") ("src/compiler/codegen") ("src/compiler/debug") diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 838c63b..868d3f6 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -146,8 +146,8 @@ (values array start end 0)) #!-alpha -(defun sb!vm::ash-left-constant-mod32 (integer amount) +(defun sb!vm::ash-left-mod32 (integer amount) (ldb (byte 32 0) (ash integer amount))) #!+alpha -(defun sb!vm::ash-left-constant-mod64 (integer amount) +(defun sb!vm::ash-left-mod64 (integer amount) (ldb (byte 64 0) (ash integer amount))) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index a9987d6..c62f864 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1369,7 +1369,7 @@ collect `(prepare-argument ,arg))))))) (loop for infos being each hash-value of sb!c::*modular-funs* ;; FIXME: We need to process only "toplevel" functions - unless (eq infos :good) + when (listp infos) do (loop for info in infos for name = (sb!c::modular-fun-info-name info) and width = (sb!c::modular-fun-info-width info) @@ -1383,16 +1383,15 @@ ;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more ;;; discussion of this hack. -- CSR, 2003-10-09 #!-alpha -(defun sb!vm::ash-left-constant-mod32 (integer amount) +(defun sb!vm::ash-left-mod32 (integer amount) (etypecase integer ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount))) (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))) (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount))))) #!+alpha -(defun sb!vm::ash-left-constant-mod64 (integer amount) +(defun sb!vm::ash-left-mod64 (integer amount) (etypecase integer ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount))) (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))) - (bignum (ldb (byte 64 0) + (bignum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))))) - diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp index 9eece3c..c6c8552 100644 --- a/src/compiler/alpha/arith.lisp +++ b/src/compiler/alpha/arith.lisp @@ -364,11 +364,9 @@ (:generator 1 (inst not x res))) -(defknown ash-left-constant-mod64 (integer (integer 0)) (unsigned-byte 64) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod64/unsigned=>unsigned +(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod64)) + (:translate ash-left-mod64)) (macrolet ((define-modular-backend (fun &optional constantp) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index e9f6a01..b86d04d 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -152,7 +152,9 @@ ;;; Modular functions -;;; hash: name -> { ({(width . fun)}*) | :good } +;;; For a documentation, see CUT-TO-WIDTH. + +;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)} (defvar *modular-funs* (make-hash-table :test 'eq)) @@ -166,11 +168,11 @@ (defun find-modular-version (fun-name width) (let ((infos (gethash fun-name *modular-funs*))) - (if (eq infos :good) - :good + (if (listp infos) (find-if (lambda (item-width) (>= item-width width)) infos - :key #'modular-fun-info-width)))) + :key #'modular-fun-info-width) + infos))) (defun %define-modular-fun (name lambda-list prototype width) (let* ((infos (the list (gethash prototype *modular-funs*))) @@ -216,3 +218,22 @@ (defmacro define-good-modular-fun (name) (check-type name symbol) `(%define-good-modular-fun ',name)) + +(defmacro define-modular-fun-optimizer + (name ((&rest lambda-list) &key (width (gensym "WIDTH"))) + &body body) + (check-type name symbol) + (dolist (arg lambda-list) + (when (member arg lambda-list-keywords) + (error "Lambda list keyword ~S is not supported for ~ + modular function lambda lists." arg))) + (with-unique-names (call args) + `(setf (gethash ',name *modular-funs*) + (lambda (,call ,width) + (declare (type basic-combination ,call) + (type (integer 0) width)) + (let ((,args (basic-combination-args ,call))) + (when (= (length ,args) ,(length lambda-list)) + (destructuring-bind ,lambda-list ,args + (declare (type lvar ,@lambda-list)) + ,@body))))))) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index f8e7bda..1d93eba 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -439,10 +439,32 @@ (= (double-float-high-bits x) (double-float-high-bits y)))) -;;;; 32-bit operations +;;;; modular functions (define-good-modular-fun logand) (define-good-modular-fun logior) ;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16 + +#!-alpha +(progn + (defknown sb!vm::ash-left-mod32 (integer (integer 0)) (unsigned-byte 32) + (foldable flushable movable)) + (define-modular-fun-optimizer ash ((integer count) :width width) + (when (and (<= width 32) + (constant-lvar-p count) ; ? + (plusp (lvar-value count))) + (cut-to-width integer width) + 'sb!vm::ash-left-mod32))) +#!+alpha +(progn + (defknown sb!vm::ash-left-mod64 (integer (integer 0)) (unsigned-byte 64) + (foldable flushable movable)) + (define-modular-fun-optimizer ash ((integer count) :width width) + (when (and (<= width 64) + (constant-lvar-p count) ; ? + (plusp (lvar-value count))) + (cut-to-width integer width) + 'sb!vm::ash-left-mod64))) + ;;; There are two different ways the multiplier can be recoded. The ;;; more obvious is to shift X by the correct amount for each bit set @@ -456,13 +478,11 @@ (declare (type (unsigned-byte 32) num)) (let ((adds 0) (shifts 0) (result nil) first-one) - (labels ((tub32 (x) `(logand ,x #xffffffff)) ; uses modular arithmetic - (add (next-factor) + (labels ((add (next-factor) (setf result - (tub32 - (if result - (progn (incf adds) `(+ ,result ,(tub32 next-factor))) - next-factor))))) + (if result + (progn (incf adds) `(+ ,result ,next-factor)) + next-factor)))) (declare (inline add)) (dotimes (bitpos 32) (if first-one @@ -474,8 +494,8 @@ (progn (incf adds) (incf shifts 2) - `(- ,(tub32 `(ash ,arg ,bitpos)) - ,(tub32 `(ash ,arg ,first-one)))))) + `(- (ash ,arg ,bitpos) + (ash ,arg ,first-one))))) (setf first-one nil)) (when (logbitp bitpos num) (setf first-one bitpos)))) @@ -485,8 +505,12 @@ (t (incf shifts 2) (incf adds) - (add `(- ,(tub32 `(ash ,arg 31)) - ,(tub32 `(ash ,arg ,first-one)))))) + (add `(- (ash ,arg 31) + (ash ,arg ,first-one))))) (incf shifts) (add `(ash ,arg 31)))) - (values result adds shifts))) + (values (if (plusp adds) + `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic + result) + adds + shifts))) diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp index c09800b..2ca4be0 100644 --- a/src/compiler/hppa/arith.lisp +++ b/src/compiler/hppa/arith.lisp @@ -588,11 +588,9 @@ (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) (:translate --mod32)) -(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod32)) + (:translate ash-left-mod32)) (define-modular-fun lognot-mod32 (x) lognot 32) (define-vop (lognot-mod32/unsigned=>unsigned) diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp index e38cffe..3b6b890 100644 --- a/src/compiler/mips/arith.lisp +++ b/src/compiler/mips/arith.lisp @@ -690,11 +690,9 @@ (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) (:translate --mod32)) -(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod32)) + (:translate ash-left-mod32)) ;;; logical operations (define-modular-fun lognot-mod32 (x) lognot 32) diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp index 8dab1bb..5570dc5 100644 --- a/src/compiler/ppc/arith.lisp +++ b/src/compiler/ppc/arith.lisp @@ -469,11 +469,9 @@ (:generator 1 (inst not res x))) -(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod32)) + (:translate ash-left-mod32)) (macrolet ((define-modular-backend (fun &optional constantp) diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp index 65f35be..412c56f 100644 --- a/src/compiler/sparc/arith.lisp +++ b/src/compiler/sparc/arith.lisp @@ -680,11 +680,9 @@ (define-source-transform lognor (x y) `(lognot (logior ,x ,y))) -(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod32)) + (:translate ash-left-mod32)) ;;;; Binary conditional VOPs: diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 8df9c25..4da5db1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2518,8 +2518,12 @@ ;;; "goodness" means that the result will not increase (in the ;;; (unsigned-byte +infinity) sense). An ordinary modular function is ;;; replaced with the version, cutting its result to WIDTH or more -;;; bits. If we have changed anything, we need to flush old derived -;;; types, because they have nothing in common with the new code. +;;; bits. For most functions (e.g. for +) we cut all arguments; for +;;; others (e.g. for ASH) we have "optimizers", cutting only necessary +;;; arguments (maybe to a different width) and returning the name of a +;;; 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 width) (declare (type lvar lvar) (type (integer 0) width)) (labels ((reoptimize-node (node name) @@ -2536,55 +2540,32 @@ (fun-info-p (basic-combination-kind node))) (let* ((fun-ref (lvar-use (combination-fun node))) (fun-name (leaf-source-name (ref-leaf fun-ref))) - (modular-fun (find-modular-version fun-name width)) - (name (and (modular-fun-info-p modular-fun) - (modular-fun-info-name modular-fun)))) - (cond - ((and modular-fun - (not (and (eq name 'logand) - (csubtypep - (single-value-type (node-derived-type node)) - (specifier-type `(unsigned-byte ,width)))))) - (unless (eq modular-fun :good) - (setq did-something t) - (change-ref-leaf - fun-ref - (find-free-fun name "in a strange place")) - (setf (combination-kind node) :full)) - (dolist (arg (basic-combination-args node)) - (when (cut-lvar arg) - (setq did-something t))) - (when did-something - (reoptimize-node node fun-name)) - did-something) - ;; FIXME: This clause is a workaround for a fairly - ;; critical bug. Prior to this, strength reduction - ;; of constant (unsigned-byte 32) multiplication - ;; achieved modular arithmetic by lying to the - ;; compiler with TRULY-THE. Since we now have an - ;; understanding of modular arithmetic, we can stop - ;; lying to the compiler, at the cost of - ;; uglification of this code. Probably we want to - ;; generalize the modular arithmetic mechanism to - ;; be able to deal with more complex operands (ASH, - ;; EXPT, ...?) -- CSR, 2003-10-09 - ((and - (eq fun-name 'ash) - ;; FIXME: only constants for now, but this - ;; complicates implementation of the out of line - ;; version of modular ASH. -- CSR, 2003-10-09 - (constant-lvar-p (second (basic-combination-args node))) - (> (lvar-value (second (basic-combination-args node))) 0)) - (setq did-something t) - (change-ref-leaf - fun-ref - (find-free-fun - #!-alpha 'sb!vm::ash-left-constant-mod32 - #!+alpha 'sb!vm::ash-left-constant-mod64 - "in a strange place")) - (setf (combination-kind node) :full) - (cut-lvar (first (basic-combination-args node))) - (reoptimize-node node 'ash)))))) + (modular-fun (find-modular-version fun-name width))) + (when (and modular-fun + (not (and (eq fun-name 'logand) + (csubtypep + (single-value-type (node-derived-type node)) + (specifier-type `(unsigned-byte ,width)))))) + (binding* ((name (etypecase modular-fun + ((eql :good) fun-name) + (modular-fun-info + (modular-fun-info-name modular-fun)) + (function + (funcall modular-fun node width))) + :exit-if-null)) + (unless (eql modular-fun :good) + (setq did-something t) + (change-ref-leaf + fun-ref + (find-free-fun name "in a strange place")) + (setf (combination-kind node) :full)) + (unless (functionp modular-fun) + (dolist (arg (basic-combination-args node)) + (when (cut-lvar arg) + (setq did-something t)))) + (when did-something + (reoptimize-node node name)) + did-something))))) (cut-lvar (lvar &aux did-something) (do-uses (node lvar) (when (cut-node node) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 2da36e3..39efee1 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1148,11 +1148,9 @@ (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) (:translate --mod32)) -(defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32) - (foldable flushable movable)) -(define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned - fast-ash-c/unsigned=>unsigned) - (:translate ash-left-constant-mod32)) +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-mod32)) ;;; logical operations (define-modular-fun lognot-mod32 (x) lognot 32) diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 624abd3..8c47082 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -106,11 +106,10 @@ (let* ((x (random most-positive-fixnum)) (x2 (* x 2)) (x3 (* x 3))) - (let ((fn (handler-bind (;; broken by rearrangement of - ;; multiplication strength reduction in - ;; sbcl-0.8.4.12 - #+nil - (sb-ext:compiler-note #'error)) + (let ((fn (handler-bind ((sb-ext:compiler-note + (lambda (c) + (when (<= x3 most-positive-fixnum) + (error c))))) (compile nil `(lambda (y) (declare (optimize speed) (type (integer 0 3) y)) diff --git a/version.lisp-expr b/version.lisp-expr index 9885cbd..a18bf5b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.4.14" +"0.8.4.15"