From 98743008038a932dc6b53560d121df69c40e40ad Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 13 Aug 2003 09:40:24 +0000 Subject: [PATCH] 0.8.2.26: * Fix bug in the portable implementation of SB-MD5::I; * add support for modular functions with argument number different from 2; * SB!C::CUT-TO-WIDTH: derive node type from the type declaration; * on x86 reimplement LOGNOT as a modular function and implement 32BIT-LOGICAL-NOT in terms of LOGNOT; ... remove optimization of LOGNOT with LOGAND dest. --- BUGS | 16 +++++++++++ contrib/sb-md5/md5.lisp | 2 +- src/code/numbers.lisp | 16 ++++++----- src/compiler/generic/vm-macs.lisp | 53 +++++++++++++++++++++++++------------ src/compiler/generic/vm-tran.lisp | 1 + src/compiler/main.lisp | 1 + src/compiler/srctran.lisp | 19 ++++++++----- src/compiler/x86/arith.lisp | 42 ++++++++++++++++------------- version.lisp-expr | 2 +- 9 files changed, 102 insertions(+), 50 deletions(-) diff --git a/BUGS b/BUGS index 9e5139a..98ea647 100644 --- a/BUGS +++ b/BUGS @@ -1061,6 +1061,22 @@ WORKAROUND: 269: SCALE-FLOAT should accept any integer for its second argument. +270: + In the following function constraint propagator optimizes nothing: + + (defun foo (x) + (declare (integer x)) + (declare (optimize speed)) + (typecase x + (fixnum "hala") + (fixnum "buba") + (bignum "hip") + (t "zuz"))) + +271: + Cross-compiler cannot perform constant folding of some internal + functions, such as %NEGATE. + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp index 9eee945..e362f74 100644 --- a/contrib/sb-md5/md5.lisp +++ b/contrib/sb-md5/md5.lisp @@ -117,7 +117,7 @@ where a is the intended low-order byte and d the high-order byte." #+sbcl (sb-kernel:32bit-logical-xor y (sb-kernel:32bit-logical-orc2 x z)) #-(or cmu sbcl) - (logxor y (logorc2 x z))) + (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) (ftype (function (ub32 ub32) ub32) mod32+)) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 7a17b29..0539b31 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1340,10 +1340,10 @@ ;;;; modular functions #. (collect ((forms)) - (flet ((definition (name width pattern) + (flet ((definition (name lambda-list width pattern) ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH) ;; 'BIGNUM-ELEMENT-TYPE) - `(defun ,name (x y) + `(defun ,name ,lambda-list (flet ((prepare-argument (x) (declare (integer x)) (etypecase x @@ -1351,10 +1351,14 @@ (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* + (,name ,@(loop for arg in lambda-list + collect `(prepare-argument ,arg))))))) + (loop for infos being each hash-value of sb!c::*modular-funs* ;; FIXME: We need to process only "toplevel" functions - do (loop for (width . name) in info + do (loop for info in infos + for name = (sb!c::modular-fun-info-name info) + and width = (sb!c::modular-fun-info-width info) + and lambda-list = (sb!c::modular-fun-info-lambda-list info) for pattern = (1- (ash 1 width)) - do (forms (definition name width pattern))))) + do (forms (definition name lambda-list width pattern))))) `(progn ,@(forms))) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 94e8b39..2984db4 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -158,32 +158,51 @@ ;;; List of increasing widths (defvar *modular-funs-widths* nil) +(defstruct modular-fun-info + (name (missing-arg) :type symbol) + (width (missing-arg) :type (integer 0)) + (lambda-list (missing-arg) :type list) + (prototype (missing-arg) :type symbol)) (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) + (let ((infos (gethash fun-name *modular-funs*))) + (find-if (lambda (item-width) (>= item-width width)) + infos + :key #'modular-fun-info-width))) + +(defun %define-modular-fun (name lambda-list prototype width) + (let* ((infos (the list (gethash prototype *modular-funs*))) + (info (find-if (lambda (item-width) (= item-width width)) + infos + :key #'modular-fun-info-width))) + (if info + (unless (and (eq name (modular-fun-info-name info)) + (= (length lambda-list) + (length (modular-fun-info-lambda-list info)))) + (setf (modular-fun-info-name info) 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 #'<)))) + (merge 'list + (list (make-modular-fun-info :name name + :width width + :lambda-list lambda-list + :prototype prototype)) + infos + #'< :key #'modular-fun-info-width)))) (setq *modular-funs-widths* (merge 'list (list width) *modular-funs-widths* #'<))) -(defmacro define-modular-fun (name prototype width) +(defmacro define-modular-fun (name lambda-list prototype width) (check-type name symbol) (check-type prototype symbol) (check-type width unsigned-byte) + (dolist (arg lambda-list) + (when (member arg lambda-list-keywords) + (error "Lambda list keyword ~S is not supported for ~ + modular function lambda lists." arg))) `(progn - (%define-modular-fun ',name ',prototype ,width) - (defknown ,name (integer integer) (unsigned-byte ,width) - (foldable flushable movable)) - )) + (%define-modular-fun ',name ',lambda-list ',prototype ,width) + (defknown ,name ,(mapcar (constantly 'integer) lambda-list) + (unsigned-byte ,width) + (foldable flushable movable)))) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 8e82df7..d5937ba 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -391,6 +391,7 @@ ;;;; 32-bit operations +#!-x86 ; on X86 it is a modular function (deftransform lognot ((x) ((unsigned-byte 32)) * :node node :result result) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 79e0c45..e79babe 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -445,6 +445,7 @@ (multiple-value-bind (code-length trace-table fixups) (generate-code component) + #-sb-xc-host (when *compiler-trace-output* (format *compiler-trace-output* "~|~%disassembly of code for ~S~2%" component) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 943e291..89747f7 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2441,8 +2441,12 @@ (logand int (lognot mask))))) ;;; modular functions +;;; +;;; -- lower N bits of a result depend only on lower N bits of +;;; arguments. -;;; Try to cut all uses of the continuation CONT to WIDTH bits. +;;; Try to recursively 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) @@ -2450,15 +2454,16 @@ (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 + (modular-fun (find-modular-version fun-name width)) + (name (and modular-fun + (modular-fun-info-name modular-fun)))) + (when modular-fun (change-ref-leaf fun-ref - (find-free-fun modular-fun-name - "in a strange place")) + (find-free-fun name "in a strange place")) (setf (combination-kind node) :full) (setf (node-derived-type node) - (values-specifier-type `(values (unsigned-byte ,width) - &optional))) + (fun-type-returns + (info :function :type name))) (setf (continuation-%derived-type (node-cont node)) nil) (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index fa50482..c4444e0 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -997,22 +997,8 @@ (:result-types unsigned-num) (:policy :fast-safe)) -(define-vop (32bit-logical-not) - (:translate 32bit-logical-not) - (:args (x :scs (unsigned-reg) :target r - :load-if (not (and (sc-is x unsigned-stack) - (sc-is r unsigned-stack) - (location= x r))))) - (:arg-types unsigned-num) - (:results (r :scs (unsigned-reg) - :load-if (not (and (sc-is x unsigned-stack) - (sc-is r unsigned-stack) - (location= x r))))) - (:result-types unsigned-num) - (:policy :fast-safe) - (:generator 1 - (move r x) - (inst not r))) +(define-source-transform 32bit-logical-not (x) + `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32)))) (define-vop (32bit-logical-and 32bit-logical) (:translate 32bit-logical-and) @@ -1390,8 +1376,8 @@ (inst shr tmp 18) (inst xor y tmp))) -;;; Modular functions -(define-modular-fun +-mod32 + 32) +;;;; Modular functions +(define-modular-fun +-mod32 (x y) + 32) (define-vop (fast-+-mod32/unsigned=>unsigned fast-safe-arith-op) (:translate +-mod32) @@ -1415,3 +1401,23 @@ (t (move r x) (inst add r y))))) + +;;; logical operations +(define-modular-fun lognot-mod32 (x) lognot 32) + +(define-vop (lognot-mod32/unsigned=>unsigned) + (:translate lognot-mod32) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r))))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (move r x) + (inst not r))) diff --git a/version.lisp-expr b/version.lisp-expr index 46443a5..cb7b15c 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.25" +"0.8.2.26" -- 1.7.10.4