From: Paul K. <pk...@us...> - 2009-01-11 18:33:40
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv426/src/compiler Modified Files: backend.lisp debug.lisp ir1-translators.lisp ir2tran.lisp ltn.lisp main.lisp meta-vmdef.lisp vmdef.lisp vop.lisp Added Files: ir2opt.lisp Log Message: 1.0.24.34: IR2: additional representation for predicates, conditional moves * :CONDITIONAL VOPs can now specify how to interpret the test they compute without performing the branch directly. How the test is specified is completely platform-dependent and only affects new-style :CONDITIONAL VOPs and a new BRANCH-IF VOP (src/compiler/$ARCH/pred.lisp). * Candidates for conversion to conditional moves are found and may be converted, depending on CONVERT-CONDITIONAL-MOVE-P, a new VM support routine. C-C-M-P returns NIL to punt on the conversion, or 5 values: 1. name of the VOP to use 2. TN for the first argument (NIL if none) 3. TN for the second argument (NIL if none) 4. TN for the result 5. A list of info data, which will be appended to the flags The correct values will be MOVEd in the argument TNs if needed before computing the condition, and the result MOVEd to the right TN after the conditional move VOP. --- NEW FILE: ir2opt.lisp --- ;;;; This file implements some optimisations at the IR2 level. ;;;; Currently, the pass converts branches to conditional moves, ;;;; deletes subsequently dead blocks and then reoptimizes jumps. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!C") ;;; We track pred/succ info at the IR2-block level, extrapolating ;;; most of the data from IR1 to initialise. (declaim (type hash-table *2block-pred* *2block-succ* *label-2block*)) (defvar *2block-pred*) (defvar *2block-succ*) (defvar *label-2block*) (defun initialize-ir2-blocks-flow-info (component) (labels ((block-last-2block (block) (declare (type cblock block)) (do ((2block (block-info block) (ir2-block-next 2block))) (nil) (let ((next (ir2-block-next 2block))) (when (or (null next) (neq block (ir2-block-block next))) (return 2block))))) (link-2blocks (pred succ) (declare (type ir2-block pred succ)) (pushnew pred (gethash succ *2block-pred*)) (pushnew succ (gethash pred *2block-succ*)))) (do-blocks (block component :both) (let ((succ (block-succ block)) (last (block-last-2block block))) (dolist (succ succ) (link-2blocks last (block-info succ))) (do ((2block (block-info block) (ir2-block-next 2block))) ((eq 2block last)) (link-2blocks 2block (ir2-block-next 2block))))) (do-ir2-blocks (2block component) (awhen (ir2-block-%label 2block) (setf (gethash it *label-2block*) 2block))))) (defun update-block-succ (2block succ) (declare (type ir2-block 2block) (type list succ)) (flet ((blockify (x) (etypecase x (label (or (gethash x *label-2block*) (error "Unknown label: ~S" x))) (ir2-block x)))) (setf succ (mapcar #'blockify succ))) (dolist (old (gethash 2block *2block-succ*)) (setf (gethash old *2block-pred*) (remove 2block (gethash old *2block-pred*)))) (setf (gethash 2block *2block-succ*) succ) (dolist (new succ) (pushnew 2block (gethash new *2block-pred*)))) ;;;; Conditional move insertion support code #!-sb-fluid (declaim (inline vop-name)) (defun vop-name (vop &optional default) (declare (type vop vop)) (let ((vop-info (vop-info vop))) (if vop-info (vop-info-name vop-info) default))) (defun move-value-target (2block) (declare (type ir2-block 2block)) (let* ((first (or (ir2-block-start-vop 2block) (return-from move-value-target))) (second (vop-next first))) (when (and (eq (vop-name first) 'move) (or (not second) (eq (vop-name second) 'branch))) (values (tn-ref-tn (vop-args first)) (tn-ref-tn (vop-results first)))))) ;; A conditional jump may be converted to a conditional move if ;; both branches move a value to the same TN and then continue ;; execution in the same successor block. ;; ;; The label argument is used to return possible value TNs in ;; the right order (first TN if the branch would have been taken, ;; second otherwise) (defun cmovp (label a b) (declare (type label label) (type cblock a b)) (cond ((eq label (ir2-block-%label (block-info a)))) ((eq label (ir2-block-%label (block-info b))) (rotatef a b)) (t (return-from cmovp))) (let ((succ-a (block-succ a)) (succ-b (block-succ b))) (unless (and (singleton-p succ-a) (singleton-p succ-b) (eq (car succ-a) (car succ-b))) (return-from cmovp)) (multiple-value-bind (value-a target) (move-value-target (block-info a)) (multiple-value-bind (value-b targetp) (move-value-target (block-info b)) (and value-a value-b (eq target targetp) (values (block-label (car succ-a)) target value-a value-b)))))) ;; To convert a branch to a conditional move: ;; 1. Convert both possible values to the chosen common representation ;; 2. Execute the conditional VOP ;; 3. Execute the chosen conditional move VOP ;; 4. Convert the result from the common representation ;; 5. Jump to the successor #!-sb-fluid (declaim (inline convert-one-cmov)) (defun convert-one-cmov (cmove-vop value-if arg-if value-else arg-else target res flags info label vop node 2block) (delete-vop vop) (flet ((load-and-coerce (dst src) (when (and dst (neq dst src)) (let ((end (ir2-block-last-vop 2block)) (move (template-or-lose 'move))) (multiple-value-bind (first last) (funcall (template-emit-function move) node 2block move (reference-tn src nil) (reference-tn dst t)) (insert-vop-sequence first last 2block end)))))) (load-and-coerce arg-if value-if) (load-and-coerce arg-else value-else)) (emit-template node 2block (template-or-lose cmove-vop) (reference-tn-list (remove nil (list arg-if arg-else)) nil) (reference-tn res t) (list* flags info)) (emit-move node 2block res target) (vop branch node 2block label) (update-block-succ 2block (list label))) ;; Since conditional branches are always at the end of blocks, ;; it suffices to look at the last VOP in each block. (defun maybe-convert-one-cmov (2block) (let* ((block (ir2-block-block 2block)) (succ (block-succ block)) (a (first succ)) (b (second succ)) (vop (or (ir2-block-last-vop 2block) (return-from maybe-convert-one-cmov))) (node (vop-node vop))) (unless (eq (vop-name vop) 'branch-if) (return-from maybe-convert-one-cmov)) (destructuring-bind (jump-target flags not-p) (vop-codegen-info vop) (multiple-value-bind (label target value-a value-b) (cmovp jump-target a b) (unless label (return-from maybe-convert-one-cmov)) (multiple-value-bind (cmove-vop arg-a arg-b res info) (convert-conditional-move-p node target value-a value-b) (unless cmove-vop (return-from maybe-convert-one-cmov)) (when not-p (rotatef value-a value-b) (rotatef arg-a arg-b)) (convert-one-cmov cmove-vop value-a arg-a value-b arg-b target res flags info label vop node 2block)))))) (defun convert-cmovs (component) (do-ir2-blocks (2block component (values)) (maybe-convert-one-cmov 2block))) (defun delete-unused-ir2-blocks (component) (declare (component component)) (let ((live-2blocks (make-hash-table))) (labels ((mark-2block (2block) (declare (type ir2-block 2block)) (when (gethash 2block live-2blocks) (return-from mark-2block)) (setf (gethash 2block live-2blocks) t) (map nil #'mark-2block (gethash 2block *2block-succ*)))) (mark-2block (block-info (component-head component)))) (flet ((delete-2block (2block) (declare (type ir2-block 2block)) (do ((vop (ir2-block-start-vop 2block) (vop-next vop))) ((null vop)) (delete-vop vop)))) (do-ir2-blocks (2block component (values)) (unless (gethash 2block live-2blocks) (delete-2block 2block)))))) (defun delete-fall-through-jumps (component) (flet ((jump-falls-through-p (2block) (let* ((last (or (ir2-block-last-vop 2block) (return-from jump-falls-through-p nil))) (target (first (vop-codegen-info last)))) (unless (eq (vop-name last) 'branch) (return-from jump-falls-through-p nil)) (do ((2block (ir2-block-next 2block) (ir2-block-next 2block))) ((null 2block) nil) (cond ((eq target (ir2-block-%label 2block)) (return t)) ((ir2-block-start-vop 2block) (return nil))))))) ;; Walk the blocks in reverse emission order to catch jumps ;; that fall-through only once another jump is deleted (let ((last-2block (do-ir2-blocks (2block component (aver nil)) (when (null (ir2-block-next 2block)) (return 2block))))) (do ((2block last-2block (ir2-block-prev 2block))) ((null 2block) (values)) (when (jump-falls-through-p 2block) (delete-vop (ir2-block-last-vop 2block))))))) (defun ir2-optimize (component) (let ((*2block-pred* (make-hash-table)) (*2block-succ* (make-hash-table)) (*label-2block* (make-hash-table))) (initialize-ir2-blocks-flow-info component) (convert-cmovs component) (delete-unused-ir2-blocks component) (delete-fall-through-jumps component)) (values)) Index: backend.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/backend.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- backend.lisp 7 Feb 2006 03:32:02 -0000 1.21 +++ backend.lisp 11 Jan 2009 18:33:31 -0000 1.22 @@ -194,6 +194,9 @@ make-dynamic-state-tns make-nlx-entry-arg-start-location + ;; from pred.lisp + convert-conditional-move-p + ;; from support.lisp generate-call-sequence generate-return-sequence Index: debug.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug.lisp,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- debug.lisp 25 Jan 2007 15:51:34 -0000 1.40 +++ debug.lisp 11 Jan 2009 18:33:31 -0000 1.41 @@ -642,7 +642,7 @@ atypes) (template-more-args-type info) "args") (check-tn-refs (vop-results vop) vop t - (if (eq rtypes :conditional) 0 (length rtypes)) + (if (template-conditional-p info) 0 (length rtypes)) (template-more-results-type info) "results") (check-tn-refs (vop-temps vop) vop t 0 t "temps") (unless (= (length (vop-codegen-info vop)) Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- ir1-translators.lisp 31 Jul 2008 12:52:38 -0000 1.88 +++ ir1-translators.lisp 11 Jan 2009 18:33:31 -0000 1.89 @@ -449,7 +449,7 @@ nargs min))) - (when (eq (template-result-types template) :conditional) + (when (template-conditional-p template) (bug "%PRIMITIVE was used with a conditional template.")) (when (template-more-results-type template) Index: ir2tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v retrieving revision 1.77 retrieving revision 1.78 diff -u -d -r1.77 -r1.78 --- ir2tran.lisp 18 Oct 2008 15:26:06 -0000 1.77 +++ ir2tran.lisp 11 Jan 2009 18:33:31 -0000 1.78 @@ -571,16 +571,28 @@ (declare (type node node) (type ir2-block block) (type template template) (type (or tn-ref null) args) (list info-args) (type cif if) (type boolean not-p)) - (aver (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) - (alternative (if-alternative if))) - (cond ((drop-thru-p if consequent) + (alternative (if-alternative if)) + (flags (and (consp (template-result-types template)) + (rest (template-result-types template))))) + (aver (= (template-info-arg-count template) + (+ (length info-args) + (if flags 0 2)))) + (when not-p + (rotatef consequent alternative) + (setf not-p nil)) + (when (drop-thru-p if consequent) + (rotatef consequent alternative) + (setf not-p t)) + (cond ((not flags) (emit-template node block template args nil - (list* (block-label alternative) (not not-p) - info-args))) + (list* (block-label consequent) not-p + info-args)) + (unless (drop-thru-p if alternative) + (vop branch node block (block-label alternative)))) (t - (emit-template node block template args nil - (list* (block-label consequent) not-p info-args)) + (emit-template node block template args nil info-args) + (vop branch-if node block (block-label consequent) flags not-p) (unless (drop-thru-p if alternative) (vop branch node block (block-label alternative))))))) @@ -648,7 +660,7 @@ (multiple-value-bind (args info-args) (reference-args call block (combination-args call) template) (aver (not (template-more-results-type template))) - (if (eq rtypes :conditional) + (if (template-conditional-p template) (ir2-convert-conditional call block template args info-args (lvar-dest lvar) nil) (let* ((results (make-template-result-tns call lvar rtypes)) @@ -680,7 +692,7 @@ (multiple-value-bind (args info-args) (reference-args call block (cddr (combination-args call)) template) (aver (not (template-more-results-type template))) - (aver (not (eq rtypes :conditional))) + (aver (not (template-conditional-p template))) (aver (null info-args)) (if info Index: ltn.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ltn.lisp,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- ltn.lisp 12 Dec 2008 13:05:24 -0000 1.40 +++ ltn.lisp 11 Jan 2009 18:33:31 -0000 1.41 @@ -367,7 +367,7 @@ (unless (and (combination-p use) (let ((info (basic-combination-info use))) (and (template-p info) - (eq (template-result-types info) :conditional)))) + (template-conditional-p info)))) (annotate-ordinary-lvar test))) (values)) @@ -523,7 +523,7 @@ (if (and safe-p (template-args-ok template call nil)) :arg-check :arg-types))) - ((eq (template-result-types template) :conditional) + ((template-conditional-p template) (let ((dest (lvar-dest lvar))) (if (and (if-p dest) (immediately-used-p (if-test dest) call)) Index: main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v retrieving revision 1.138 retrieving revision 1.139 diff -u -d -r1.138 -r1.139 --- main.lisp 3 Jan 2009 17:05:45 -0000 1.138 +++ main.lisp 11 Jan 2009 18:33:31 -0000 1.139 @@ -459,6 +459,8 @@ (maybe-mumble "copy ") (copy-propagate component)) + (ir2-optimize component) + (select-representations component) (when *check-consistency* Index: meta-vmdef.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/meta-vmdef.lisp,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- meta-vmdef.lisp 12 Dec 2007 12:19:44 -0000 1.39 +++ meta-vmdef.lisp 11 Jan 2009 18:33:32 -0000 1.40 @@ -389,7 +389,9 @@ (operands nil :type list) ;; names of variables that should be declared IGNORE (ignores () :type list) - ;; true if this is a :CONDITIONAL VOP + ;; true if this is a :CONDITIONAL VOP. T if a branchful VOP, + ;; a list of condition descriptor otherwise. See $ARCH/pred.lisp + ;; for more information. (conditional-p nil) ;; argument and result primitive types. These are pulled out of the ;; operands, since we often want to change them without respecifying @@ -1083,7 +1085,7 @@ (setf (vop-parse-result-types parse) ()) (setf (vop-parse-results parse) ()) (setf (vop-parse-more-results parse) nil) - (setf (vop-parse-conditional-p parse) t)) + (setf (vop-parse-conditional-p parse) (or (rest spec) t))) (:temporary (parse-temporary spec parse)) (:generator @@ -1460,9 +1462,12 @@ `(:type (specifier-type '(function () nil)) :arg-types (list ,@(mapcar #'make-operand-type args)) :more-args-type ,(when more-args (make-operand-type more-arg)) - :result-types ,(if conditional - :conditional - `(list ,@(mapcar #'make-operand-type results))) + :result-types ,(cond ((eq conditional t) + :conditional) + (conditional + `'(:conditional . ,conditional)) + (t + `(list ,@(mapcar #'make-operand-type results)))) :more-results-type ,(when more-results (make-operand-type more-result))))) @@ -1572,7 +1577,7 @@ ;;; (:ARGUMENT N)/(:RESULT N). These options are necessary ;;; primarily when operands are read or written out of order. ;;; -;;; :CONDITIONAL +;;; :CONDITIONAL [Condition-descriptor+] ;;; This is used in place of :RESULTS with conditional branch VOPs. ;;; There are no result values: the result is a transfer of control. ;;; The target label is passed as the first :INFO arg. The second @@ -1580,6 +1585,10 @@ ;;; A side effect is to set the PREDICATE attribute for functions ;;; in the :TRANSLATE option. ;;; +;;; If some condition descriptors are provided, this is a flag-setting +;;; VOP. Descriptors are interpreted in an architecture-dependent +;;; manner. See the BRANCH-IF VOP in $ARCH/pred.lisp. +;;; ;;; :TEMPORARY ({Key Value}*) Name* ;;; Allocate a temporary TN for each Name, binding that variable to ;;; the TN within the body of the generators. In addition to :TARGET Index: vmdef.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/vmdef.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- vmdef.lisp 14 Jul 2005 18:57:02 -0000 1.14 +++ vmdef.lisp 11 Jan 2009 18:33:32 -0000 1.15 @@ -219,7 +219,7 @@ (let* ((args (convert (template-arg-types template) (template-more-args-type template))) (result-restr (template-result-types template)) - (results (if (eq result-restr :conditional) + (results (if (template-conditional-p template) '(boolean) (convert result-restr (cond ((template-more-results-type template)) @@ -229,3 +229,10 @@ ,(if (= (length results) 1) (first results) `(values ,@results)))))) + +#!-sb-fluid (declaim (inline template-conditional-p)) +(defun template-conditional-p (template) + (declare (type template template)) + (let ((rtypes (template-result-types template))) + (or (eq rtypes :conditional) + (eq (car rtypes) :conditional)))) Index: vop.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/vop.lisp,v retrieving revision 1.43 retrieving revision 1.44 diff -u -d -r1.43 -r1.44 --- vop.lisp 19 Sep 2008 20:22:18 -0000 1.43 +++ vop.lisp 11 Jan 2009 18:33:32 -0000 1.44 @@ -559,8 +559,12 @@ ;; conditional that yields its result as a control transfer. The ;; emit function takes two info arguments: the target label and a ;; boolean flag indicating whether to negate the sense of the test. + ;; + ;; If RESULT-TYPES is a cons whose car is :CONDITIONAL, then this is + ;; a flag-setting VOP. The rest is a list of condition descriptors to + ;; be interpreted by the BRANCH-IF VOP (see $ARCH/pred.lisp). (arg-types nil :type list) - (result-types nil :type (or list (member :conditional))) + (result-types nil :type (or list (member :conditional) (cons (eql :conditional)))) ;; the primitive type restriction applied to each extra argument or ;; result following the fixed operands. If NIL, no extra ;; args/results are allowed. Otherwise, either * or a (:OR ...) list |