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

Made error checking stuff recompute the operand costs and compare with

the value in the VOP-INFO to see if there is an inconsistency.
Added CHECK-MOVE-FUNCTION-CONSISTENCY.
When computing costs, ignore references due to the MOVE VOP.
Changed stuff over to the new scheme of having the NFP be per-component
rather than per-function.
Added new argument moving stuff.
parent 4807e020
No related branches found
No related tags found
No related merge requests found
...@@ -31,31 +31,46 @@ ...@@ -31,31 +31,46 @@
;;; 3] True if the operand is a more operand, false otherwise. ;;; 3] True if the operand is a more operand, false otherwise.
;;; 4] The costs for this operand. ;;; 4] The costs for this operand.
;;; 5] The load-scs vector for this operand (NIL if more-p.) ;;; 5] The load-scs vector for this operand (NIL if more-p.)
;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the
;;; currently record ones.
;;; ;;;
(defun get-operand-info (ref) (defun get-operand-info (ref)
(declare (type tn-ref ref)) (declare (type tn-ref ref))
(let* ((arg-p (not (tn-ref-write-p ref))) (let* ((arg-p (not (tn-ref-write-p ref)))
(vop (tn-ref-vop ref)) (vop (tn-ref-vop ref))
(info (vop-info vop))) (info (vop-info vop)))
(flet ((frob (refs costs restr load more-cost) (flet ((frob (refs costs load more-cost)
(do ((refs refs (tn-ref-across refs)) (do ((refs refs (tn-ref-across refs))
(costs costs (cdr costs)) (costs costs (cdr costs))
(load load (cdr load)) (load load (cdr load))
(n 0 (1+ i))) (n 0 (1+ n)))
((null costs) ((null costs)
(assert more-cost) (assert more-cost)
(values arg-p (values arg-p
(+ n (position-in #'tn-ref-across ref refs)) (+ n (position-in #'tn-ref-across ref refs) 1)
t t
more-cost more-cost
nil
nil)) nil))
(when (eq refs ref) (when (eq refs ref)
(return (let ((parse (vop-parse-or-lose (vop-info-name info))))
(values arg-p (multiple-value-bind
n (ccosts cscs)
nil (compute-loading-costs
(car costs) (elt (if arg-p
(car load))))))) (vop-parse-args parse)
(vop-parse-results parse))
n)
arg-p)
(return
(values arg-p
(1+ n)
nil
(car costs)
(car load)
(not (and (equalp ccosts (car costs))
(equalp cscs (car load))))))))))))
(if arg-p (if arg-p
(frob (vop-args vop) (vop-info-arg-costs info) (frob (vop-args vop) (vop-info-arg-costs info)
(vop-info-arg-load-scs info) (vop-info-arg-load-scs info)
...@@ -87,14 +102,13 @@ ...@@ -87,14 +102,13 @@
(defun bad-costs-error (ref) (defun bad-costs-error (ref)
(declare (type tn-ref ref)) (declare (type tn-ref ref))
(let* ((tn (tn-ref-tn ref)) (let* ((tn (tn-ref-tn ref))
(vop (tn-ref-vop ref))
(ptype (tn-primitive-type tn))) (ptype (tn-primitive-type tn)))
(multiple-value-bind (arg-p pos more-p costs load-scs) (multiple-value-bind (arg-p pos more-p costs load-scs incon)
(get-operand-info ref) (get-operand-info ref)
(collect ((losers)) (collect ((losers))
(dolist (sc (primitive-type-scs ptype)) (dolist (scn (primitive-type-scs ptype))
(unless (svref costs (sc-number sc)) (unless (svref costs scn)
(losers sc))) (losers (svref *sc-numbers* scn))))
(unless (losers) (unless (losers)
(error "Representation selection flamed out for no obvious reason.~@ (error "Representation selection flamed out for no obvious reason.~@
...@@ -103,47 +117,88 @@ ...@@ -103,47 +117,88 @@
(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@ (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@ ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
~:[which cannot be coerced or loaded into the allowed SCs:~ ~:[which cannot be coerced or loaded into the allowed SCs:~
~% ~S~;~]" ~% ~S~;~]~:[~;~@
Current cost info inconsistent with that in effect at compile ~
time. Recompile.~%Compilation order may be incorrect.~]"
tn pos arg-p tn pos arg-p
(template-name info) (template-name (vop-info (tn-ref-vop ref)))
(primitive-type-name ptype) (primitive-type-name ptype)
(mapcar #'sc-name losers) (mapcar #'sc-name (losers))
more-p more-p
(mapcar #'sc-name (listify-restrictions load-scs))))))) (mapcar #'sc-name (listify-restrictions load-scs))
incon)))))
;;; BAD-MOVE-ARG-ERROR -- Internal ;;; BAD-MOVE-ARG-ERROR -- Internal
;;; ;;;
(defun bad-move-arg-error (val pass) (defun bad-move-arg-error (val pass)
(declare (type tn val pass)) (declare (type tn val pass))
(error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to (error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~
~S (SC ~S.)" ~S (SC ~S.)"
val (sc-name (tn-sc val)) val (sc-name (tn-sc val))
pass (sc-name (tn-sc pass)))) pass (sc-name (tn-sc pass))))
;;;; VM Consistency Checking:
;;;
;;; We do some checking of the consistency of the VM definition at load
;;; time.
;;; CHECK-MOVE-FUNCTION-CONSISTENCY -- Interface
;;;
(defun check-move-function-consistency ()
(dotimes (i sc-number-limit)
(let ((sc (svref *sc-numbers* i)))
(when sc
(let ((moves (sc-load-functions sc)))
(dolist (const (sc-constant-scs sc))
(unless (svref moves (sc-number const))
(error "No move function defined to load SC ~S from constant ~
SC ~S."
(sc-name sc) (sc-name const))))
(dolist (alt (sc-alternate-scs sc))
(unless (svref moves (sc-number alt))
(error "No move function defined to load SC ~S from alternate ~
SC ~S."
(sc-name sc) (sc-name alt)))
(unless (svref (sc-load-functions alt) i)
(error "No move function defined to save SC ~S to alternate ~
SC ~S."
(sc-name sc) (sc-name alt)))))))))
;;;
(check-move-function-consistency)
;;; SELECT-TN-REPRESENTATION -- Internal ;;; SELECT-TN-REPRESENTATION -- Internal
;;; ;;;
;;; Return the best representation for a normal TN. SCs is a list of the SC ;;; Return the best representation for a normal TN. SCs is a list of the SC
;;; numbers of the SCs to select from. Costs is a scratch vector. ;;; numbers of the SCs to select from. Costs is a scratch vector.
;;; ;;;
;;; What we do is sum the costs for each reference to TN in each of the
;;; SCs, and then return the SC having the lowest cost. We ignore references
;;; by the MOVE VOP, since counting them would spuriously encourage descriptor
;;; representations. We won't actually need to coerce to descriptor and back,
;;; since we will replace the MOVE with a specialized move VOP.
;;;
(defun select-tn-representation (tn scs costs) (defun select-tn-representation (tn scs costs)
(declare (type tn tn) (type sc-vector costs)) (declare (type tn tn) (type sc-vector costs))
(dolist (scn scs) (dolist (scn scs)
(setf (svref costs scn) 0)) (setf (svref costs scn) 0))
(macrolet ((scan-refs (refs ops-slot costs-slot more-costs-slot) (macrolet ((scan-refs (refs ops-slot costs-slot more-costs-slot)
`(do ((ref ,refs (tn-ref-next ref))) `(do ((ref ,refs (tn-ref-next ref)))
((null ref)) ((null ref))
(let* ((vop (tn-ref-vop ref)) (let* ((vop (tn-ref-vop ref))
(info (vop-info vop))) (info (vop-info vop)))
(do ((cost (,costs-slot info) (cdr cost)) (unless (eq (vop-info-name info) 'move)
(op (,ops-slot vop) (tn-ref-across op))) (do ((cost (,costs-slot info) (cdr cost))
((null cost) (op (,ops-slot vop) (tn-ref-across op)))
(add-costs (,more-costs-slot info))) ((null cost)
(when (eq op ref) (add-costs (,more-costs-slot info)))
(add-costs (car cost)) (when (eq op ref)
(return)))))) (add-costs (car cost))
(return)))))))
(add-costs (cost) (add-costs (cost)
`(let ((cost ,cost)) `(let ((cost ,cost))
(dolist (scn scs) (dolist (scn scs)
...@@ -163,7 +218,7 @@ ...@@ -163,7 +218,7 @@
(let ((cost (svref costs scn))) (let ((cost (svref costs scn)))
(when (< cost min) (when (< cost min)
(setq min cost) (setq min cost)
(setq min-scs scn)))) (setq min-scn scn))))
(svref *sc-numbers* min-scn))) (svref *sc-numbers* min-scn)))
...@@ -171,24 +226,24 @@ ...@@ -171,24 +226,24 @@
;;; NOTE-NUMBER-STACK-TN -- Internal ;;; NOTE-NUMBER-STACK-TN -- Internal
;;; ;;;
;;; Prepare for the possibility of a TN being allocated on the number stack ;;; Prepare for the possibility of a TN being allocated on the number stack
;;; by allocating a number-FP in all functions that TN is referenced in and in ;;; by setting NUMBER-STACK-P in all functions that TN is referenced in and in
;;; all the functions in their tail sets. Refs is a TN-Refs list of references ;;; all the functions in their tail sets. Refs is a TN-Refs list of references
;;; to the TN. ;;; to the TN.
;;; ;;;
(defun note-number-stack-tn (refs) (defun note-number-stack-tn (refs)
(declare (type (or tn-ref null) refs)) (declare (type (or tn-ref null) refs))
(do ((ref refs (tn-ref-next refs))) (do ((ref refs (tn-ref-next refs)))
((null ref)) ((null ref))
(let* ((lambda (block-lambda (let* ((lambda (block-lambda
(ir2-block-block (ir2-block-block
(vop-block (tn-ref-fop ref))))) (vop-block (tn-ref-vop ref)))))
(tails (lambda-tail-set lambda))) (tails (lambda-tail-set lambda)))
(flet ((frob (fun) (flet ((frob (fun)
(let ((env (lambda-environment lambda)) (setf (ir2-environment-number-stack-p
(2env (environment-info env))) (environment-info
(unless (ir2-environment-number-fp 2env) (lambda-environment fun)))
(setf (ir2-environment-number-fp 2env) t)))
(make-number-fp-tn env))))))
(frob lambda) (frob lambda)
(when tails (when tails
(dolist (fun (tail-set-functions tails)) (dolist (fun (tail-set-functions tails))
...@@ -197,31 +252,6 @@ ...@@ -197,31 +252,6 @@
(undefined-value)) (undefined-value))
;;; ALLOCATE-OLD-NUMBER-FP-TNS -- Internal
;;;
;;; Allocate Old-Number-FP and Old-Number-FP-Pass TNs for all functions in
;;; tail sets that have locations which might be allocated on the number stack.
;;;
(defun allocate-old-number-fp-tns (component)
(dolist (fun (component-lambdas component))
(let* ((env (lambda-environment fun))
(2env (environment-info env)))
(unless (ir2-environment-old-number-fp 2env)
(let ((tails (lambda-tail-set fun)))
(when tails
(let ((info (tail-set-info tails)))
(when (eq (return-info-kind info) :fixed)
(dolist (loc (return-info-locations ))
(when (sc-number-stack-p (tn-sc loc))
(setf (ir2-environment-old-number-fp 2env)
(make-normal-tn *any-primitive-type*))
(setf (ir2-environment-old-number-fp-pass 2env)
(make-normal-tn *any-primitive-type*))
(return))))))))))
(undefined-value))
;;; 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 or die trying. SCS is the operand's LOAD-SCS
...@@ -234,6 +264,9 @@ ...@@ -234,6 +264,9 @@
;;; SC. If we find such a VOP, then we make a TN having the load SC as the ;;; SC. If we find such a VOP, then we make a TN having the load SC as the
;;; representation. ;;; representation.
;;; ;;;
;;; 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.
;;;
(defun emit-coerce-vop (op scs) (defun emit-coerce-vop (op scs)
(declare (type tn-ref op) (type sc-vector scs)) (declare (type tn-ref op) (type sc-vector scs))
(let* ((op-tn (tn-ref-tn op)) (let* ((op-tn (tn-ref-tn op))
...@@ -252,9 +285,12 @@ ...@@ -252,9 +285,12 @@
(when res (when res
(let ((temp (make-representation-tn i))) (let ((temp (make-representation-tn i)))
(change-tn-ref-tn op temp) (change-tn-ref-tn op temp)
(if write-p (cond
(emit-move-template node block res temp op-tn vop) ((not write-p)
(emit-move-template node block res op-tn temp vop))) (emit-move-template node block res op-tn temp vop))
((null (tn-reads op-tn)))
(t
(emit-move-template node block res temp op-tn (vop-next vop)))))
(return))))))) (return)))))))
...@@ -277,6 +313,50 @@ ...@@ -277,6 +313,50 @@
(scan (vop-results vop) (vop-info-result-load-scs info))))) (scan (vop-results vop) (vop-info-result-load-scs info)))))
;;; EMIT-ARG-MOVES -- Internal
;;;
(defun emit-arg-moves (vop)
(let* ((info (vop-info vop))
(node (vop-node vop))
(block (vop-block vop))
(how (vop-info-move-args info))
(args (vop-args vop))
(fp-tn (tn-ref-tn args))
(nfp-tn (if (eq how :local-call)
(tn-ref-tn (tn-ref-across args))
nil))
(pass-locs (first (vop-codegen-info vop))))
(do ((val (do ((arg args (tn-ref-across arg))
(req (template-arg-types info) (cdr req)))
((null req) arg))
(tn-ref-across val))
(pass pass-locs (cdr pass)))
((null val)
(assert (null pass)))
(let* ((val-tn (tn-ref-tn val))
(pass-tn (first pass))
(pass-sc (tn-sc pass-tn))
(res (svref (sc-move-arg-vops pass-sc)
(sc-number (tn-sc val-tn)))))
(unless res
(bad-move-arg-error val-tn pass-tn))
(let ((this-fp
(cond ((not (sc-number-stack-p pass-sc)) fp-tn)
(nfp-tn)
(t
(assert (eq how :known-return))
(setq nfp-tn
(make-representation-tn
(first (primitive-type-scs
*any-primitive-type*))))
(emit-context-template node block nfp-tn vop)
nfp-tn))))
(emit-move-arg-template node block res val-tn this-fp pass-tn vop)))))
(undefined-value))
;;; EMIT-MOVES-AND-COERCIONS -- Internal ;;; EMIT-MOVES-AND-COERCIONS -- Internal
;;; ;;;
;;; Scan the IR2 looking for move operations that need to be replaced with ;;; Scan the IR2 looking for move operations that need to be replaced with
...@@ -290,39 +370,21 @@ ...@@ -290,39 +370,21 @@
(let ((info (vop-info vop)) (let ((info (vop-info vop))
(node (vop-node vop)) (node (vop-node vop))
(block (vop-block vop))) (block (vop-block vop)))
(case (vop-info-name info) (cond
(move-arguments ((eq (vop-info-name info) 'move)
(let* ((info-args (vop-codegen-info vop)) (let* ((x (tn-ref-tn (vop-args vop)))
(fp-tn (first info-args))
(nfp-tn (second info-args))
(pass-locs (third (info-args))))
(do ((val (vop-args vop) (tn-ref-across val))
(pass pass-locs (cdr pass-loc)))
((null val))
(let* ((val-tn (tn-ref-tn val))
(pass-tn (first pass))
(pass-sc (tn-sc pass-tn))
(res (svref (sc-move-arg-vops pass-sc)
(sc-number (tn-sc val-tn)))))
(unless res
(bad-move-arg-error val-tn pass-tn))
(emit-move-arg-template node block res val-tn
(if (sc-number-stack-p pass-sc)
nfp-tn fp-tn)
pass-tn
vop)))))
(move
(let ((x (tn-ref-tn (vop-args op)))
(y (tn-ref-tn (vop-results vop))) (y (tn-ref-tn (vop-results vop)))
(res (svref (sc-move-vops (tn-sc y)) (res (svref (sc-move-vops (tn-sc y))
(sc-number (tn-sc x))))) (sc-number (tn-sc x)))))
(cond (res (cond (res
(emit-move-template node block res x y vop) (emit-move-template node block res x y vop)
(delete-vop vop)) (delete-vop vop))
(t (t
(coerce-vop-operands vop))))) (coerce-vop-operands vop)))))
(t ((vop-info-move-args info)
(coerce-vop-operands vop)))))) (emit-arg-moves vop))
(t
(coerce-vop-operands vop))))))
;;; SELECT-REPRESENTATIONS -- Interface ;;; SELECT-REPRESENTATIONS -- Interface
...@@ -334,20 +396,25 @@ ...@@ -334,20 +396,25 @@
;;; return values on the number stack. Finally, we scan the IR2 looking for ;;; return values on the number stack. Finally, we scan the IR2 looking for
;;; places that we need to insert coercions and representation-specific moves. ;;; places that we need to insert coercions and representation-specific moves.
;;; ;;;
;;; We ignore TNs that already have a SC (representation is predetermined.)
;;;
(defun select-representations (component) (defun select-representations (component)
(let ((costs (make-array sc-number-limit))) (let ((costs (make-array sc-number-limit))
(do ((tn (ir2-component-normal-tns (component-info component)) (2comp (component-info component)))
(tn-next tn))) (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
((null tn)) ((null tn))
(let* ((scs (primitive-type-scs (tn-primitive-type tn))) (unless (tn-sc tn)
(sc (if (rest scs) (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
(select-tn-representation tn scs costs) (sc (if (rest scs)
(svref *sc-numbers* (first scs))))) (select-tn-representation tn scs costs)
(setf (tn-sc tn) sc) (svref *sc-numbers* (first scs)))))
(when (sc-number-stack-p tn) (assert sc)
(note-number-stack-tn tn))))) (setf (tn-sc tn) sc)
(when (sc-number-stack-p sc)
(allocate-old-number-fp-tns component) (unless (ir2-component-nfp 2comp)
(setf (ir2-component-nfp 2comp) (make-nfp-tn)))
(note-number-stack-tn (tn-reads tn))
(note-number-stack-tn (tn-writes tn)))))))
(do-ir2-blocks (block component) (do-ir2-blocks (block component)
(emit-moves-and-coercions block)) (emit-moves-and-coercions block))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment