Skip to content
Snippets Groups Projects
Commit d1f88027 authored by ram's avatar ram
Browse files

Added code to any emit coercion VOPs before the move-argument VOPs in a call

parent ee8f462d
No related branches found
No related tags found
No related merge requests found
...@@ -254,10 +254,10 @@ ...@@ -254,10 +254,10 @@
;;; EMIT-COERCE-VOP -- Internal ;;; EMIT-COERCE-VOP -- Internal
;;; ;;;
;;; Emit a coercion VOP for Op or die trying. SCS is the operand's LOAD-SCS ;;; Emit a coercion VOP for Op Before the specifed VOP or die trying. SCS
;;; vector, which we use to determine what SCs the VOP will accept. We pick ;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
;;; any acceptable coerce VOP, since it practice it seems uninteresting to have ;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it
;;; more than one applicable. ;;; seems uninteresting to have more than one applicable.
;;; ;;;
;;; What we do is look at each SC allowed by the operand restriction, and ;;; What we do is look at each SC allowed by the operand restriction, and
;;; see if there is a move VOP which moves between the operand's SC and load ;;; see if there is a move VOP which moves between the operand's SC and load
...@@ -267,8 +267,8 @@ ...@@ -267,8 +267,8 @@
;;; If the TN is an unused result TN, then we don't actually emit the move; ;;; If the TN is an unused result TN, then we don't actually emit the move;
;;; we just change to the right kind of TN. ;;; we just change to the right kind of TN.
;;; ;;;
(defun emit-coerce-vop (op scs) (defun emit-coerce-vop (op scs before)
(declare (type tn-ref op) (type sc-vector scs)) (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before))
(let* ((op-tn (tn-ref-tn op)) (let* ((op-tn (tn-ref-tn op))
(op-sc (tn-sc op-tn)) (op-sc (tn-sc op-tn))
(op-scn (sc-number op-sc)) (op-scn (sc-number op-sc))
...@@ -287,34 +287,49 @@ ...@@ -287,34 +287,49 @@
(change-tn-ref-tn op temp) (change-tn-ref-tn op temp)
(cond (cond
((not write-p) ((not write-p)
(emit-move-template node block res op-tn temp vop)) (emit-move-template node block res op-tn temp before))
((null (tn-reads op-tn))) ((null (tn-reads op-tn)))
(t (t
(emit-move-template node block res temp op-tn (vop-next vop))))) (emit-move-template node block res temp op-tn before))))
(return))))))) (return)))))))
;;; COERCE-SOME-OPERANDS -- Internal
;;;
;;; Scan some operands and call EMIT-COERCE-VOP on any for which we can't
;;; load the operand. The coerce VOP is inserted Before the specified VOP.
;;;
(proclaim '(inline coerce-some-operands))
(defun coerce-some-operands (ops load-scs before)
(declare (type (or tn-ref null) ops) (list load-scs)
(type (or vop null) before))
(do ((op ops (tn-ref-across op))
(scs load-scs (cdr scs)))
((null scs))
(unless (svref (car scs)
(sc-number (tn-sc (tn-ref-tn op))))
(emit-coerce-vop op (car scs) before)))
(undefined-value))
;;; COERCE-VOP-OPERANDS -- Internal ;;; COERCE-VOP-OPERANDS -- Internal
;;; ;;;
;;; Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we ;;; Emit coerce VOPs for the args and results, as needed.
;;; can't load the operand.
;;; ;;;
(defun coerce-vop-operands (vop) (defun coerce-vop-operands (vop)
(declare (type vop vop)) (declare (type vop vop))
(let ((info (vop-info vop))) (let ((info (vop-info vop)))
(macrolet ((scan (ops load-scs) (coerce-some-operands (vop-args vop) (vop-info-arg-load-scs info) vop)
`(do ((op ,ops (tn-ref-across op)) (coerce-some-operands (vop-results vop) (vop-info-result-load-scs info)
(scs ,load-scs (cdr scs))) (vop-next vop))))
((null scs))
(unless (svref (car scs)
(sc-number (tn-sc (tn-ref-tn op))))
(emit-coerce-vop op (car scs))))))
(scan (vop-args vop) (vop-info-arg-load-scs info))
(scan (vop-results vop) (vop-info-result-load-scs info)))))
;;; EMIT-ARG-MOVES -- Internal ;;; EMIT-ARG-MOVES -- Internal
;;; ;;;
;;; Iterate over the more operands to a call VOP, emitting move-arg VOPs and
;;; any necessary coercions. We determine which FP to use by looking at the
;;; MOVE-ARGS annotation.
;;;
(defun emit-arg-moves (vop) (defun emit-arg-moves (vop)
(let* ((info (vop-info vop)) (let* ((info (vop-info vop))
(node (vop-node vop)) (node (vop-node vop))
...@@ -325,7 +340,8 @@ ...@@ -325,7 +340,8 @@
(nfp-tn (if (eq how :local-call) (nfp-tn (if (eq how :local-call)
(tn-ref-tn (tn-ref-across args)) (tn-ref-tn (tn-ref-across args))
nil)) nil))
(pass-locs (first (vop-codegen-info vop)))) (pass-locs (first (vop-codegen-info vop)))
(prev (vop-prev vop)))
(do ((val (do ((arg args (tn-ref-across arg)) (do ((val (do ((arg args (tn-ref-across arg))
(req (template-arg-types info) (cdr req))) (req (template-arg-types info) (cdr req)))
((null req) arg)) ((null req) arg))
...@@ -340,20 +356,25 @@ ...@@ -340,20 +356,25 @@
(sc-number (tn-sc val-tn))))) (sc-number (tn-sc val-tn)))))
(unless res (unless res
(bad-move-arg-error val-tn pass-tn)) (bad-move-arg-error val-tn pass-tn))
(let ((this-fp (change-tn-ref-tn val pass-tn)
(cond ((not (sc-number-stack-p pass-sc)) fp-tn) (let* ((this-fp
(nfp-tn) (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
(t (nfp-tn)
(assert (eq how :known-return)) (t
(setq nfp-tn (assert (eq how :known-return))
(make-representation-tn (setq nfp-tn
(first (primitive-type-scs (make-representation-tn
*any-primitive-type*)))) (first (primitive-type-scs
(emit-context-template node block nfp-tn vop) *any-primitive-type*))))
nfp-tn)))) (emit-context-template node block nfp-tn vop)
(emit-move-arg-template node block res val-tn this-fp pass-tn vop))))) nfp-tn)))
(new (emit-move-arg-template node block res val-tn this-fp
pass-tn vop)))
(coerce-some-operands (vop-args new) (vop-info-arg-load-scs res)
(if prev
(vop-next prev)
(ir2-block-start-vop block)))))))
(undefined-value)) (undefined-value))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment