X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=66d399aa8d3a2d058ceba15df05831d5ed623bd1;hb=b1b85bbf17f686a0787304a04cf0e01e8216d038;hp=e9f6a0194d3ca7938b9398332b8ef0856403348d;hpb=f6f238261f95e8ffff2870ed3ac6fc00ddf09ef2;p=sbcl.git

diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index e9f6a01..66d399a 100644
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -33,14 +33,13 @@
 		(remove-keywords (cddr options) keywords)))))
 
 (def!struct (prim-object-slot
-	     (:constructor make-slot (name docs rest-p offset length options))
+	     (:constructor make-slot (name docs rest-p offset options))
 	     (:make-load-form-fun just-dump-it-normally)
 	     (:conc-name slot-))
   (name nil :type symbol)
   (docs nil :type (or null simple-string))
   (rest-p nil :type (member t nil))
   (offset 0 :type fixnum)
-  (length 1 :type fixnum)
   (options nil :type list))
 
 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
@@ -79,7 +78,7 @@
 		       (set-known nil set-known-p) set-trans
 		       &allow-other-keys)
 	    (if (atom spec) (list spec) spec)
-	  (slots (make-slot slot-name docs rest-p offset length
+	  (slots (make-slot slot-name docs rest-p offset
 			    (remove-keywords options
 					     '(:docs :rest-p :length))))
 	  (let ((offset-sym (symbolicate name "-" slot-name
@@ -152,10 +151,18 @@
 
 ;;; Modular functions
 
-;;; hash: name -> { ({(width . fun)}*) | :good }
+;;; For a documentation, see CUT-TO-WIDTH.
+
+;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
 (defvar *modular-funs*
   (make-hash-table :test 'eq))
 
+;;; hash: modular-variant -> (prototype width)
+;;;
+;;; FIXME: Reimplement with generic function names of kind
+;;; (MODULAR-VERSION prototype width)
+(defvar *modular-versions* (make-hash-table :test 'eq))
+
 ;;; List of increasing widths
 (defvar *modular-funs-widths* nil)
 (defstruct modular-fun-info
@@ -166,11 +173,15 @@
 
 (defun find-modular-version (fun-name width)
   (let ((infos (gethash fun-name *modular-funs*)))
-    (if (eq infos :good)
-        :good
+    (if (listp infos)
         (find-if (lambda (item-width) (>= item-width width))
                  infos
-                 :key #'modular-fun-info-width))))
+                 :key #'modular-fun-info-width)
+        infos)))
+
+;;; Return (VALUES prototype-name width)
+(defun modular-version-info (name)
+  (values-list (gethash name *modular-versions*)))
 
 (defun %define-modular-fun (name lambda-list prototype width)
   (let* ((infos (the list (gethash prototype *modular-funs*)))
@@ -191,7 +202,9 @@
                                                   :lambda-list lambda-list
                                                   :prototype prototype))
                      infos
-                     #'< :key #'modular-fun-info-width))))
+                     #'< :key #'modular-fun-info-width)
+              (gethash name *modular-versions*)
+              (list prototype width))))
   (setq *modular-funs-widths*
         (merge 'list (list width) *modular-funs-widths* #'<)))
 
@@ -216,3 +229,22 @@
 (defmacro define-good-modular-fun (name)
   (check-type name symbol)
   `(%define-good-modular-fun ',name))
+
+(defmacro define-modular-fun-optimizer
+    (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
+     &body body)
+  (check-type name symbol)
+  (dolist (arg lambda-list)
+    (when (member arg lambda-list-keywords)
+      (error "Lambda list keyword ~S is not supported for ~
+              modular function lambda lists." arg)))
+  (with-unique-names (call args)
+    `(setf (gethash ',name *modular-funs*)
+           (lambda (,call ,width)
+             (declare (type basic-combination ,call)
+                      (type (integer 0) width))
+             (let ((,args (basic-combination-args ,call)))
+               (when (= (length ,args) ,(length lambda-list))
+                 (destructuring-bind ,lambda-list ,args
+                   (declare (type lvar ,@lambda-list))
+                   ,@body)))))))