X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=66d399aa8d3a2d058ceba15df05831d5ed623bd1;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=dd5f2ea02629b22e5bfd1b1a6d88643ec2063cf4;hpb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;p=sbcl.git diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index dd5f2ea..66d399a 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -33,24 +33,23 @@ (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)) (name nil :type symbol) - (header nil :type symbol) + (widetag nil :type symbol) (lowtag nil :type symbol) (options nil :type list) (slots nil :type list) (size 0 :type fixnum) - (variable-length nil :type (member t nil))) + (variable-length-p nil :type (member t nil))) (defvar *primitive-objects* nil) @@ -63,13 +62,13 @@ name)) (defmacro define-primitive-object - ((name &key header lowtag alloc-trans (type t)) + ((name &key lowtag widetag alloc-trans (type t)) &rest slot-specs) (collect ((slots) (exports) (constants) (forms) (inits)) - (let ((offset (if header 1 0)) - (variable-length nil)) + (let ((offset (if widetag 1 0)) + (variable-length-p nil)) (dolist (spec slot-specs) - (when variable-length + (when variable-length-p (error "No more slots can follow a :rest-p slot.")) (destructuring-bind (slot-name &rest options @@ -79,12 +78,12 @@ (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 (if rest-p "-OFFSET" "-SLOT")))) - (constants `(defconstant ,offset-sym ,offset + (constants `(def!constant ,offset-sym ,offset ,@(when docs (list docs)))) (exports offset-sym)) (when ref-trans @@ -103,24 +102,24 @@ (when init (inits (cons init offset))) (when rest-p - (setf variable-length t)) + (setf variable-length-p t)) (incf offset length))) - (unless variable-length + (unless variable-length-p (let ((size (symbolicate name "-SIZE"))) - (constants `(defconstant ,size ,offset)) + (constants `(def!constant ,size ,offset)) (exports size))) (when alloc-trans - (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header + (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 - :header header + :widetag widetag :lowtag lowtag :slots (slots) :size offset - :variable-length variable-length)) + :variable-length-p variable-length-p)) ,@(constants)) ,@(forms))))) @@ -128,43 +127,18 @@ (in-package "SB!C") -(defun %def-reffer (name offset lowtag) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - #'(lambda (node block) - (ir2-convert-reffer node block name offset lowtag)))) - name) - (defmacro def-reffer (name offset lowtag) `(%def-reffer ',name ,offset ,lowtag)) - -(defun %def-setter (name offset lowtag) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - (if (listp name) - #'(lambda (node block) - (ir2-convert-setfer node block name offset lowtag)) - #'(lambda (node block) - (ir2-convert-setter node block name offset lowtag))))) - name) - (defmacro def-setter (name offset lowtag) `(%def-setter ',name ,offset ,lowtag)) - -(defun %def-alloc (name words variable-length header lowtag inits) - (let ((info (function-info-or-lose name))) - (setf (function-info-ir2-convert info) - (if variable-length - #'(lambda (node block) - (ir2-convert-variable-allocation node block name words header - lowtag inits)) - #'(lambda (node block) - (ir2-convert-fixed-allocation node block name words header - lowtag inits))))) - name) - -(defmacro def-alloc (name words variable-length header lowtag inits) - `(%def-alloc ',name ,words ,variable-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 +;;; references to structure slot setters because ANSI in its wisdom +;;; allows the xc host CL to implement structure slot setters as SETF +;;; expanders instead of SETF functions. -- WHN 2002-02-09 ;;;; some general constant definitions @@ -173,4 +147,104 @@ (in-package "SB!C") ;;; the maximum number of SCs in any implementation -(defconstant sc-number-limit 32) +(def!constant sc-number-limit 32) + +;;; Modular functions + +;;; 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 ((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 (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 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)) + +(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)))))))