X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=ae21559eefb9d503c44cc059a8ead7433c316c34;hb=ca267caa3bdb897a93a1e69ae7300ba3ba5d391f;hp=94e8b399adad946972dad2937ae0e6d272d81ba2;hpb=5f1f553ecde8995aae8d9f9fbe1cd2b2cfb7db48;p=sbcl.git diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 94e8b39..ae21559 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,38 +151,116 @@ ;;; 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) +;;; 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 + (widths nil)) +(defvar *unsigned-modular-class* (make-modular-class)) +(defvar *signed-modular-class* (make-modular-class)) +(defun find-modular-class (kind) + (ecase kind + (:unsigned *unsigned-modular-class*) + (:signed *signed-modular-class*))) + +(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 class width) + (let ((infos (gethash fun-name (modular-class-funs (find-modular-class class))))) + (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 class) + (values-list (gethash name (modular-class-versions (find-modular-class class))))) + +(defun %define-modular-fun (name lambda-list prototype class width) + (let* ((class (find-modular-class class)) + (funs (modular-class-funs class)) + (versions (modular-class-versions class)) + (infos (the list (gethash prototype 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 #'<)))) - (setq *modular-funs-widths* - (merge 'list (list width) *modular-funs-widths* #'<))) + (setf (gethash prototype funs) + (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 versions) + (list prototype width))) + (setf (modular-class-widths class) + (merge 'list (list width) (modular-class-widths class) #'<)))) -(defmacro define-modular-fun (name prototype width) +(defmacro define-modular-fun (name lambda-list prototype class width) (check-type name symbol) (check-type prototype symbol) + (check-type class (member :unsigned :signed)) (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 ',class ,width) + (defknown ,name ,(mapcar (constantly 'integer) lambda-list) + (,(ecase class + (:unsigned 'unsigned-byte) + (:signed 'signed-byte)) + ,width) + (foldable flushable movable) + :derive-type (make-modular-fun-type-deriver + ',prototype ',class ,width)))) + +(defun %define-good-modular-fun (name class) + (setf (gethash name (modular-class-funs (find-modular-class class))) :good) + name) + +(defmacro define-good-modular-fun (name class) + (check-type name symbol) + (check-type class (member :unsigned :signed)) + `(%define-good-modular-fun ',name ',class)) + +(defmacro define-modular-fun-optimizer + (name ((&rest lambda-list) class &key (width (gensym "WIDTH"))) + &body body) + (check-type name symbol) + (check-type class (member :unsigned :signed)) + (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-class-funs (find-modular-class ',class))) + (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)))))))