X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=1fcfe78b96fab202cbc405c2a4c294d31b81b170;hb=f8893c7c658bf9d9e0757c63e47af2fdea810f04;hp=fe7f950a83785e3aae7953c280ccf18d2f32de46;hpb=80d37651bc4cba800bbf2ba38ea720d734fbae4a;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index fe7f950..1fcfe78 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,26 +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)))) + (modular-fun (find-modular-version fun-name width))) (when (and modular-fun - (not (and (eq name 'logand) + (not (and (eq fun-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 + (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)) - (dolist (arg (basic-combination-args node)) - (when (cut-lvar arg) - (setq did-something t))) - (when did-something - (reoptimize-node node fun-name)) - did-something)))) + (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) @@ -2602,22 +2612,22 @@ (give-up-ir1-transform "BOOLE code is not a constant.")) (let ((control (lvar-value op))) (case control - (#.boole-clr 0) - (#.boole-set -1) - (#.boole-1 'x) - (#.boole-2 'y) - (#.boole-c1 '(lognot x)) - (#.boole-c2 '(lognot y)) - (#.boole-and '(logand x y)) - (#.boole-ior '(logior x y)) - (#.boole-xor '(logxor x y)) - (#.boole-eqv '(logeqv x y)) - (#.boole-nand '(lognand x y)) - (#.boole-nor '(lognor x y)) - (#.boole-andc1 '(logandc1 x y)) - (#.boole-andc2 '(logandc2 x y)) - (#.boole-orc1 '(logorc1 x y)) - (#.boole-orc2 '(logorc2 x y)) + (#.sb!xc:boole-clr 0) + (#.sb!xc:boole-set -1) + (#.sb!xc:boole-1 'x) + (#.sb!xc:boole-2 'y) + (#.sb!xc:boole-c1 '(lognot x)) + (#.sb!xc:boole-c2 '(lognot y)) + (#.sb!xc:boole-and '(logand x y)) + (#.sb!xc:boole-ior '(logior x y)) + (#.sb!xc:boole-xor '(logxor x y)) + (#.sb!xc:boole-eqv '(logeqv x y)) + (#.sb!xc:boole-nand '(lognand x y)) + (#.sb!xc:boole-nor '(lognor x y)) + (#.sb!xc:boole-andc1 '(logandc1 x y)) + (#.sb!xc:boole-andc2 '(logandc2 x y)) + (#.sb!xc:boole-orc1 '(logorc1 x y)) + (#.sb!xc:boole-orc2 '(logorc2 x y)) (t (abort-ir1-transform "~S is an illegal control arg to BOOLE." control)))))