0.6.11.40:
[sbcl.git] / src / compiler / target-byte-comp.lisp
1 ;;;; This file contains the noise to byte-compile stuff. It uses the
2 ;;;; same front end as the real compiler, but generates byte code
3 ;;;; instead of native code.
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 ;;; Generate trace-file output for the byte compiler back-end.
17 ;;;
18 ;;; (Note: As of sbcl-0.6.7, this is target-only code not because it's
19 ;;; logically target-only, but just because it's still implemented in
20 ;;; terms of SAPs.)
21 #!+sb-show
22 (defun describe-byte-component (component xeps segment *standard-output*)
23   (format t "~|~%;;;; byte component ~S~2%" (component-name component))
24   (format t ";;; functions:~%")
25   (dolist (fun (component-lambdas component))
26     (when (leaf-name fun)
27       (let ((info (leaf-info fun)))
28         (when info
29           (format t "~6D: ~S~%"
30                   (sb!assem:label-position (byte-lambda-info-label info))
31                   (leaf-name fun))))))
32
33   (format t "~%;;;disassembly:~2%")
34   (collect ((eps)
35             (chunks))
36     (dolist (x xeps)
37       (let ((xep (cdr x)))
38         (etypecase xep
39           (simple-byte-function
40            (eps (simple-byte-function-entry-point xep)))
41           (hairy-byte-function
42            (dolist (ep (hairy-byte-function-entry-points xep))
43              (eps ep))
44                (when (hairy-byte-function-more-args-entry-point xep)
45                  (eps (hairy-byte-function-more-args-entry-point xep)))))))
46     ;; In CMU CL, this was
47     ;;   (SB!ASSEM:SEGMENT-MAP-OUTPUT
48     ;;      SEGMENT
49     ;;      #'(LAMBDA (SAP BYTES) (CHUNKS (CONS SAP BYTES))))
50     ;; -- WHN 19990811
51     (sb!assem:on-segment-contents-vectorly segment
52                                            (lambda (chunk) (chunks chunk)))
53     (let* ((total-bytes (reduce #'+ (mapcar #'cdr (chunks))))
54            ;; KLUDGE: It's not clear that BUF has to be a SAP instead
55            ;; of a nice high-level, safe, friendly vector. Perhaps
56            ;; this code could be rewritten to use ordinary indices and
57            ;; vectors instead of SAP references to chunks of raw
58            ;; system memory? -- WHN 19990811
59            (buf (allocate-system-memory total-bytes)))
60       (let ((offset 0))
61         (dolist (chunk (chunks))
62           (declare (type (simple-array (unsigned-byte 8)) chunk))
63           (copy-byte-vector-to-system-area chunk buf offset)
64           (incf offset chunk-n-bits)))
65
66       (disassem-byte-sap buf
67                          total-bytes
68                          (map 'vector
69                               #'(lambda (x)
70                                   (if (constant-p x)
71                                       (constant-value x)
72                                       x))
73                               (byte-component-info-constants
74                                (component-info component)))
75                          (sort (eps) #'<))
76       (terpri)
77       (deallocate-system-memory buf total-bytes)
78       (values))))
79
80 ;;; Given a byte-compiled function, disassemble it to standard output.
81 (defun disassem-byte-fun (xep)
82   (declare (optimize (inhibit-warnings 3)))
83   (disassem-byte-component
84    (byte-function-component xep)
85    (etypecase xep
86      (simple-byte-function
87       (list (simple-byte-function-entry-point xep)))
88      (hairy-byte-function
89       (sort (copy-list
90              (if (hairy-byte-function-more-args-entry-point xep)
91                  (cons (hairy-byte-function-more-args-entry-point xep)
92                        (hairy-byte-function-entry-points xep))
93                  (hairy-byte-function-entry-points xep)))
94             #'<)))))
95
96 ;;; Given a byte-compiled component, disassemble it to standard output.
97 ;;; EPS is a list of the entry points.
98 (defun disassem-byte-component (component &optional (eps '(0)))
99   (let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot)
100                    sb!vm:word-bytes))
101          (num-consts (- (get-header-data component)
102                         sb!vm:code-constants-offset))
103          (consts (make-array num-consts)))
104     (dotimes (i num-consts)
105       (setf (aref consts i)
106             (code-header-ref component (+ i sb!vm:code-constants-offset))))
107     (without-gcing
108       (disassem-byte-sap (code-instructions component) bytes
109                          consts eps))
110     (values)))
111
112 ;;; Disassemble byte code from a SAP and constants vector.
113 (defun disassem-byte-sap (sap bytes constants eps)
114   (declare (optimize (inhibit-warnings 3)))
115   (let ((index 0))
116     (labels ((newline ()
117                (format t "~&~4D:" index))
118              (next-byte ()
119                (let ((byte (sap-ref-8 sap index)))
120                  (format t " ~2,'0X" byte)
121                  (incf index)
122                  byte))
123              (extract-24-bits ()
124                (logior (ash (next-byte) 16)
125                        (ash (next-byte) 8)
126                        (next-byte)))
127              (extract-extended-op ()
128                (let ((byte (next-byte)))
129                  (if (= byte 255)
130                      (extract-24-bits)
131                      byte)))
132              (extract-4-bit-op (byte)
133                (let ((4-bits (ldb (byte 4 0) byte)))
134                  (if (= 4-bits 15)
135                      (extract-extended-op)
136                      4-bits)))
137              (extract-3-bit-op (byte)
138                (let ((3-bits (ldb (byte 3 0) byte)))
139                  (if (= 3-bits 7)
140                      :var
141                      3-bits)))
142              (extract-branch-target (byte)
143                (if (logbitp 0 byte)
144                    (let ((disp (next-byte)))
145                      (if (logbitp 7 disp)
146                          (+ index disp -256)
147                          (+ index disp)))
148                    (extract-24-bits)))
149              (note (string &rest noise)
150                (format t "~12T~?" string noise))
151              (get-constant (index)
152                (if (< -1 index (length constants))
153                    (aref constants index)
154                    "<bogus index>")))
155       (loop
156         (unless (< index bytes)
157           (return))
158
159         (when (eql index (first eps))
160           (newline)
161           (pop eps)
162           (let ((frame-size
163                  (let ((byte (next-byte)))
164                    (if (< byte 255)
165                        (* byte 2)
166                        (logior (ash (next-byte) 16)
167                                (ash (next-byte) 8)
168                                (next-byte))))))
169             (note "Entry point, frame-size=~D~%" frame-size)))
170
171         (newline)
172         (let ((byte (next-byte)))
173           (macrolet ((dispatch (&rest clauses)
174                        `(cond ,@(mapcar #'(lambda (clause)
175                                             `((= (logand byte ,(caar clause))
176                                                  ,(cadar clause))
177                                               ,@(cdr clause)))
178                                         clauses))))
179             (dispatch
180              ((#b11110000 #b00000000)
181               (let ((op (extract-4-bit-op byte)))
182                 (note "push-local ~D" op)))
183              ((#b11110000 #b00010000)
184               (let ((op (extract-4-bit-op byte)))
185                 (note "push-arg ~D" op)))
186              ((#b11110000 #b00100000)
187               (let ((*print-level* 3)
188                     (*print-lines* 2))
189                 (note "push-const ~S" (get-constant (extract-4-bit-op byte)))))
190              ((#b11110000 #b00110000)
191               (let ((op (extract-4-bit-op byte))
192                     (*print-level* 3)
193                     (*print-lines* 2))
194                 (note "push-sys-const ~S"
195                       (svref *system-constants* op))))
196              ((#b11110000 #b01000000)
197               (let ((op (extract-4-bit-op byte)))
198                 (note "push-int ~D" op)))
199              ((#b11110000 #b01010000)
200               (let ((op (extract-4-bit-op byte)))
201                 (note "push-neg-int ~D" (- (1+ op)))))
202              ((#b11110000 #b01100000)
203               (let ((op (extract-4-bit-op byte)))
204                 (note "pop-local ~D" op)))
205              ((#b11110000 #b01110000)
206               (let ((op (extract-4-bit-op byte)))
207                 (note "pop-n ~D" op)))
208              ((#b11110000 #b10000000)
209               (let ((op (extract-3-bit-op byte)))
210                 (note "~:[~;named-~]call, ~D args"
211                       (logbitp 3 byte) op)))
212              ((#b11110000 #b10010000)
213               (let ((op (extract-3-bit-op byte)))
214                 (note "~:[~;named-~]tail-call, ~D args"
215                       (logbitp 3 byte) op)))
216              ((#b11110000 #b10100000)
217               (let ((op (extract-3-bit-op byte)))
218                 (note "~:[~;named-~]multiple-call, ~D args"
219                       (logbitp 3 byte) op)))
220              ((#b11111000 #b10110000)
221               ;; local call
222               (let ((op (extract-3-bit-op byte))
223                     (target (extract-24-bits)))
224                 (note "local call ~D, ~D args" target op)))
225              ((#b11111000 #b10111000)
226               ;; local tail-call
227               (let ((op (extract-3-bit-op byte))
228                     (target (extract-24-bits)))
229                 (note "local tail-call ~D, ~D args" target op)))
230              ((#b11111000 #b11000000)
231               ;; local-multiple-call
232               (let ((op (extract-3-bit-op byte))
233                     (target (extract-24-bits)))
234                 (note "local multiple-call ~D, ~D args" target op)))
235              ((#b11111000 #b11001000)
236               ;; return
237               (let ((op (extract-3-bit-op byte)))
238                 (note "return, ~D vals" op)))
239              ((#b11111110 #b11010000)
240               ;; branch
241               (note "branch ~D" (extract-branch-target byte)))
242              ((#b11111110 #b11010010)
243               ;; if-true
244               (note "if-true ~D" (extract-branch-target byte)))
245              ((#b11111110 #b11010100)
246               ;; if-false
247               (note "if-false ~D" (extract-branch-target byte)))
248              ((#b11111110 #b11010110)
249               ;; if-eq
250               (note "if-eq ~D" (extract-branch-target byte)))
251              ((#b11111000 #b11011000)
252               ;; XOP
253               (let* ((low-3-bits (extract-3-bit-op byte))
254                      (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
255                                *xop-names*)))
256                 (note "xop ~A~@[ ~D~]"
257                       xop
258                       (case xop
259                         ((catch go unwind-protect)
260                          (extract-24-bits))
261                         ((type-check push-n-under)
262                          (get-constant (extract-extended-op)))))))
263
264              ((#b11100000 #b11100000)
265               ;; inline
266               (note "inline ~A"
267                     (inline-function-info-function
268                      (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))