X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=e9f6a0194d3ca7938b9398332b8ef0856403348d;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=984e83b1a1ac3b5f0e36692b2e4b561b2d32c0c2;hpb=8731c1a7c1a585d190151fa881050fb5e14c0616;p=sbcl.git

diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index 984e83b..e9f6a01 100644
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -50,7 +50,7 @@
   (options nil :type list)
   (slots nil :type list)
   (size 0 :type fixnum)
-  (var-length nil :type (member t nil)))
+  (variable-length-p nil :type (member t nil)))
 
 (defvar *primitive-objects* nil)
 
@@ -67,9 +67,9 @@
 	   &rest slot-specs)
   (collect ((slots) (exports) (constants) (forms) (inits))
     (let ((offset (if widetag 1 0))
-	  (var-length nil))
+	  (variable-length-p nil))
       (dolist (spec slot-specs)
-	(when var-length
+	(when variable-length-p
 	  (error "No more slots can follow a :rest-p slot."))
 	(destructuring-bind
 	    (slot-name &rest options
@@ -103,14 +103,14 @@
 	  (when init
 	    (inits (cons init offset)))
 	  (when rest-p
-	    (setf var-length t))
+	    (setf variable-length-p t))
 	  (incf offset length)))
-      (unless var-length
+      (unless variable-length-p
 	(let ((size (symbolicate name "-SIZE")))
 	  (constants `(def!constant ,size ,offset))
 	  (exports size)))
       (when alloc-trans
-	(forms `(def-alloc ,alloc-trans ,offset ,var-length ,widetag
+	(forms `(def-alloc ,alloc-trans ,offset ,variable-length-p ,widetag
 			   ,lowtag ',(inits))))
       `(progn
 	 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -120,7 +120,7 @@
 				     :lowtag lowtag
 				     :slots (slots)
 				     :size offset
-				     :var-length var-length))
+				     :variable-length-p variable-length-p))
 	   ,@(constants))
 	 ,@(forms)))))
 
@@ -132,8 +132,8 @@
   `(%def-reffer ',name ,offset ,lowtag))
 (defmacro def-setter (name offset lowtag)
   `(%def-setter ',name ,offset ,lowtag))
-(defmacro def-alloc (name words var-length header lowtag inits)
-  `(%def-alloc ',name ,words ,var-length ,header ,lowtag ,inits))
+(defmacro def-alloc (name words variable-length-p header lowtag inits)
+  `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
 ;;; are defined later in another file, since they use structure slot
 ;;; setters defined later, and we can't have physical forward
@@ -149,3 +149,70 @@
 
 ;;; the maximum number of SCs in any implementation
 (def!constant sc-number-limit 32)
+
+;;; Modular functions
+
+;;; hash: name -> { ({(width . fun)}*) | :good }
+(defvar *modular-funs*
+  (make-hash-table :test 'eq))
+
+;;; 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 ((infos (gethash fun-name *modular-funs*)))
+    (if (eq infos :good)
+        :good
+        (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 (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 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 ',lambda-list ',prototype ,width)
+     (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
+               (unsigned-byte ,width)
+               (foldable flushable movable))))
+
+(defun %define-good-modular-fun (name)
+  (setf (gethash name *modular-funs*) :good)
+  name)
+
+(defmacro define-good-modular-fun (name)
+  (check-type name symbol)
+  `(%define-good-modular-fun ',name))