[Sbcl-commits] CVS: sbcl/src/compiler/generic vm-macs.lisp,1.11,1.12

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

Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8-pr-cvs1:/tmp/cvs-serv16526/src/compiler/generic

Modified Files:
	vm-macs.lisp 
Log Message:
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.


Index: vm-macs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/vm-macs.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- vm-macs.lisp	12 Aug 2002 13:54:50 -0000	1.11
+++ vm-macs.lisp	12 Aug 2003 17:42:57 -0000	1.12
@@ -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))
+     ))