X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=184861f009ff0f9f3ea8e97323f6b2910978742a;hb=42ab0c5b87f834c69842713c60587a76f953411f;hp=ae21559eefb9d503c44cc059a8ead7433c316c34;hpb=cb79d726de3e18c660f84c58a43f00d22b459037;p=sbcl.git diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index ae21559..184861f 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -26,16 +26,16 @@ (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 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)) @@ -56,72 +56,82 @@ (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 - (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 + cas-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 cas-trans + (when rest-p + (error ":REST-P and :CAS-TRANS incompatible.")) + (forms + `(progn + (defknown ,cas-trans (,type ,slot-type ,slot-type) + ,slot-type (unsafe)) + #!+compare-and-swap-vops + (def-casser ,cas-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 @@ -133,6 +143,9 @@ `(%def-setter ',name ,offset ,lowtag)) (defmacro def-alloc (name words variable-length-p header lowtag inits) `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits)) +#!+compare-and-swap-vops +(defmacro def-casser (name offset lowtag) + `(%def-casser ',name ,offset ,lowtag)) ;;; 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