X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-macs.lisp;h=74a9e099ef95999a0cf81b31c83a25cfe6be6fe5;hb=7dfa54273d2ebc6c2be9a39ab5cd6df639d340c9;hp=b6bc5a9c0a38986f6fb55414451d7a35a127ef8b;hpb=f1ffbf976aaa50b7b22f126b97e34afe06a91210;p=sbcl.git diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index b6bc5a9..74a9e09 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -76,6 +76,7 @@ ((: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 @@ -99,6 +100,15 @@ ,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 ()) + #!+compare-and-swap-vops + (def-casser ,cas-trans ,offset ,lowtag)))) (when init (inits (cons init offset))) (when rest-p @@ -109,8 +119,10 @@ (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 + ,(if variable-length-p :var-alloc :fixed-alloc) + ,widetag + ,lowtag ',(inits)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (%define-primitive-object @@ -131,8 +143,11 @@ `(%def-reffer ',name ,offset ,lowtag)) (defmacro def-setter (name offset lowtag) `(%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)) +(defmacro def-alloc (name words alloc-style header lowtag inits) + `(%def-alloc ',name ,words ,alloc-style ,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 @@ -147,7 +162,7 @@ (in-package "SB!C") ;;; the maximum number of SCs in any implementation -(def!constant sc-number-limit 32) +(def!constant sc-number-limit 62) ;;; Modular functions @@ -161,52 +176,63 @@ ;; FIXME: Reimplement with generic function names of kind ;; (MODULAR-VERSION prototype width) (versions (make-hash-table :test 'eq)) - ;; list of increasing widths + ;; list of increasing widths + signedps (widths nil)) -(defvar *unsigned-modular-class* (make-modular-class)) -(defvar *signed-modular-class* (make-modular-class)) -(defun find-modular-class (kind) +(defvar *untagged-unsigned-modular-class* (make-modular-class)) +(defvar *untagged-signed-modular-class* (make-modular-class)) +(defvar *tagged-modular-class* (make-modular-class)) +(defun find-modular-class (kind signedp) (ecase kind - (:unsigned *unsigned-modular-class*) - (:signed *signed-modular-class*))) + (:untagged + (ecase signedp + ((nil) *untagged-unsigned-modular-class*) + ((t) *untagged-signed-modular-class*))) + (:tagged + (aver signedp) + *tagged-modular-class*))) (defstruct modular-fun-info (name (missing-arg) :type symbol) (width (missing-arg) :type (integer 0)) + (signedp (missing-arg) :type boolean) (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))))) +(defun find-modular-version (fun-name kind signedp width) + (let ((infos (gethash fun-name (modular-class-funs (find-modular-class kind signedp))))) (if (listp infos) - (find-if (lambda (item-width) (>= item-width width)) - infos - :key #'modular-fun-info-width) + (find-if (lambda (mfi) + (aver (eq (modular-fun-info-signedp mfi) signedp)) + (>= (modular-fun-info-width mfi) width)) + infos) infos))) ;;; Return (VALUES prototype-name width) -(defun modular-version-info (name class) - (values-list (gethash name (modular-class-versions (find-modular-class class))))) +(defun modular-version-info (name kind signedp) + (values-list (gethash name (modular-class-versions (find-modular-class kind signedp))))) -(defun %define-modular-fun (name lambda-list prototype class width) - (let* ((class (find-modular-class class)) +(defun %define-modular-fun (name lambda-list prototype kind signedp width) + (let* ((class (find-modular-class kind signedp)) (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))) + (info (find-if (lambda (mfi) + (and (eq (modular-fun-info-signedp mfi) signedp) + (= (modular-fun-info-width mfi) width))) + infos))) (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)) + (style-warn "Redefining modular version ~S of ~S for ~ + ~:[un~;~]signed width ~S." + name prototype signedp width)) (setf (gethash prototype funs) (merge 'list (list (make-modular-fun-info :name name :width width + :signedp signedp :lambda-list lambda-list :prototype prototype)) infos @@ -214,51 +240,52 @@ (gethash name versions) (list prototype width))) (setf (modular-class-widths class) - (merge 'list (list width) (modular-class-widths class) #'<)))) + (merge 'list (list (cons width signedp)) (modular-class-widths class) + #'< :key #'car)))) -(defmacro define-modular-fun (name lambda-list prototype class width) +(defmacro define-modular-fun (name lambda-list prototype kind signedp width) (check-type name symbol) (check-type prototype symbol) - (check-type class (member :unsigned :signed)) + (check-type kind (member :untagged :tagged)) (check-type width unsigned-byte) (dolist (arg lambda-list) - (when (member arg lambda-list-keywords) + (when (member arg sb!xc: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 ',class ,width) + (%define-modular-fun ',name ',lambda-list ',prototype ',kind ',signedp ,width) (defknown ,name ,(mapcar (constantly 'integer) lambda-list) - (,(ecase class - (:unsigned 'unsigned-byte) - (:signed 'signed-byte)) + (,(ecase signedp + ((nil) 'unsigned-byte) + ((t) 'signed-byte)) ,width) (foldable flushable movable) :derive-type (make-modular-fun-type-deriver - ',prototype ',class ,width)))) + ',prototype ',kind ,width ',signedp)))) -(defun %define-good-modular-fun (name class) - (setf (gethash name (modular-class-funs (find-modular-class class))) :good) +(defun %define-good-modular-fun (name kind signedp) + (setf (gethash name (modular-class-funs (find-modular-class kind signedp))) :good) name) -(defmacro define-good-modular-fun (name class) +(defmacro define-good-modular-fun (name kind signedp) (check-type name symbol) - (check-type class (member :unsigned :signed)) - `(%define-good-modular-fun ',name ',class)) + (check-type kind (member :untagged :tagged)) + `(%define-good-modular-fun ',name ',kind ',signedp)) (defmacro define-modular-fun-optimizer - (name ((&rest lambda-list) class &key (width (gensym "WIDTH"))) + (name ((&rest lambda-list) kind signedp &key (width (gensym "WIDTH"))) &body body) (check-type name symbol) - (check-type class (member :unsigned :signed)) + (check-type kind (member :untagged :tagged)) (dolist (arg lambda-list) - (when (member arg lambda-list-keywords) + (when (member arg sb!xc: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))) + `(setf (gethash ',name (modular-class-funs (find-modular-class ',kind ',signedp))) (lambda (,call ,width) (declare (type basic-combination ,call) - (type (integer 0) width)) + (type (integer 0) ,width)) (let ((,args (basic-combination-args ,call))) (when (= (length ,args) ,(length lambda-list)) (destructuring-bind ,lambda-list ,args