X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=b6bc5a9c0a38986f6fb55414451d7a35a127ef8b;hb=942e45e3bb73fd55786e4a0ab4590324063c0c89;hp=ef031a952cbe5a3af01ff4b5bca8e82f527fdf73;hpb=5dcf5905dc38232b3cc5ec6b309ea5c6424db957;p=sbcl.git diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index ef031a9..b6bc5a9 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -26,21 +26,20 @@ (defun remove-keywords (options keywords) (cond ((null options) nil) - ((member (car options) keywords) - (remove-keywords (cddr options) keywords)) - (t - (list* (car options) (cadr options) - (remove-keywords (cddr options) keywords))))) + ((member (car options) keywords) + (remove-keywords (cddr options) keywords)) + (t + (list* (car options) (cadr options) + (remove-keywords (cddr options) keywords))))) (def!struct (prim-object-slot - (:constructor make-slot (name docs rest-p offset length options)) - (:make-load-form-fun just-dump-it-normally) - (:conc-name slot-)) + (: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)) @@ -57,72 +56,72 @@ (defun %define-primitive-object (primobj) (let ((name (primitive-object-name primobj))) (setf *primitive-objects* - (cons primobj - (remove name *primitive-objects* - :key #'primitive-object-name :test #'eq))) + (cons primobj + (remove name *primitive-objects* + :key #'primitive-object-name :test #'eq))) name)) (defmacro define-primitive-object - ((name &key lowtag widetag alloc-trans (type t)) - &rest slot-specs) + ((name &key lowtag widetag alloc-trans (type t)) + &rest slot-specs) (collect ((slots) (exports) (constants) (forms) (inits)) (let ((offset (if widetag 1 0)) - (variable-length-p nil)) + (variable-length-p nil)) (dolist (spec slot-specs) - (when variable-length-p - (error "No more slots can follow a :rest-p slot.")) - (destructuring-bind - (slot-name &rest options - &key docs rest-p (length (if rest-p 0 1)) - ((:type slot-type) t) init - (ref-known nil ref-known-p) ref-trans - (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 - (remove-keywords options - '(:docs :rest-p :length)))) - (let ((offset-sym (symbolicate name "-" slot-name - (if rest-p "-OFFSET" "-SLOT")))) - (constants `(def!constant ,offset-sym ,offset - ,@(when docs (list docs)))) - (exports offset-sym)) - (when ref-trans - (when ref-known-p - (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known))) - (forms `(def-reffer ,ref-trans ,offset ,lowtag))) - (when set-trans - (when set-known-p - (forms `(defknown ,set-trans - ,(if (listp set-trans) - (list slot-type type) - (list type slot-type)) - ,slot-type - ,set-known))) - (forms `(def-setter ,set-trans ,offset ,lowtag))) - (when init - (inits (cons init offset))) - (when rest-p - (setf variable-length-p t)) - (incf offset length))) + (when variable-length-p + (error "No more slots can follow a :rest-p slot.")) + (destructuring-bind + (slot-name &rest options + &key docs rest-p (length (if rest-p 0 1)) + ((:type slot-type) t) init + (ref-known nil ref-known-p) ref-trans + (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 + (remove-keywords options + '(:docs :rest-p :length)))) + (let ((offset-sym (symbolicate name "-" slot-name + (if rest-p "-OFFSET" "-SLOT")))) + (constants `(def!constant ,offset-sym ,offset + ,@(when docs (list docs)))) + (exports offset-sym)) + (when ref-trans + (when ref-known-p + (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known))) + (forms `(def-reffer ,ref-trans ,offset ,lowtag))) + (when set-trans + (when set-known-p + (forms `(defknown ,set-trans + ,(if (listp set-trans) + (list slot-type type) + (list type slot-type)) + ,slot-type + ,set-known))) + (forms `(def-setter ,set-trans ,offset ,lowtag))) + (when init + (inits (cons init offset))) + (when rest-p + (setf variable-length-p t)) + (incf offset length))) (unless variable-length-p - (let ((size (symbolicate name "-SIZE"))) - (constants `(def!constant ,size ,offset)) - (exports size))) + (let ((size (symbolicate name "-SIZE"))) + (constants `(def!constant ,size ,offset)) + (exports size))) (when alloc-trans - (forms `(def-alloc ,alloc-trans ,offset ,variable-length-p ,widetag - ,lowtag ',(inits)))) + (forms `(def-alloc ,alloc-trans ,offset ,variable-length-p ,widetag + ,lowtag ',(inits)))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (%define-primitive-object - ',(make-primitive-object :name name - :widetag widetag - :lowtag lowtag - :slots (slots) - :size offset - :variable-length-p variable-length-p)) - ,@(constants)) - ,@(forms))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (%define-primitive-object + ',(make-primitive-object :name name + :widetag widetag + :lowtag lowtag + :slots (slots) + :size offset + :variable-length-p variable-length-p)) + ,@(constants)) + ,@(forms))))) ;;;; stuff for defining reffers and setters @@ -154,26 +153,31 @@ ;;; For a documentation, see CUT-TO-WIDTH. -;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)} -(defvar *modular-funs* - (make-hash-table :test 'eq)) +(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*))) -;;; 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 ((infos (gethash fun-name *modular-funs*))) +(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 @@ -181,11 +185,14 @@ infos))) ;;; Return (VALUES prototype-name width) -(defun modular-version-info (name) - (values-list (gethash name *modular-versions*))) +(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 width) - (let* ((infos (the list (gethash prototype *modular-funs*))) +(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))) @@ -196,7 +203,7 @@ (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*) + (setf (gethash prototype funs) (merge 'list (list (make-modular-fun-info :name name :width width @@ -204,43 +211,51 @@ :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* #'<))) + (gethash name versions) + (list prototype width))) + (setf (modular-class-widths class) + (merge 'list (list width) (modular-class-widths class) #'<)))) -(defmacro define-modular-fun (name lambda-list 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 ',lambda-list ',prototype ,width) + (%define-modular-fun ',name ',lambda-list ',prototype ',class ,width) (defknown ,name ,(mapcar (constantly 'integer) lambda-list) - (unsigned-byte ,width) - (foldable flushable movable)))) + (,(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) - (setf (gethash name *modular-funs*) :good) +(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) +(defmacro define-good-modular-fun (name class) (check-type name symbol) - `(%define-good-modular-fun ',name)) + (check-type class (member :unsigned :signed)) + `(%define-good-modular-fun ',name ',class)) (defmacro define-modular-fun-optimizer - (name ((&rest lambda-list) &key (width (gensym "WIDTH"))) + (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-funs*) + `(setf (gethash ',name (modular-class-funs (find-modular-class ',class))) (lambda (,call ,width) (declare (type basic-combination ,call) (type (integer 0) width))