[Sbcl-commits] CVS: sbcl/src/compiler srctran.lisp,1.115.2.2,1.115.2.3

[Alexey D. <ade...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1755/src/compiler

Modified Files:
      Tag: sbcl-0-8-17-28-signed-modular
	srctran.lisp 
Log Message:
0.8.17.28-signed-modular-arithmetic.4:

* DERIVE-TYPE optimizers for modular functions are reimplemented with
  closures.

* Backends are updated to the new modular arithmetic interface
  (untested).



Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.115.2.2
retrieving revision 1.115.2.3
diff -u -d -r1.115.2.2 -r1.115.2.3
--- srctran.lisp	13 Dec 2004 10:28:23 -0000	1.115.2.2
+++ srctran.lisp	18 Dec 2004 07:56:36 -0000	1.115.2.3
@@ -2569,12 +2569,30 @@
 ;;;
 ;;; and similar for other arguments.
 
-(defun modular-fun-derive-type (node prototype class width)
+(defun make-modular-fun-type-deriver (prototype class width)
+  #!-sb-fluid
   (binding* ((info (info :function :info prototype) :exit-if-null)
              (fun (fun-info-derive-type info) :exit-if-null)
-             (res (funcall fun node) :exit-if-null))
-    (if (eq class :unsigned)
-        (logand-derive-type-aux res (specifier-type `(unsigned-byte* ,width))))))
+             (mask-type (specifier-type
+                         (ecase class
+                             (:unsigned `(unsigned-byte* ,width))
+                             (:signed `(signed-byte ,width))))))
+    (lambda (call)
+      (let ((res (funcall fun call)))
+        (when res
+          (if (eq class :unsigned)
+              (logand-derive-type-aux res mask-type))))))
+  #!+sb-fluid
+  (lambda (call)
+    (binding* ((info (info :function :info prototype) :exit-if-null)
+               (fun (fun-info-derive-type info) :exit-if-null)
+               (res (funcall fun call) :exit-if-null)
+               (mask-type (specifier-type
+                           (ecase class
+                             (:unsigned `(unsigned-byte* ,width))
+                             (:signed `(signed-byte ,width))))))
+      (if (eq class :unsigned)
+          (logand-derive-type-aux res mask-type)))))
 
 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
 ;;;