-;;; 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)
+;;; For a documentation, see CUT-TO-WIDTH.
+
+(defstruct modular-class
+ ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
+ (funs (make-hash-table :test 'eq))
+ ;; hash: modular-variant -> (prototype width)
+ ;;
+ ;; FIXME: Reimplement with generic function names of kind
+ ;; (MODULAR-VERSION prototype width)
+ (versions (make-hash-table :test 'eq))
+ ;; list of increasing widths + signedps
+ (widths nil))
+(defvar *untagged-unsigned-modular-class* (make-modular-class))
+(defvar *untagged-signed-modular-class* (make-modular-class))
+(defvar *tagged-modular-class* (make-modular-class))
+(defun find-modular-class (kind signedp)
+ (ecase kind
+ (:untagged
+ (ecase signedp
+ ((nil) *untagged-unsigned-modular-class*)
+ ((t) *untagged-signed-modular-class*)))
+ (:tagged
+ (aver signedp)
+ *tagged-modular-class*)))
+
+(defstruct modular-fun-info
+ (name (missing-arg) :type symbol)
+ (width (missing-arg) :type (integer 0))
+ (signedp (missing-arg) :type boolean)
+ (lambda-list (missing-arg) :type list)
+ (prototype (missing-arg) :type symbol))
+
+(defun find-modular-version (fun-name kind signedp width)
+ (let ((infos (gethash fun-name (modular-class-funs (find-modular-class kind signedp)))))
+ (if (listp infos)
+ (find-if (lambda (mfi)
+ (aver (eq (modular-fun-info-signedp mfi) signedp))
+ (>= (modular-fun-info-width mfi) width))
+ infos)
+ infos)))
+
+;;; Return (VALUES prototype-name width)
+(defun modular-version-info (name kind signedp)
+ (values-list (gethash name (modular-class-versions (find-modular-class kind signedp)))))
+
+(defun %define-modular-fun (name lambda-list prototype kind signedp width)
+ (let* ((class (find-modular-class kind signedp))
+ (funs (modular-class-funs class))
+ (versions (modular-class-versions class))
+ (infos (the list (gethash prototype funs)))
+ (info (find-if (lambda (mfi)
+ (and (eq (modular-fun-info-signedp mfi) signedp)
+ (= (modular-fun-info-width mfi) width)))
+ infos)))
+ (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 ~
+ ~:[un~;~]signed width ~S."
+ name prototype signedp width))
+ (setf (gethash prototype funs)
+ (merge 'list
+ (list (make-modular-fun-info :name name
+ :width width
+ :signedp signedp
+ :lambda-list lambda-list
+ :prototype prototype))
+ infos
+ #'< :key #'modular-fun-info-width)
+ (gethash name versions)
+ (list prototype width)))
+ (setf (modular-class-widths class)
+ (merge 'list (list (cons width signedp)) (modular-class-widths class)
+ #'< :key #'car))))
+
+(defmacro define-modular-fun (name lambda-list prototype kind signedp width)