1 ;;;; the implementation-independent parts of the code generator. We use
2 ;;;; functions and information provided by the VM definition to convert
3 ;;;; IR2 into assembly code. After emitting code, we finish the
4 ;;;; assembly and then do the post-assembly phase.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 ;;;; utilities used during code generation
19 ;;; the number of bytes used by the code object header
20 (defun component-header-length (&optional
21 (component *component-being-compiled
*))
22 (let* ((2comp (component-info component
))
23 (constants (ir2-component-constants 2comp
))
24 (num-consts (length constants
)))
25 (ash (logandc2 (1+ num-consts
) 1) sb
!vm
:word-shift
)))
27 ;;; the size of the NAME'd SB in the currently compiled component.
28 ;;; This is useful mainly for finding the size for allocating stack
30 (defun sb-allocated-size (name)
31 (finite-sb-current-size (sb-or-lose name
)))
33 ;;; the TN that is used to hold the number stack frame-pointer in
34 ;;; VOP's function, or NIL if no number stack frame was allocated
35 (defun current-nfp-tn (vop)
36 (unless (zerop (sb-allocated-size 'non-descriptor-stack
))
37 (let ((block (ir2-block-block (vop-block vop
))))
38 (when (ir2-physenv-number-stack-p
40 (block-physenv block
)))
41 (ir2-component-nfp (component-info (block-component block
)))))))
43 ;;; the TN that is used to hold the number stack frame-pointer in the
44 ;;; function designated by 2ENV, or NIL if no number stack frame was
46 (defun callee-nfp-tn (2env)
47 (unless (zerop (sb-allocated-size 'non-descriptor-stack
))
48 (when (ir2-physenv-number-stack-p 2env
)
49 (ir2-component-nfp (component-info *component-being-compiled
*)))))
51 ;;; the TN used for passing the return PC in a local call to the function
52 ;;; designated by 2ENV
53 (defun callee-return-pc-tn (2env)
54 (ir2-physenv-return-pc-pass 2env
))
56 ;;;; specials used during code generation
58 (defvar *code-segment
* nil
)
59 (defvar *elsewhere
* nil
)
60 (defvar *elsewhere-label
* nil
)
63 (defvar *constant-segment
* nil
)
64 (defvar *constant-table
* nil
)
65 (defvar *constant-vector
* nil
))
68 ;;;; noise to emit an instruction trace
70 (defvar *prev-segment
*)
73 (defun trace-instruction (segment vop inst
&rest args
)
74 (declare (dynamic-extent args
))
75 (let ((*standard-output
* *compiler-trace-output
*))
76 (unless (eq *prev-segment
* segment
)
77 (format t
"in the ~A segment:~%" (sb!assem
:segment-type segment
))
78 (setf *prev-segment
* segment
))
79 (unless (eq *prev-vop
* vop
)
84 (format *compiler-trace-output
* "~S~%" vop
)))
86 (setf *prev-vop
* vop
))
89 (format t
"~A:~%" (car args
)))
91 (format t
"~0,8T.align~0,8T~A~%" (car args
)))
93 (format t
"~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args
))))
96 ;;;; GENERATE-CODE and support routines
98 ;;; standard defaults for slots of SEGMENT objects
99 (defun default-segment-run-scheduler ()
100 (and *assembly-optimize
*
103 (block-next (component-head *component-being-compiled
*))))
104 (or (> speed compilation-speed
) (> space compilation-speed
)))))
105 (defun default-segment-inst-hook ()
106 (and *compiler-trace-output
*
107 #'trace-instruction
))
109 (defun init-assembler ()
111 (sb!assem
:make-segment
:type
:regular
112 :run-scheduler
(default-segment-run-scheduler)
113 :inst-hook
(default-segment-inst-hook)))
115 (setf (sb!assem
:segment-collect-dynamic-statistics
*code-segment
*)
116 *collect-dynamic-statistics
*)
118 (sb!assem
:make-segment
:type
:elsewhere
119 :run-scheduler
(default-segment-run-scheduler)
120 :inst-hook
(default-segment-inst-hook)
123 (setf *constant-segment
*
124 (sb!assem
:make-segment
:type
:elsewhere
126 :inst-hook
(default-segment-inst-hook)
128 *constant-table
* (make-hash-table :test
#'equal
)
129 *constant-vector
* (make-array 16 :adjustable t
:fill-pointer
0))
133 (defun emit-inline-constants ()
134 (unless (zerop (length *constant-vector
*))
135 (let ((constants (sb!vm
:sort-inline-constants
*constant-vector
*)))
136 (assemble (*constant-segment
*)
137 (map nil
(lambda (constant)
138 (sb!vm
:emit-inline-constant
(car constant
) (cdr constant
)))
140 (sb!assem
:append-segment
*constant-segment
* *code-segment
*)
141 (setf *code-segment
* *constant-segment
*))
142 (setf *constant-segment
* nil
143 *constant-vector
* nil
144 *constant-table
* nil
))
146 ;;; If a constant is already loaded into a register use that register.
147 (defun optimize-constant-loads (component)
148 (let* ((register-sb (sb-or-lose 'sb
!vm
::registers
))
150 (make-array (sb-size register-sb
)
151 :initial-element nil
)))
152 (do-ir2-blocks (block component
)
153 (fill loaded-constants nil
)
154 (do ((vop (ir2-block-start-vop block
) (vop-next vop
)))
156 (labels ((register-p (tn)
158 (eq (sc-sb (tn-sc tn
)) register-sb
)))
159 (constant-eql-p (a b
)
161 (and (eq (sc-name (tn-sc a
)) 'constant
)
162 (eq (tn-sc a
) (tn-sc b
))
163 (eql (tn-offset a
) (tn-offset b
)))))
164 (remove-constant (tn)
165 (when (register-p tn
)
166 (setf (svref loaded-constants
(tn-offset tn
)) nil
)))
167 (remove-written-tns ()
168 (cond ((memq (vop-info-save-p (vop-info vop
))
169 '(t :force-to-stack
))
170 (fill loaded-constants nil
))
172 (do ((ref (vop-results vop
) (tn-ref-across ref
)))
174 (remove-constant (tn-ref-tn ref
))
175 (remove-constant (tn-ref-load-tn ref
)))
176 (do ((ref (vop-temps vop
) (tn-ref-across ref
)))
178 (remove-constant (tn-ref-tn ref
)))
179 (do ((ref (vop-args vop
) (tn-ref-across ref
)))
181 (remove-constant (tn-ref-load-tn ref
))))))
182 (compatible-scs-p (a b
)
184 (and (eq (sc-name a
) 'sb
!vm
::control-stack
)
185 (eq (sc-name b
) 'sb
!vm
::descriptor-reg
))
186 (and (eq (sc-name b
) 'sb
!vm
::control-stack
)
187 (eq (sc-name a
) 'sb
!vm
::descriptor-reg
))))
188 (find-constant-tn (constant sc
)
189 (loop for
(saved-constant . tn
) across loaded-constants
190 when
(and saved-constant
191 (constant-eql-p saved-constant constant
)
192 (compatible-scs-p (tn-sc tn
) sc
))
195 ((move sb
!vm
::move-arg
)
196 (let* ((args (vop-args vop
))
198 (y (tn-ref-tn (vop-results vop
)))
200 (cond ((and (eq (vop-name vop
) 'move
)
202 ;; Helps subsequent optimization of adjacent VOPs
204 ((or (eq (sc-name (tn-sc x
)) 'null
)
205 (not (eq (tn-kind x
) :constant
)))
206 (remove-written-tns))
207 ((setf constant
(find-constant-tn x
(tn-sc y
)))
209 (setf (svref loaded-constants
(tn-offset y
))
211 ;; XOR is more compact on x86oids and many
212 ;; RISCs have a zero register
213 (unless (and (constant-p (tn-leaf x
))
216 (setf (tn-ref-tn args
) constant
)
217 (setf (tn-ref-load-tn args
) nil
)))
219 (setf (svref loaded-constants
(tn-offset y
))
222 (remove-written-tns)))))
224 (remove-written-tns))))))))
226 (defun generate-code (component)
227 (when *compiler-trace-output
*
228 (format *compiler-trace-output
*
229 "~|~%assembly code for ~S~2%"
235 (let ((label (sb!assem
:gen-label
)))
236 (setf *elsewhere-label
* label
)
237 (sb!assem
:assemble
(*elsewhere
*)
238 (sb!assem
:emit-label label
)))
239 (do-ir2-blocks (block component
)
240 (let ((1block (ir2-block-block block
)))
241 (when (and (eq (block-info 1block
) block
)
242 (block-start 1block
))
243 (sb!assem
:assemble
(*code-segment
*)
244 ;; Align first emitted block of each loop: x86 and x86-64 both
245 ;; like 16 byte alignment, however, since x86 aligns code objects
246 ;; on 8 byte boundaries we cannot guarantee proper loop alignment
247 ;; there (yet.) Only x86-64 does something with ALIGNP, but
248 ;; it may be useful in the future.
249 (let ((alignp (let ((cloop (block-loop 1block
)))
252 (not (loop-info cloop
)))
253 ;; Mark the loop as aligned by saving the IR1 block aligned.
254 (setf (loop-info cloop
) 1block
)
256 (emit-block-header (block-label 1block
)
257 (ir2-block-%trampoline-label block
)
258 (ir2-block-dropped-thru-to block
)
260 (let ((env (block-physenv 1block
)))
261 (unless (eq env prev-env
)
262 (let ((lab (gen-label)))
263 (setf (ir2-physenv-elsewhere-start (physenv-info env
))
265 (emit-label-elsewhere lab
))
266 (setq prev-env env
)))))
267 (do ((vop (ir2-block-start-vop block
) (vop-next vop
)))
269 (let ((gen (vop-info-generator-function (vop-info vop
))))
272 "missing generator for ~S~%"
273 (template-name (vop-info vop
))))
277 (vop-name (vop-next vop
)))
278 (memq (vop-name vop
) '(move move-operand sb
!vm
::move-arg
))
279 (sb!vm
::load-store-two-words vop
(vop-next vop
)))
280 (setf vop
(vop-next vop
)))
282 (funcall gen vop
))))))
283 (sb!assem
:append-segment
*code-segment
* *elsewhere
*)
284 (setf *elsewhere
* nil
)
286 (emit-inline-constants)
287 (values (sb!assem
:finalize-segment
*code-segment
*)
290 (defun emit-label-elsewhere (label)
291 (sb!assem
:assemble
(*elsewhere
*)
292 (sb!assem
:emit-label label
)))
294 (defun label-elsewhere-p (label-or-posn kind
)
295 (let ((elsewhere (label-position *elsewhere-label
*))
296 (label (etypecase label-or-posn
298 (label-position label-or-posn
))
301 (if (memq kind
'(:single-value-return
304 ;; We're interested in what precedes the return, not after
306 (<= elsewhere label
))))
309 (defun register-inline-constant (&rest constant-descriptor
)
310 (declare (dynamic-extent constant-descriptor
))
311 (let ((constant (sb!vm
:canonicalize-inline-constant constant-descriptor
)))
312 (or (gethash constant
*constant-table
*)
313 (multiple-value-bind (label value
) (sb!vm
:inline-constant-value constant
)
314 (vector-push-extend (cons constant label
) *constant-vector
*)
315 (setf (gethash constant
*constant-table
*) value
)))))