1 ;;;; This file implements some optimisations at the IR2 level.
2 ;;;; Currently, the pass converts branches to conditional moves,
3 ;;;; deletes subsequently dead blocks and then reoptimizes jumps.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
16 ;;; We track pred/succ info at the IR2-block level, extrapolating
17 ;;; most of the data from IR1 to initialise.
18 (declaim (type hash-table
*2block-pred
* *2block-succ
* *label-2block
*))
19 (defvar *2block-pred
*)
20 (defvar *2block-succ
*)
21 (defvar *label-2block
*)
23 (defun initialize-ir2-blocks-flow-info (component)
24 (labels ((block-last-2block (block)
25 (declare (type cblock block
))
26 (do ((2block (block-info block
)
27 (ir2-block-next 2block
)))
29 (let ((next (ir2-block-next 2block
)))
31 (neq block
(ir2-block-block next
)))
33 (link-2blocks (pred succ
)
34 (declare (type ir2-block pred succ
))
35 (pushnew pred
(gethash succ
*2block-pred
*))
36 (pushnew succ
(gethash pred
*2block-succ
*))))
37 (do-blocks (block component
:both
)
38 (let ((succ (block-succ block
))
39 (last (block-last-2block block
)))
41 (link-2blocks last
(block-info succ
)))
42 (do ((2block (block-info block
)
43 (ir2-block-next 2block
)))
45 (link-2blocks 2block
(ir2-block-next 2block
)))))
46 (do-ir2-blocks (2block component
)
47 (awhen (ir2-block-%label
2block
)
48 (setf (gethash it
*label-2block
*) 2block
)))))
50 (defun update-block-succ (2block succ
)
51 (declare (type ir2-block
2block
)
55 (label (or (gethash x
*label-2block
*)
56 (error "Unknown label: ~S" x
)))
58 (setf succ
(mapcar #'blockify succ
)))
59 (dolist (old (gethash 2block
*2block-succ
*))
60 (setf (gethash old
*2block-pred
*)
61 (remove 2block
(gethash old
*2block-pred
*))))
62 (setf (gethash 2block
*2block-succ
*) succ
)
64 (pushnew 2block
(gethash new
*2block-pred
*))))
66 ;;;; Conditional move insertion support code
67 #!-sb-fluid
(declaim (inline vop-name
))
68 (defun vop-name (vop &optional default
)
69 (declare (type vop vop
))
70 (let ((vop-info (vop-info vop
)))
72 (vop-info-name vop-info
)
75 (defun move-value-target (2block)
76 (declare (type ir2-block
2block
))
77 (let* ((first (or (ir2-block-start-vop 2block
)
78 (return-from move-value-target
)))
79 (second (vop-next first
)))
80 (when (and (eq (vop-name first
) 'move
)
82 (eq (vop-name second
) 'branch
)))
83 (values (tn-ref-tn (vop-args first
))
84 (tn-ref-tn (vop-results first
))))))
86 ;; A conditional jump may be converted to a conditional move if
87 ;; both branches move a value to the same TN and then continue
88 ;; execution in the same successor block.
90 ;; The label argument is used to return possible value TNs in
91 ;; the right order (first TN if the branch would have been taken,
93 (defun cmovp (label a b
)
94 (declare (type label label
)
96 (cond ((eq label
(ir2-block-%label
(block-info a
))))
97 ((eq label
(ir2-block-%label
(block-info b
)))
99 (t (return-from cmovp
)))
100 (let ((succ-a (block-succ a
))
101 (succ-b (block-succ b
)))
102 (unless (and (singleton-p succ-a
)
104 (eq (car succ-a
) (car succ-b
)))
106 (multiple-value-bind (value-a target
)
107 (move-value-target (block-info a
))
108 (multiple-value-bind (value-b targetp
)
109 (move-value-target (block-info b
))
110 (and value-a value-b
(eq target targetp
)
111 (values (block-label (car succ-a
))
112 target value-a value-b
))))))
114 ;; To convert a branch to a conditional move:
115 ;; 1. Convert both possible values to the chosen common representation
116 ;; 2. Execute the conditional VOP
117 ;; 3. Execute the chosen conditional move VOP
118 ;; 4. Convert the result from the common representation
119 ;; 5. Jump to the successor
120 #!-sb-fluid
(declaim (inline convert-one-cmov
))
121 (defun convert-one-cmov (cmove-vop
129 (flet ((load-and-coerce (dst src
)
130 (when (and dst
(neq dst src
))
131 (emit-and-insert-vop node
2block
132 (template-or-lose 'move
)
133 (reference-tn src nil
)
135 (ir2-block-last-vop 2block
)))))
136 (load-and-coerce arg-if value-if
)
137 (load-and-coerce arg-else value-else
))
138 (emit-template node
2block
(template-or-lose cmove-vop
)
139 (reference-tn-list (remove nil
(list arg-if arg-else
))
143 (emit-move node
2block res target
)
144 (vop branch node
2block label
)
145 (update-block-succ 2block
(list label
)))
147 ;; Since conditional branches are always at the end of blocks,
148 ;; it suffices to look at the last VOP in each block.
149 (defun maybe-convert-one-cmov (2block)
150 (let* ((block (ir2-block-block 2block
))
151 (succ (block-succ block
))
154 (vop (or (ir2-block-last-vop 2block
)
155 (return-from maybe-convert-one-cmov
)))
156 (node (vop-node vop
)))
157 (unless (eq (vop-name vop
) 'branch-if
)
158 (return-from maybe-convert-one-cmov
))
159 (destructuring-bind (jump-target flags not-p
) (vop-codegen-info vop
)
160 (multiple-value-bind (label target value-a value-b
)
161 (cmovp jump-target a b
)
163 (return-from maybe-convert-one-cmov
))
164 (multiple-value-bind (cmove-vop arg-a arg-b res info
)
165 (convert-conditional-move-p node target value-a value-b
)
167 (return-from maybe-convert-one-cmov
))
169 (rotatef value-a value-b
)
170 (rotatef arg-a arg-b
))
171 (convert-one-cmov cmove-vop value-a arg-a
175 label vop node
2block
))))))
177 (defun convert-cmovs (component)
178 (do-ir2-blocks (2block component
(values))
179 (maybe-convert-one-cmov 2block
)))
181 (defun delete-unused-ir2-blocks (component)
182 (declare (type component component
))
183 (let ((live-2blocks (make-hash-table)))
184 (labels ((mark-2block (2block)
185 (declare (type ir2-block
2block
))
186 (when (gethash 2block live-2blocks
)
187 (return-from mark-2block
))
188 (setf (gethash 2block live-2blocks
) t
)
189 (map nil
#'mark-2block
(gethash 2block
*2block-succ
*))))
190 (mark-2block (block-info (component-head component
))))
192 (flet ((delete-2block (2block)
193 (declare (type ir2-block
2block
))
194 (do ((vop (ir2-block-start-vop 2block
)
198 (do-ir2-blocks (2block component
(values))
199 (unless (gethash 2block live-2blocks
)
200 (delete-2block 2block
))))))
202 (defun delete-fall-through-jumps (component)
203 (flet ((jump-falls-through-p (2block)
204 (let* ((last (or (ir2-block-last-vop 2block
)
205 (return-from jump-falls-through-p nil
)))
206 (target (first (vop-codegen-info last
))))
207 (unless (eq (vop-name last
) 'branch
)
208 (return-from jump-falls-through-p nil
))
209 (do ((2block (ir2-block-next 2block
)
210 (ir2-block-next 2block
)))
212 (cond ((ir2-block-%trampoline-label
2block
)
214 ((eq target
(ir2-block-%label
2block
))
216 ((ir2-block-start-vop 2block
)
218 ;; Walk the blocks in reverse emission order to catch jumps
219 ;; that fall-through only once another jump is deleted
221 (do-ir2-blocks (2block component
(aver nil
))
222 (when (null (ir2-block-next 2block
))
224 (do ((2block last-2block
225 (ir2-block-prev 2block
)))
228 (when (jump-falls-through-p 2block
)
229 (delete-vop (ir2-block-last-vop 2block
)))))))
231 (defun ir2-optimize (component)
232 (let ((*2block-pred
* (make-hash-table))
233 (*2block-succ
* (make-hash-table))
234 (*label-2block
* (make-hash-table)))
235 (initialize-ir2-blocks-flow-info component
)
237 (convert-cmovs component
)
238 (delete-unused-ir2-blocks component
)
239 (delete-fall-through-jumps component
))