From: Alexey Dejneka Date: Tue, 12 Aug 2003 17:42:57 +0000 (+0000) Subject: 0.8.2.25: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5f1f553ecde8995aae8d9f9fbe1cd2b2cfb7db48;p=sbcl.git 0.8.2.25: Initial implementation of modular functions: * new macro: SB!C:DEFINE-MODULAR-FUNCTION; * optimization of LOGAND: try to cut arguments to the needed number of bits; * implemented + with 32 bit width for x86. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6746658..852af57 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -224,7 +224,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "DEF-IR1-TRANSLATOR" "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS" "DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE" - "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUN" + "DEFINE-ASSEMBLY-ROUTINE" + "DEFINE-MODULAR-FUN" + "DEFINE-MOVE-FUN" "DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE" "DEFINE-STORAGE-CLASS" "DEFINE-VOP" "DEFKNOWN" "DEFOPTIMIZER" diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 34ad585..7a17b29 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1336,3 +1336,25 @@ (def minusp "Is this real number strictly negative?") (def oddp "Is this integer odd?") (def evenp "Is this integer even?")) + +;;;; modular functions +#. +(collect ((forms)) + (flet ((definition (name width pattern) + ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH) + ;; 'BIGNUM-ELEMENT-TYPE) + `(defun ,name (x y) + (flet ((prepare-argument (x) + (declare (integer x)) + (etypecase x + ((unsigned-byte ,width) x) + (bignum-element-type (logand x ,pattern)) + (fixnum (logand x ,pattern)) + (bignum (logand (%bignum-ref x 0) ,pattern))))) + (,name (prepare-argument x) (prepare-argument y)))))) + (loop for info being each hash-value of sb!c::*modular-funs* + ;; FIXME: We need to process only "toplevel" functions + do (loop for (width . name) in info + for pattern = (1- (ash 1 width)) + do (forms (definition name width pattern))))) + `(progn ,@(forms))) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 639f7e4..94e8b39 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -149,3 +149,41 @@ ;;; the maximum number of SCs in any implementation (def!constant sc-number-limit 32) + +;;; Modular functions + +;;; hash: name -> ({(width . fun)}*) +(defvar *modular-funs* + (make-hash-table :test 'eq)) + +;;; List of increasing widths +(defvar *modular-funs-widths* nil) + +(defun find-modular-version (fun-name width) + (let ((info (gethash fun-name *modular-funs*))) + (cdr (find-if (lambda (item-width) (>= item-width width)) + info + :key #'car)))) + +(defun %define-modular-fun (name prototype width) + (let* ((list (gethash prototype *modular-funs*)) + (entry (assoc width list))) + (if entry + (unless (eq name (cdr entry)) + (setf (cdr entry) name) + (style-warn "Redefining modular version ~S of ~S for width ~S." + name prototype width)) + (setf (gethash prototype *modular-funs*) + (merge 'list (list (cons width name)) list #'<)))) + (setq *modular-funs-widths* + (merge 'list (list width) *modular-funs-widths* #'<))) + +(defmacro define-modular-fun (name prototype width) + (check-type name symbol) + (check-type prototype symbol) + (check-type width unsigned-byte) + `(progn + (%define-modular-fun ',name ',prototype ,width) + (defknown ,name (integer integer) (unsigned-byte ,width) + (foldable flushable movable)) + )) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ab4fc17..943e291 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2440,6 +2440,53 @@ (logior (logand new mask) (logand int (lognot mask))))) +;;; modular functions + +;;; Try to cut all uses of the continuation CONT to WIDTH bits. +(defun cut-to-width (cont width) + (declare (type continuation cont) (type (integer 0) width)) + (labels ((cut-node (node) + (when (and (combination-p node) + (fun-info-p (basic-combination-kind node))) + (let* ((fun-ref (continuation-use (combination-fun node))) + (fun-name (leaf-source-name (ref-leaf fun-ref))) + (modular-fun-name (find-modular-version fun-name width))) + (when modular-fun-name + (change-ref-leaf fun-ref + (find-free-fun modular-fun-name + "in a strange place")) + (setf (combination-kind node) :full) + (setf (node-derived-type node) + (values-specifier-type `(values (unsigned-byte ,width) + &optional))) + (setf (continuation-%derived-type (node-cont node)) nil) + (setf (node-reoptimize node) t) + (setf (block-reoptimize (node-block node)) t) + (setf (component-reoptimize (node-component node)) t) + (dolist (arg (basic-combination-args node)) + (cut-continuation arg)))))) + (cut-continuation (cont) + (do-uses (node cont) + (cut-node node)))) + (cut-continuation cont))) + +(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))) + (when (some (lambda (x) (<= width x)) + *modular-funs-widths*) + ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH). + (cut-to-width x width) + (cut-to-width y width) + nil ; After fixing above, replace with T. + ))))))) + ;;; miscellanous numeric transforms ;;; If a constant appears as the first arg, swap the args. @@ -2641,6 +2688,17 @@ (def logxor -1 (lognot x)) (def logxor 0 x)) +(deftransform logand ((x y) (* (constant-arg t)) *) + "fold identity operation" + (let ((y (continuation-value y))) + (unless (and (plusp y) + (= y (1- (ash 1 (integer-length y))))) + (give-up-ir1-transform)) + (unless (csubtypep (continuation-type x) + (specifier-type `(integer 0 ,y))) + (give-up-ir1-transform)) + 'x)) + ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and ;;; (* 0 -4.0) is -0.0. (deftransform - ((x y) ((constant-arg (member 0)) rational) *) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 865fade..fa50482 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1389,3 +1389,29 @@ (inst mov tmp y) (inst shr tmp 18) (inst xor y tmp))) + +;;; Modular functions +(define-modular-fun +-mod32 + 32) + +(define-vop (fast-+-mod32/unsigned=>unsigned fast-safe-arith-op) + (:translate +-mod32) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 5 + (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg) (sc-is r unsigned-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) diff --git a/version.lisp-expr b/version.lisp-expr index 6116a64..46443a5 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.2.24" +"0.8.2.25"