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
)
62 ;;;; noise to emit an instruction trace
64 (defvar *prev-segment
*)
67 (defun trace-instruction (segment vop inst
&rest args
)
68 (declare (dynamic-extent args
))
69 (let ((*standard-output
* *compiler-trace-output
*))
70 (unless (eq *prev-segment
* segment
)
71 (format t
"in the ~A segment:~%" (sb!assem
:segment-type segment
))
72 (setf *prev-segment
* segment
))
73 (unless (eq *prev-vop
* vop
)
78 (format *compiler-trace-output
* "~S~%" vop
)))
80 (setf *prev-vop
* vop
))
83 (format t
"~A:~%" (car args
)))
85 (format t
"~0,8T.align~0,8T~A~%" (car args
)))
87 (format t
"~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args
))))
90 ;;;; GENERATE-CODE and support routines
92 ;;; standard defaults for slots of SEGMENT objects
93 (defun default-segment-run-scheduler ()
94 (and *assembly-optimize
*
97 (block-next (component-head *component-being-compiled
*))))
98 (or (> speed compilation-speed
) (> space compilation-speed
)))))
99 (defun default-segment-inst-hook ()
100 (and *compiler-trace-output
*
101 #'trace-instruction
))
103 (defun init-assembler ()
105 (sb!assem
:make-segment
:type
:regular
106 :run-scheduler
(default-segment-run-scheduler)
107 :inst-hook
(default-segment-inst-hook)))
109 (setf (sb!assem
:segment-collect-dynamic-statistics
*code-segment
*)
110 *collect-dynamic-statistics
*)
112 (sb!assem
:make-segment
:type
:elsewhere
113 :run-scheduler
(default-segment-run-scheduler)
114 :inst-hook
(default-segment-inst-hook)
117 (setf *unboxed-constants
* (make-unboxed-constants))
121 (defun emit-inline-constants (&aux
(constant-holder *unboxed-constants
*)
122 (vector (constant-vector constant-holder
)))
123 (setf *unboxed-constants
* nil
)
124 (unless (zerop (length vector
))
125 (let ((constants (sb!vm
:sort-inline-constants vector
)))
126 (assemble ((constant-segment constant-holder
))
127 (map nil
(lambda (constant)
128 (sb!vm
:emit-inline-constant
(car constant
) (cdr constant
)))
130 ;; Always append the constant segment, because a zero-length vector
131 ;; does not imply absence of unboxed data.
132 ;; In particular the simple-fun offsets are in there.
133 (setf *code-segment
* (let ((seg (constant-segment constant-holder
)))
134 (sb!assem
:append-segment seg
*code-segment
*)
137 ;;; If a constant is already loaded into a register use that register.
138 (defun optimize-constant-loads (component)
139 (let* ((register-sb (sb-or-lose 'sb
!vm
::registers
))
141 (make-array (sb-size register-sb
)
142 :initial-element nil
)))
143 (do-ir2-blocks (block component
)
144 (fill loaded-constants nil
)
145 (do ((vop (ir2-block-start-vop block
) (vop-next vop
)))
147 (labels ((register-p (tn)
149 (eq (sc-sb (tn-sc tn
)) register-sb
)))
150 (constant-eql-p (a b
)
152 (and (eq (sc-name (tn-sc a
)) 'constant
)
153 (eq (tn-sc a
) (tn-sc b
))
154 (eql (tn-offset a
) (tn-offset b
)))))
155 (remove-constant (tn)
156 (when (register-p tn
)
157 (setf (svref loaded-constants
(tn-offset tn
)) nil
)))
158 (remove-written-tns ()
159 (cond ((memq (vop-info-save-p (vop-info vop
))
160 '(t :force-to-stack
))
161 (fill loaded-constants nil
))
163 (do ((ref (vop-results vop
) (tn-ref-across ref
)))
165 (remove-constant (tn-ref-tn ref
))
166 (remove-constant (tn-ref-load-tn ref
)))
167 (do ((ref (vop-temps vop
) (tn-ref-across ref
)))
169 (remove-constant (tn-ref-tn ref
)))
170 (do ((ref (vop-args vop
) (tn-ref-across ref
)))
172 (remove-constant (tn-ref-load-tn ref
))))))
173 (compatible-scs-p (a b
)
175 (and (eq (sc-name a
) 'sb
!vm
::control-stack
)
176 (eq (sc-name b
) 'sb
!vm
::descriptor-reg
))
177 (and (eq (sc-name b
) 'sb
!vm
::control-stack
)
178 (eq (sc-name a
) 'sb
!vm
::descriptor-reg
))))
179 (find-constant-tn (constant sc
)
180 (loop for
(saved-constant . tn
) across loaded-constants
181 when
(and saved-constant
182 (constant-eql-p saved-constant constant
)
183 (compatible-scs-p (tn-sc tn
) sc
))
186 ((move sb
!vm
::move-arg
)
187 (let* ((args (vop-args vop
))
189 (y (tn-ref-tn (vop-results vop
)))
191 (cond ((and (eq (vop-name vop
) 'move
)
193 ;; Helps subsequent optimization of adjacent VOPs
195 ((or (eq (sc-name (tn-sc x
)) 'null
)
196 (not (eq (tn-kind x
) :constant
)))
197 (remove-written-tns))
198 ((setf constant
(find-constant-tn x
(tn-sc y
)))
200 (setf (svref loaded-constants
(tn-offset y
))
202 ;; XOR is more compact on x86oids and many
203 ;; RISCs have a zero register
204 (unless (and (constant-p (tn-leaf x
))
207 (setf (tn-ref-tn args
) constant
)
208 (setf (tn-ref-load-tn args
) nil
)))
210 (setf (svref loaded-constants
(tn-offset y
))
213 (remove-written-tns)))))
215 (remove-written-tns))))))))
217 (defun generate-code (component)
218 (when *compiler-trace-output
*
219 (format *compiler-trace-output
*
220 "~|~%assembly code for ~S~2%"
226 (let ((label (sb!assem
:gen-label
)))
227 (setf *elsewhere-label
* label
)
228 (sb!assem
:assemble
(*elsewhere
*)
229 (sb!assem
:emit-label label
)))
230 ;; Leave space for the unboxed words containing simple-fun offsets.
231 ;; Each offset is a 32-bit integer. On 64-bit platforms, 1 offset
232 ;; is stored in the header word as a 16-bit integer.
233 ;; On 32-bit platforms there is an extra boxed slot in the code oject.
234 (let* ((n-entries (length (ir2-component-entries (component-info component
))))
235 (ptrs-per-word (/ sb
!vm
:n-word-bytes
4)) ; either 1 or 2
236 (n-words (ceiling (1- n-entries
) ptrs-per-word
)))
237 (emit-skip #!-inline-constants
*code-segment
*
238 #!+inline-constants
(constant-segment *unboxed-constants
*)
239 ;; Preserve double-word alignment of the unboxed constants
240 (sb!vm
:pad-data-block n-words
)))
242 (do-ir2-blocks (block component
)
243 (let ((1block (ir2-block-block block
)))
244 (when (and (eq (block-info 1block
) block
)
245 (block-start 1block
))
246 (sb!assem
:assemble
(*code-segment
*)
247 ;; Align first emitted block of each loop: x86 and x86-64 both
248 ;; like 16 byte alignment, however, since x86 aligns code objects
249 ;; on 8 byte boundaries we cannot guarantee proper loop alignment
250 ;; there (yet.) Only x86-64 does something with ALIGNP, but
251 ;; it may be useful in the future.
252 (let ((alignp (let ((cloop (block-loop 1block
)))
255 (not (loop-info cloop
)))
256 ;; Mark the loop as aligned by saving the IR1 block aligned.
257 (setf (loop-info cloop
) 1block
)
259 (emit-block-header (block-label 1block
)
260 (ir2-block-%trampoline-label block
)
261 (ir2-block-dropped-thru-to block
)
263 (let ((env (block-physenv 1block
)))
264 (unless (eq env prev-env
)
265 (let ((lab (gen-label)))
266 (setf (ir2-physenv-elsewhere-start (physenv-info env
))
268 (emit-label-elsewhere lab
))
269 (setq prev-env env
)))))
270 (do ((vop (ir2-block-start-vop block
) (vop-next vop
)))
272 (let ((gen (vop-info-generator-function (vop-info vop
))))
275 "missing generator for ~S~%"
276 (template-name (vop-info vop
))))
280 (vop-name (vop-next vop
)))
281 (memq (vop-name vop
) '(move move-operand sb
!vm
::move-arg
))
282 (sb!vm
::load-store-two-words vop
(vop-next vop
)))
283 (setf vop
(vop-next vop
)))
285 (funcall gen vop
))))))
286 (sb!assem
:append-segment
*code-segment
* *elsewhere
*)
287 (setf *elsewhere
* nil
)
289 (emit-inline-constants)
290 (values (sb!assem
:finalize-segment
*code-segment
*)
293 (defun emit-label-elsewhere (label)
294 (sb!assem
:assemble
(*elsewhere
*)
295 (sb!assem
:emit-label label
)))
297 (defun label-elsewhere-p (label-or-posn kind
)
298 (let ((elsewhere (label-position *elsewhere-label
*))
299 (label (etypecase label-or-posn
301 (label-position label-or-posn
))
304 (if (memq kind
'(:single-value-return
307 ;; We're interested in what precedes the return, not after
309 (<= elsewhere label
))))
312 (defun register-inline-constant (&rest constant-descriptor
)
313 (declare (dynamic-extent constant-descriptor
))
314 (let ((constants *unboxed-constants
*)
315 (constant (sb!vm
:canonicalize-inline-constant constant-descriptor
)))
316 (or (gethash constant
(constant-table constants
))
317 (multiple-value-bind (label value
) (sb!vm
:inline-constant-value constant
)
318 (vector-push-extend (cons constant label
) (constant-vector constants
))
319 (setf (gethash constant
(constant-table constants
)) value
)))))