1.0.30.11: autogenerate tagname information for LDB in genesis
[sbcl.git] / src / compiler / codegen.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!C")
16 \f
17 ;;;; utilities used during code generation
18
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)))
26
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
29 ;;; frames.
30 (defun sb-allocated-size (name)
31   (finite-sb-current-size (sb-or-lose name)))
32
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
39            (physenv-info
40             (block-physenv block)))
41       (ir2-component-nfp (component-info (block-component block)))))))
42
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
45 ;;; allocated
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*)))))
50
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))
55 \f
56 ;;;; specials used during code generation
57
58 (defvar *trace-table-info*)
59 (defvar *code-segment* nil)
60 (defvar *elsewhere* nil)
61 (defvar *elsewhere-label* nil)
62 #!+inline-constants
63 (progn
64   (defvar *constant-segment* nil)
65   (defvar *constant-table*   nil)
66   (defvar *constant-vector*  nil))
67
68 \f
69 ;;;; noise to emit an instruction trace
70
71 (defvar *prev-segment*)
72 (defvar *prev-vop*)
73
74 (defun trace-instruction (segment vop inst 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)
80       (when vop
81         (format t "~%VOP ")
82         (if (vop-p vop)
83             (print-vop vop)
84             (format *compiler-trace-output* "~S~%" vop)))
85       (terpri)
86       (setf *prev-vop* vop))
87     (case inst
88       (:label
89        (format t "~A:~%" args))
90       (:align
91        (format t "~0,8T.align~0,8T~A~%" args))
92       (t
93        (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
94   (values))
95 \f
96 ;;;; GENERATE-CODE and support routines
97
98 ;;; standard defaults for slots of SEGMENT objects
99 (defun default-segment-run-scheduler ()
100   (and *assembly-optimize*
101         (policy (lambda-bind
102                  (block-home-lambda
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))
108
109 (defun init-assembler ()
110   (setf *code-segment*
111         (sb!assem:make-segment :type :regular
112                                :run-scheduler (default-segment-run-scheduler)
113                                :inst-hook (default-segment-inst-hook)))
114   #!+sb-dyncount
115   (setf (sb!assem:segment-collect-dynamic-statistics *code-segment*)
116         *collect-dynamic-statistics*)
117   (setf *elsewhere*
118         (sb!assem:make-segment :type :elsewhere
119                                :run-scheduler (default-segment-run-scheduler)
120                                :inst-hook (default-segment-inst-hook)
121                                :alignment 0))
122   #!+inline-constants
123   (setf *constant-segment*
124         (sb!assem:make-segment :type :elsewhere
125                                :run-scheduler nil
126                                :inst-hook (default-segment-inst-hook)
127                                :alignment 0)
128         *constant-table*  (make-hash-table :test #'equal)
129         *constant-vector* (make-array 16 :adjustable t :fill-pointer 0))
130   (values))
131
132 (defun generate-code (component)
133   (when *compiler-trace-output*
134     (format *compiler-trace-output*
135             "~|~%assembly code for ~S~2%"
136             component))
137   (let ((prev-env nil)
138         (*trace-table-info* nil)
139         (*prev-segment* nil)
140         (*prev-vop* nil)
141         (*fixup-notes* nil))
142     (let ((label (sb!assem:gen-label)))
143       (setf *elsewhere-label* label)
144       (sb!assem:assemble (*elsewhere*)
145         (sb!assem:emit-label label)))
146     (do-ir2-blocks (block component)
147       (let ((1block (ir2-block-block block)))
148         (when (and (eq (block-info 1block) block)
149                    (block-start 1block))
150           (sb!assem:assemble (*code-segment*)
151             ;; Align first emitted block of each loop: x86 and x86-64 both
152             ;; like 16 byte alignment, however, since x86 aligns code objects
153             ;; on 8 byte boundaries we cannot guarantee proper loop alignment
154             ;; there (yet.)
155             #!+x86-64
156             (let ((cloop (sb!c::block-loop 1block)))
157               (when (and cloop
158                          (sb!c::loop-tail cloop)
159                          (not (sb!c::loop-info cloop)))
160                 (sb!assem:emit-alignment sb!vm:n-lowtag-bits #x90)
161                 ;; Mark the loop as aligned by saving the IR1 block aligned.
162                 (setf (sb!c::loop-info cloop) 1block)))
163             (sb!assem:emit-label (block-label 1block)))
164           (let ((env (block-physenv 1block)))
165             (unless (eq env prev-env)
166               (let ((lab (gen-label)))
167                 (setf (ir2-physenv-elsewhere-start (physenv-info env))
168                       lab)
169                 (emit-label-elsewhere lab))
170               (setq prev-env env)))))
171       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
172           ((null vop))
173         (let ((gen (vop-info-generator-function (vop-info vop))))
174           (if gen
175             (funcall gen vop)
176             (format t
177                     "missing generator for ~S~%"
178                     (template-name (vop-info vop)))))))
179     (sb!assem:append-segment *code-segment* *elsewhere*)
180     (setf *elsewhere* nil)
181     #!+inline-constants
182     (progn
183       (unless (zerop (length *constant-vector*))
184         (let ((constants (sb!vm:sort-inline-constants *constant-vector*)))
185           (assemble (*constant-segment*)
186             (sb!vm:emit-constant-segment-header
187              constants
188              (do-ir2-blocks (2block component nil)
189                (when (policy (block-last (ir2-block-block 2block))
190                              (> speed space))
191                  (return t))))
192             (map nil (lambda (constant)
193                        (sb!vm:emit-inline-constant (car constant) (cdr constant)))
194                  constants)))
195         (sb!assem:append-segment *code-segment* *constant-segment*))
196       (setf *constant-segment* nil
197             *constant-vector*  nil
198             *constant-table*   nil))
199     (values (sb!assem:finalize-segment *code-segment*)
200             (nreverse *trace-table-info*)
201             *fixup-notes*)))
202
203 (defun emit-label-elsewhere (label)
204   (sb!assem:assemble (*elsewhere*)
205     (sb!assem:emit-label label)))
206
207 (defun label-elsewhere-p (label-or-posn)
208   (<= (label-position *elsewhere-label*)
209       (etypecase label-or-posn
210         (label
211          (label-position label-or-posn))
212         (index
213          label-or-posn))))
214
215 #!+inline-constants
216 (defun register-inline-constant (&rest constant-descriptor)
217   (declare (dynamic-extent constant-descriptor))
218   (let ((constant (sb!vm:canonicalize-inline-constant constant-descriptor)))
219     (or (gethash constant *constant-table*)
220         (multiple-value-bind (label value) (sb!vm:inline-constant-value constant)
221           (vector-push-extend (cons constant label) *constant-vector*)
222           (setf (gethash constant *constant-table*) value)))))