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 ;;; KLUDGE: the assembler can not emit backpatches comprising jump tables without
20 ;;; knowing the boxed code header length. But there is no compiler IR2 metaobject,
21 ;;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that.
22 (defun asm-routines-boxed-header-nwords ()
23 (align-up (+ sb-vm
:code-constants-offset
24 #+x86-64
1) ; KLUDGE: make room for 1 boxed constant
26 ;;; the number of bytes used by the code object header
27 (defun component-header-length ()
28 (cond #+sb-xc-host
((not (boundp '*component-being-compiled
*))
29 (* sb-vm
:n-word-bytes
(asm-routines-boxed-header-nwords)))
31 (let* ((2comp (component-info *component-being-compiled
*))
32 (constants (ir2-component-constants 2comp
)))
33 (ash (align-up (length constants
) code-boxed-words-align
)
36 (defun component-n-jump-table-entries (&optional
(component *component-being-compiled
*))
37 (ir2-component-n-jump-table-entries (component-info component
)))
39 ;;; the size of the NAME'd SB in the currently compiled component.
40 ;;; This is useful mainly for finding the size for allocating stack
42 (defun sb-allocated-size (name)
43 (finite-sb-current-size (sb-or-lose name
)))
45 ;;; the TN that is used to hold the number stack frame-pointer in
46 ;;; VOP's function, or NIL if no number stack frame was allocated
47 #-c-stack-is-control-stack
48 (defun current-nfp-tn (vop)
49 (unless (zerop (sb-allocated-size 'non-descriptor-stack
))
50 (let ((block (ir2-block-block (vop-block vop
))))
51 (when (ir2-environment-number-stack-p
53 (block-environment block
)))
54 (ir2-component-nfp (component-info (block-component block
)))))))
56 ;;; the TN that is used to hold the number stack frame-pointer in the
57 ;;; function designated by 2ENV, or NIL if no number stack frame was
59 #-c-stack-is-control-stack
60 (defun callee-nfp-tn (2env)
61 (unless (zerop (sb-allocated-size 'non-descriptor-stack
))
62 (when (ir2-environment-number-stack-p 2env
)
63 (ir2-component-nfp (component-info *component-being-compiled
*)))))
65 ;;; the TN used for passing the return PC in a local call to the function
66 ;;; designated by 2ENV
67 (defun callee-return-pc-tn (2env)
68 (ir2-environment-return-pc-pass 2env
))
72 ;;; a fixup of some kind
74 (:constructor make-fixup
(name flavor
&optional offset
))
76 ;; the name and flavor of the fixup. The assembler makes no
77 ;; assumptions about the contents of these fields; their semantics
78 ;; are imposed by the dumper.
79 (name nil
:read-only t
)
80 ;; FIXME: "-flavor" and "-kind" are completedly devoid of meaning.
81 ;; They former should probably be "fixup-referent-type" or "fixup-source"
82 ;; to indicate that it denotes a namespace for NAME, and latter should be
83 ;; "fixup-how" as it conveys a manner in which to modify encoded bytes.
84 (flavor nil
:read-only t
)
85 ;; OFFSET is an optional offset from whatever external label this
86 ;; fixup refers to. Or in the case of the :CODE-OBJECT flavor of
87 ;; fixups on the :X86 architecture, NAME is always NIL, so this
88 ;; fixup doesn't refer to an external label, and OFFSET is an offset
89 ;; from the beginning of the current code block.
90 ;; A LABEL can also be used for ppc or ppc64 in which case the value
91 ;; of the fixup will be the displacement to the label from CODE-TN.
92 (offset 0 :type
(or sb-vm
:signed-word label
)
95 ;;; A FIXUP-NOTE tells you where the assembly patch is to be performed
96 (defstruct (fixup-note
97 (:constructor make-fixup-note
(kind fixup position
))
99 ;; KIND is architecture-dependent (see the various 'vm' files)
100 (kind nil
:type symbol
)
101 (fixup (missing-arg) :type fixup
)
102 (position 0 :type fixnum
))
103 (declaim (freeze-type fixup fixup-note
))
105 ;;; Record a FIXUP of KIND occurring at the current position in SEGMENT
106 (defun note-fixup (segment kind fixup
)
109 (lambda (segment posn
)
110 (push (make-fixup-note kind fixup
111 (- posn
(segment-header-skew segment
)))
112 (sb-assem::segment-fixup-notes segment
)))))
114 ;;;; noise to emit an instruction trace
116 (defun trace-instruction (section vop inst args state
117 &aux
(*standard-output
* *compiler-trace-output
*))
118 (macrolet ((prev-section () `(car state
))
119 (prev-vop () `(cdr state
)))
120 (unless (eq (prev-section) section
)
121 (format t
"in the ~A section:~%" section
)
122 (setf (prev-section) section
))
123 (unless (eq (prev-vop) vop
)
128 (format *compiler-trace-output
* "~S~%" vop
)))
130 (setf (prev-vop) vop
))
133 (format t
"~A:~%" args
))
135 (format t
"~0,8T.align~0,8T~A~%" args
))
137 (format t
"~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args
))))
140 ;;;; GENERATE-CODE and support routines
142 ;;; standard defaults for slots of SEGMENT objects
143 (defun default-segment-run-scheduler ()
146 (block-next (component-head *component-being-compiled
*))))
147 (or (> speed compilation-speed
) (> space compilation-speed
))))
149 ;;; Some platforms support unboxed constants immediately following the boxed
150 ;;; code header. Such platform must implement supporting 4 functions:
151 ;;; * CANONICALIZE-INLINE-CONSTANT: converts a constant descriptor (list) into
152 ;;; a canonical description, to be used as a key in an EQUAL hash table
153 ;;; and to guide the generation of the constant itself.
154 ;;; * INLINE-CONSTANT-VALUE: given a canonical constant descriptor, computes
156 ;;; 1. A label that will be used to emit the constant (usually a
158 ;;; 2. A value that will be returned to code generators referring to
159 ;;; the constant (on x86oids, an EA object)
160 ;;; * SORT-INLINE-CONSTANTS: Receives a vector of unique constants;
161 ;;; the car of each entry is the constant descriptor, and the cdr the
162 ;;; corresponding label. Destructively returns a vector of constants
163 ;;; sorted in emission order. It could actually perform arbitrary
164 ;;; modifications to the vector, e.g. to fuse constants of different
166 ;;; * EMIT-INLINE-CONSTANT: receives a constant descriptor and its associated
167 ;;; label. Emits the constant.
169 ;;; Implementing this feature lets VOP generators use sb-c:register-inline-constant
170 ;;; to get handles (as returned by sb-vm:inline-constant-value) from constant
173 #+(or arm64 mips ppc ppc64 x86 x86-64
)
174 (defun register-inline-constant (&rest constant-descriptor
)
175 ;; N.B.: Please do not think yourself so clever as to declare DYNAMIC-EXTENT on
176 ;; CONSTANT-DESCRIPTOR. Giving the list indefinite extent allows backends to simply
177 ;; return it as the key to the hash-table in the most trivial possible implementation.
178 ;; The cost of listifying a &REST arg is unnoticeable here.
179 (let ((asmstream *asmstream
*)
180 (constant (sb-vm:canonicalize-inline-constant constant-descriptor
)))
181 (values ; kill the second value
184 (asmstream-constant-table asmstream
)
185 (multiple-value-bind (label value
) (sb-vm:inline-constant-value constant
)
186 (vector-push-extend (cons constant label
)
187 (asmstream-constant-vector asmstream
))
189 #-
(or arm64 mips ppc ppc64 x86 x86-64
)
190 (progn (defun sb-vm:sort-inline-constants
(constants) constants
)
191 (defun sb-vm:emit-inline-constant
(&rest args
)
192 (error "EMIT-INLINE-CONSTANT called with ~S" args
)))
193 ;;; Emit the subset of inline constants which represent jump tables
194 ;;; and remove those constants so that they don't get emitted again.
195 (defun emit-jump-tables (ir2-component)
196 ;; Other backends will probably need relative jump tables instead
197 ;; of absolute tables because of the problem of needing to load
198 ;; the LIP register prior to loading an arbitrary PC.
199 (let* ((asmstream *asmstream
*)
200 (constants (asmstream-constant-vector asmstream
))
201 (section (asmstream-data-section asmstream
))
203 (collect ((jump-tables) (other))
204 (dovector (constant constants
)
205 ;; Constant is ((category . data) . label)
206 (cond ((eq (caar constant
) :jump-table
)
207 (incf nwords
(length (cdar constant
)))
208 (jump-tables constant
))
211 ;; Preface the unboxed data with a count of jump-table words,
212 ;; including the count itself as 1 word.
213 ;; On average this will add another padding word half of the time
214 ;; depending on the number of boxed constants. We could reduce space
215 ;; by storing one bit in the header indicating whether or not there
216 ;; is a jump table. I don't think that's worth the trouble.
217 (emit section
`(.lispword
,(1+ nwords
)))
219 (setf (ir2-component-n-jump-table-entries ir2-component
) nwords
)
220 (dolist (constant (jump-tables))
221 (sb-vm:emit-inline-constant section
(car constant
) (cdr constant
)))
222 (let ((nremaining (length (other))))
223 (adjust-array constants nremaining
224 :fill-pointer nremaining
225 :initial-contents
(other)))))))
226 ;;; Return T if and only if there were any constants emitted.
227 (defun emit-inline-constants ()
228 (let* ((asmstream *asmstream
*)
229 (constants (asmstream-constant-vector asmstream
))
230 (section (asmstream-data-section asmstream
)))
231 (when (plusp (length constants
))
232 (dovector (constant (sb-vm:sort-inline-constants constants
) t
)
233 (sb-vm:emit-inline-constant section
(car constant
) (cdr constant
))))))
235 ;; Collect "static" count of number of times each vop is employed.
236 ;; (as opposed to "dynamic" - how many times its code is hit at runtime)
237 (defglobal *static-vop-usage-counts
* nil
)
238 (defparameter *do-instcombine-pass
* t
)
240 (defun generate-code (component &aux
(ir2-component (component-info component
)))
241 (declare (type ir2-component ir2-component
))
242 (when *compiler-trace-output
*
243 (let ((*print-pretty
* nil
)) ; force 1 line
244 (format *compiler-trace-output
* "~|~%assembly code for ~S~2%" component
)))
245 (let* ((prev-env nil
)
246 (sb-vm::*adjustable-vectors
* nil
)
247 ;; The first function's alignment word is zero-filled, but subsequent
248 ;; ones can use a NOP which helps the disassembler not lose sync.
250 (asmstream (make-asmstream))
251 (*asmstream
* asmstream
))
252 (declare (special sb-vm
::*adjustable-vectors
*))
254 (emit (asmstream-elsewhere-section asmstream
)
255 (asmstream-elsewhere-label asmstream
))
257 (do-ir2-blocks (block component
)
258 (let ((1block (ir2-block-block block
)))
259 (when (and (eq (block-info 1block
) block
)
260 (block-start 1block
))
261 (assemble (:code
'nil
) ; bind **CURRENT-VOP** to nil
262 ;; Align first emitted block of each loop: x86 and x86-64 both
263 ;; like 16 byte alignment, however, since x86 aligns code objects
264 ;; on 8 byte boundaries we cannot guarantee proper loop alignment
265 ;; there (yet.) Only x86-64 does something with ALIGNP, but
266 ;; it may be useful in the future.
267 ;; FIXME: see comment in ASSEMBLE-SECTIONS - we *can* enforce larger
268 ;; alignment than the size of a cons cell.
269 (let ((alignp (let ((cloop (block-loop 1block
)))
272 (not (loop-info cloop
)))
273 ;; Mark the loop as aligned by saving the IR1 block aligned.
274 (setf (loop-info cloop
) 1block
)
276 (setf filler-pattern
:long-nop
)
277 (emit-block-header (block-label 1block
)
278 (ir2-block-%trampoline-label block
)
279 (ir2-block-dropped-thru-to block
)
281 (let ((env (block-environment 1block
)))
282 (unless (eq env prev-env
)
283 (let ((lab (gen-label "environment elsewhere start")))
284 (setf (ir2-environment-elsewhere-start (environment-info env
))
286 (emit (asmstream-elsewhere-section asmstream
) lab
))
287 (setq prev-env env
)))))
288 (do ((vop (ir2-block-start-vop block
) (vop-next vop
)))
290 (let ((gen (vop-info-generator-function (vop-info vop
))))
291 (awhen *static-vop-usage-counts
*
292 (let ((name (vop-name vop
)))
293 (incf (gethash name it
0))))
294 (assemble (:code vop
)
297 "missing generator for ~S~%"
298 (template-name (vop-info vop
))))
302 (vop-name (vop-next vop
)))
303 (memq (vop-name vop
) '(move move-operand sb-vm
::move-arg
))
304 (sb-vm::load-store-two-words vop
(vop-next vop
)))
305 (setf vop
(vop-next vop
)))
307 (funcall gen vop
)))))))
309 (when *do-instcombine-pass
*
311 (sb-assem::combine-instructions
(asmstream-code-section asmstream
)))
313 (emit (asmstream-data-section asmstream
)
314 (sb-assem::asmstream-data-origin-label asmstream
))
315 ;; Jump tables precede the coverage mark bytes to simplify locating
316 ;; them in trans_code().
317 (emit-jump-tables ir2-component
)
318 (let ((coverage-map (ir2-component-coverage-map ir2-component
)))
319 (unless (zerop (length coverage-map
))
320 ;; Nothing depends on the length of the constant vector at this
321 ;; phase (codegen has not made use of component-header-length),
322 ;; so extending can be done with impunity.
324 (vector-push-extend (list :coverage-marks
(length coverage-map
))
325 (ir2-component-constants ir2-component
))
327 (make-constant (cons 'coverage-map
328 (map-into coverage-map
#'car coverage-map
)))
329 (ir2-component-constants ir2-component
))
330 ;; Allocate space in the data section for coverage marks.
332 (emit (asmstream-data-section asmstream
)
333 `(.skip
,(length coverage-map
) #-
(or x86 x86-64
) #xff
))))
335 (emit-inline-constants)
337 (let* ((n-boxed (length (ir2-component-constants ir2-component
)))
338 ;; Skew is either 0 or N-WORD-BYTES depending on whether the boxed
339 ;; header length is even or odd
340 (skew (if (and (= code-boxed-words-align
1) (oddp n-boxed
))
343 (multiple-value-bind (segment text-length fixup-notes fun-table
)
346 (ir2-component-entries ir2-component
)
347 (make-segment (default-segment-run-scheduler) skew
))
348 (values segment text-length fun-table
349 (asmstream-elsewhere-label asmstream
) fixup-notes
350 (sb-assem::get-allocation-points asmstream
))))))
352 (defun label-elsewhere-p (label-or-posn kind
)
353 (let ((elsewhere (label-position *elsewhere-label
*))
354 (label (etypecase label-or-posn
356 (label-position label-or-posn
))
359 (if (memq kind
'(:single-value-return
362 ;; We're interested in what precedes the return, not after
364 (<= elsewhere label
))))