\f
;;; Modular functions
-;;; hash: name -> ({(width . fun)}*)
+;;; 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
+ (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 ((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)
+ (let ((infos (gethash fun-name *modular-funs*)))
+ (if (listp infos)
+ (find-if (lambda (item-width) (>= item-width width))
+ infos
+ :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*)))
+ (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 (cons width name)) list #'<))))
+ (merge 'list
+ (list (make-modular-fun-info :name name
+ :width width
+ :lambda-list lambda-list
+ :prototype prototype))
+ infos
+ #'< :key #'modular-fun-info-width)
+ (gethash name *modular-versions*)
+ (list prototype width))))
(setq *modular-funs-widths*
(merge 'list (list width) *modular-funs-widths* #'<)))
-(defmacro define-modular-fun (name prototype width)
+(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 ',prototype ,width)
- (defknown ,name (integer integer) (unsigned-byte ,width)
- (foldable flushable movable))
- ))
+ (%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))
+
+(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)))))))