X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=e2deca6e8a75f3e1e429cee16cdda69c03317514;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=09d6a82a8350321d0c36972f39979d11ac4fccb4;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 09d6a82..e2deca6 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -11,17 +11,17 @@ (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) (let* ((lvar (node-lvar node)) - (locs (lvar-result-tns lvar - (list *backend-t-primitive-type*))) - (res (first locs))) + (locs (lvar-result-tns lvar + (list *backend-t-primitive-type*))) + (res (first locs))) (vop slot node block (lvar-tn node block object) - name offset lowtag res) + name offset lowtag res) (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag) (let ((value-tn (lvar-tn node block value))) (vop set-slot node block (lvar-tn node block object) value-tn - name offset lowtag) + name offset lowtag) (move-lvar-result node block (list value-tn) (node-lvar node)))) ;;; FIXME: Isn't there a name for this which looks less like a typo? @@ -29,57 +29,82 @@ (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag) (let ((value-tn (lvar-tn node block value))) (vop set-slot node block (lvar-tn node block object) value-tn - name offset lowtag) + name offset lowtag) (move-lvar-result node block (list value-tn) (node-lvar node)))) -(defun do-inits (node block name result lowtag inits args) - (let ((unbound-marker-tn nil)) +#!+compare-and-swap-vops +(defoptimizer ir2-convert-casser + ((object old new) node block name offset lowtag) + (let* ((lvar (node-lvar node)) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (res (first locs))) + (vop compare-and-swap-slot node block + (lvar-tn node block object) + (lvar-tn node block old) + (lvar-tn node block new) + name offset lowtag + res) + (move-lvar-result node block locs lvar))) + +(defun emit-inits (node block name result lowtag inits args) + (let ((unbound-marker-tn nil) + (funcallable-instance-tramp-tn nil)) (dolist (init inits) (let ((kind (car init)) - (slot (cdr init))) - (vop set-slot node block result - (ecase kind - (:arg - (aver args) - (lvar-tn node block (pop args))) - (:unbound - (or unbound-marker-tn - (setf unbound-marker-tn - (let ((tn (make-restricted-tn - nil - (sc-number-or-lose 'sb!vm::any-reg)))) - (vop make-unbound-marker node block tn) - tn)))) - (:null - (emit-constant nil))) - name slot lowtag)))) + (slot (cdr init))) + (vop set-slot node block result + (ecase kind + (:arg + (aver args) + (lvar-tn node block (pop args))) + (:unbound + (or unbound-marker-tn + (setf unbound-marker-tn + (let ((tn (make-restricted-tn + nil + (sc-number-or-lose 'sb!vm::any-reg)))) + (vop make-unbound-marker node block tn) + tn)))) + (:null + (emit-constant nil)) + (:funcallable-instance-tramp + (or funcallable-instance-tramp-tn + (setf funcallable-instance-tramp-tn + (let ((tn (make-restricted-tn + nil + (sc-number-or-lose 'sb!vm::any-reg)))) + (vop make-funcallable-instance-tramp node block tn) + tn))))) + name slot lowtag)))) (aver (null args))) -(defun do-fixed-alloc (node block name words type lowtag result) - (vop fixed-alloc node block name words type lowtag result)) +(defun emit-fixed-alloc (node block name words type lowtag result lvar) + (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar)))) + (when stack-allocate-p + (vop current-stack-pointer node block + (ir2-lvar-stack-pointer (lvar-info lvar)))) + (vop fixed-alloc node block name words type lowtag stack-allocate-p result))) (defoptimizer ir2-convert-fixed-allocation - ((&rest args) node block name words type lowtag inits) + ((&rest args) node block name words type lowtag inits) (let* ((lvar (node-lvar node)) - (locs (lvar-result-tns lvar - (list *backend-t-primitive-type*))) - (result (first locs))) - (do-fixed-alloc node block name words type lowtag result) - (do-inits node block name result lowtag inits args) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (result (first locs))) + (emit-fixed-alloc node block name words type lowtag result lvar) + (emit-inits node block name result lowtag inits args) (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-variable-allocation - ((extra &rest args) node block name words type lowtag inits) + ((extra &rest args) node block name words type lowtag inits) (let* ((lvar (node-lvar node)) - (locs (lvar-result-tns lvar - (list *backend-t-primitive-type*))) - (result (first locs))) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (result (first locs))) (if (constant-lvar-p extra) - (let ((words (+ (lvar-value extra) words))) - (do-fixed-alloc node block name words type lowtag result)) - (vop var-alloc node block (lvar-tn node block extra) name words - type lowtag result)) - (do-inits node block name result lowtag inits args) + (let ((words (+ (lvar-value extra) words))) + (emit-fixed-alloc node block name words type lowtag result lvar)) + (vop var-alloc node block (lvar-tn node block extra) name words + type lowtag result)) + (emit-inits node block name result lowtag inits args) (move-lvar-result node block locs lvar))) ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite @@ -89,11 +114,11 @@ ;;; by hand. -- CSR, 2003-05-08 (let ((fun-info (fun-info-or-lose '%set-symbol-value))) (setf (fun-info-ir2-convert fun-info) - (lambda (node block) - (let ((args (basic-combination-args node))) - (destructuring-bind (symbol value) args - (let ((value-tn (lvar-tn node block value))) - (vop set node block - (lvar-tn node block symbol) value-tn) - (move-lvar-result - node block (list value-tn) (node-lvar node)))))))) + (lambda (node block) + (let ((args (basic-combination-args node))) + (destructuring-bind (symbol value) args + (let ((value-tn (lvar-tn node block value))) + (vop set node block + (lvar-tn node block symbol) value-tn) + (move-lvar-result + node block (list value-tn) (node-lvar node))))))))