1.0.45.22: non-racy RUN-PROGRAM :PTY on OpenBSD
[sbcl.git] / src / compiler / ir2opt.lisp
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.
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
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.
13
14 (in-package "SB!C")
15
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*)
22
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)))
28                  (nil)
29                (let ((next (ir2-block-next 2block)))
30                  (when (or (null next)
31                            (neq block (ir2-block-block next)))
32                    (return 2block)))))
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)))
40         (dolist (succ succ)
41           (link-2blocks last (block-info succ)))
42         (do ((2block (block-info block)
43                (ir2-block-next 2block)))
44             ((eq 2block last))
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)))))
49
50 (defun update-block-succ (2block succ)
51   (declare (type ir2-block 2block)
52            (type list succ))
53   (flet ((blockify (x)
54            (etypecase x
55              (label (or (gethash x *label-2block*)
56                         (error "Unknown label: ~S" x)))
57              (ir2-block 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)
63   (dolist (new succ)
64     (pushnew 2block (gethash new *2block-pred*))))
65
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)))
71     (if vop-info
72         (vop-info-name vop-info)
73         default)))
74
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)
81                (or (not second)
82                    (eq (vop-name second) 'branch)))
83       (values (tn-ref-tn (vop-args first))
84               (tn-ref-tn (vop-results first))))))
85
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.
89 ;;
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,
92 ;; second otherwise)
93 (defun cmovp (label a b)
94   (declare (type label label)
95            (type cblock a b))
96   (cond ((eq label (ir2-block-%label (block-info a))))
97         ((eq label (ir2-block-%label (block-info b)))
98          (rotatef a 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)
103                  (singleton-p succ-b)
104                  (eq (car succ-a) (car succ-b)))
105       (return-from cmovp))
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))))))
113
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
122                          value-if arg-if
123                          value-else arg-else
124                          target res
125                          flags info
126                          label
127                          vop node 2block)
128   (delete-vop vop)
129   (flet ((load-and-coerce (dst src)
130            (when (and dst (neq dst src))
131              (let ((end  (ir2-block-last-vop 2block))
132                    (move (template-or-lose 'move)))
133                (multiple-value-bind (first last)
134                    (funcall (template-emit-function move) node 2block
135                             move (reference-tn src nil)
136                             (reference-tn dst t))
137                  (insert-vop-sequence first last 2block end))))))
138     (load-and-coerce arg-if   value-if)
139     (load-and-coerce arg-else value-else))
140   (emit-template node 2block (template-or-lose cmove-vop)
141                  (reference-tn-list (remove nil (list arg-if arg-else))
142                                     nil)
143                  (reference-tn res t)
144                  (list* flags info))
145   (emit-move node 2block res target)
146   (vop branch node 2block label)
147   (update-block-succ 2block (list label)))
148
149 ;; Since conditional branches are always at the end of blocks,
150 ;; it suffices to look at the last VOP in each block.
151 (defun maybe-convert-one-cmov (2block)
152   (let* ((block (ir2-block-block 2block))
153          (succ (block-succ block))
154          (a    (first succ))
155          (b    (second succ))
156          (vop  (or (ir2-block-last-vop 2block)
157                    (return-from maybe-convert-one-cmov)))
158          (node (vop-node vop)))
159     (unless (eq (vop-name vop) 'branch-if)
160       (return-from maybe-convert-one-cmov))
161     (destructuring-bind (jump-target flags not-p) (vop-codegen-info vop)
162       (multiple-value-bind (label target value-a value-b)
163           (cmovp jump-target a b)
164         (unless label
165           (return-from maybe-convert-one-cmov))
166         (multiple-value-bind (cmove-vop arg-a arg-b res info)
167             (convert-conditional-move-p node target value-a value-b)
168           (unless cmove-vop
169             (return-from maybe-convert-one-cmov))
170           (when not-p
171             (rotatef value-a value-b)
172             (rotatef arg-a arg-b))
173           (convert-one-cmov cmove-vop value-a arg-a
174                                       value-b arg-b
175                                       target  res
176                                       flags info
177                             label vop node 2block))))))
178
179 (defun convert-cmovs (component)
180   (do-ir2-blocks (2block component (values))
181     (maybe-convert-one-cmov 2block)))
182
183 (defun delete-unused-ir2-blocks (component)
184   (declare (type component component))
185   (let ((live-2blocks (make-hash-table)))
186     (labels ((mark-2block (2block)
187                (declare (type ir2-block 2block))
188                (when (gethash 2block live-2blocks)
189                  (return-from mark-2block))
190                (setf (gethash 2block live-2blocks) t)
191                (map nil #'mark-2block (gethash 2block *2block-succ*))))
192       (mark-2block (block-info (component-head component))))
193
194     (flet ((delete-2block (2block)
195              (declare (type ir2-block 2block))
196              (do ((vop (ir2-block-start-vop 2block)
197                     (vop-next vop)))
198                  ((null vop))
199                (delete-vop vop))))
200       (do-ir2-blocks (2block component (values))
201         (unless (gethash 2block live-2blocks)
202           (delete-2block 2block))))))
203
204 (defun delete-fall-through-jumps (component)
205   (flet ((jump-falls-through-p (2block)
206            (let* ((last   (or (ir2-block-last-vop 2block)
207                               (return-from jump-falls-through-p nil)))
208                   (target (first (vop-codegen-info last))))
209              (unless (eq (vop-name last) 'branch)
210                (return-from jump-falls-through-p nil))
211              (do ((2block (ir2-block-next 2block)
212                     (ir2-block-next 2block)))
213                  ((null 2block) nil)
214                (cond ((eq target (ir2-block-%label 2block))
215                       (return t))
216                      ((ir2-block-start-vop 2block)
217                       (return nil)))))))
218     ;; Walk the blocks in reverse emission order to catch jumps
219     ;; that fall-through only once another jump is deleted
220     (let ((last-2block
221            (do-ir2-blocks (2block component (aver nil))
222              (when (null (ir2-block-next 2block))
223                (return 2block)))))
224       (do ((2block last-2block
225              (ir2-block-prev 2block)))
226           ((null 2block)
227              (values))
228         (when (jump-falls-through-p 2block)
229           (delete-vop (ir2-block-last-vop 2block)))))))
230
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)
236
237     (convert-cmovs component)
238     (delete-unused-ir2-blocks component)
239     (delete-fall-through-jumps component))
240   (values))