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.
5 ;;;; This software is part of the SBCL system. See the README file for
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.
16 ;;; Generate trace-file output for the byte compiler back-end.
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
21 (defun describe-byte-component (component xeps segment *standard-output*)
22 (format t "~|~%;;;; byte component ~S~2%" (component-name component))
23 (format t ";;; functions:~%")
24 (dolist (fun (component-lambdas component))
26 (let ((info (leaf-info fun)))
29 (sb!assem:label-position (byte-lambda-info-label info))
32 (format t "~%;;;disassembly:~2%")
39 (eps (simple-byte-function-entry-point xep)))
41 (dolist (ep (hairy-byte-function-entry-points xep))
43 (when (hairy-byte-function-more-args-entry-point xep)
44 (eps (hairy-byte-function-more-args-entry-point xep)))))))
45 ;; In CMU CL, this was
46 ;; (SB!ASSEM:SEGMENT-MAP-OUTPUT
48 ;; #'(LAMBDA (SAP BYTES) (CHUNKS (CONS SAP BYTES))))
50 (sb!assem:on-segment-contents-vectorly segment
51 (lambda (chunk) (chunks chunk)))
52 (flet ((chunk-n-bytes (chunk) (length chunk)))
53 (let* ((total-bytes (reduce #'+ (chunks) :key #'chunk-n-bytes))
54 ;; FIXME: 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? Failing that, the DEALLOCATE-SYSTEM-MEMORY
59 ;; operation below should probably be tied to the
60 ;; allocation here with an UNWIND-PROTECT relationship.
61 (buf (allocate-system-memory total-bytes)))
63 (dolist (chunk (chunks))
64 (let ((chunk-n-bits (* (chunk-n-bytes chunk) sb!vm:byte-bits)))
65 (declare (type (simple-array (unsigned-byte 8)) chunk))
66 (copy-byte-vector-to-system-area chunk buf offset)
67 (incf offset chunk-n-bits))))
68 (disassem-byte-sap buf
75 (byte-component-info-constants
76 (component-info component)))
79 (deallocate-system-memory buf total-bytes)
82 ;;; Given a byte-compiled function, disassemble it to standard output.
83 (defun disassem-byte-fun (xep)
84 (declare (optimize (inhibit-warnings 3)))
85 (disassem-byte-component
86 (byte-function-component xep)
89 (list (simple-byte-function-entry-point xep)))
92 (if (hairy-byte-function-more-args-entry-point xep)
93 (cons (hairy-byte-function-more-args-entry-point xep)
94 (hairy-byte-function-entry-points xep))
95 (hairy-byte-function-entry-points xep)))
98 ;;; Given a byte-compiled component, disassemble it to standard output.
99 ;;; EPS is a list of the entry points.
100 (defun disassem-byte-component (component &optional (eps '(0)))
101 (let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot)
103 (num-consts (- (get-header-data component)
104 sb!vm:code-constants-offset))
105 (consts (make-array num-consts)))
106 (dotimes (i num-consts)
107 (setf (aref consts i)
108 (code-header-ref component (+ i sb!vm:code-constants-offset))))
110 (disassem-byte-sap (code-instructions component) bytes
114 ;;; Disassemble byte code from a SAP and constants vector.
115 (defun disassem-byte-sap (sap bytes constants eps)
116 (declare (optimize (inhibit-warnings 3)))
117 (/show "entering DISASSEM-BYTE-SAP" bytes constants eps)
120 (format t "~&~4D:" index))
122 (let ((byte (sap-ref-8 sap index)))
123 (format t " ~2,'0X" byte)
127 (/show "in EXTRACT-24-BITS")
128 (logior (ash (next-byte) 16)
131 (extract-extended-op ()
132 (/show "in EXTRACT-EXTENDED-OP")
133 (let ((byte (next-byte)))
137 (extract-4-bit-op (byte)
138 (let ((4-bits (ldb (byte 4 0) byte)))
140 (extract-extended-op)
142 (extract-3-bit-op (byte)
143 (let ((3-bits (ldb (byte 3 0) byte)))
147 (extract-branch-target (byte)
148 (/show "in EXTRACT-BRANCH-TARGET")
150 (let ((disp (next-byte)))
155 (note (string &rest noise)
156 (format t "~12T~?" string noise))
157 (get-constant (index)
158 (if (< -1 index (length constants))
159 (aref constants index)
162 (/show "at head of LOOP" index bytes)
163 (unless (< index bytes)
166 (when (eql index (first eps))
167 (/show "in EQL INDEX (FIRST EPS) case")
171 (let ((byte (next-byte)))
174 (logior (ash (next-byte) 16)
177 (note "Entry point, frame-size=~D~%" frame-size)))
180 (let ((byte (next-byte)))
181 (/show "at head of DISPATCH" index byte)
182 (macrolet ((dispatch (&rest clauses)
183 `(cond ,@(mapcar #'(lambda (clause)
184 `((= (logand byte ,(caar clause))
189 ((#b11110000 #b00000000)
190 (let ((op (extract-4-bit-op byte)))
191 (note "push-local ~D" op)))
192 ((#b11110000 #b00010000)
193 (let ((op (extract-4-bit-op byte)))
194 (note "push-arg ~D" op)))
195 ((#b11110000 #b00100000)
196 (let ((*print-level* 3)
198 (note "push-const ~S" (get-constant (extract-4-bit-op byte)))))
199 ((#b11110000 #b00110000)
200 (let ((op (extract-4-bit-op byte))
203 (note "push-sys-const ~S"
204 (svref *system-constants* op))))
205 ((#b11110000 #b01000000)
206 (let ((op (extract-4-bit-op byte)))
207 (note "push-int ~D" op)))
208 ((#b11110000 #b01010000)
209 (let ((op (extract-4-bit-op byte)))
210 (note "push-neg-int ~D" (- (1+ op)))))
211 ((#b11110000 #b01100000)
212 (let ((op (extract-4-bit-op byte)))
213 (note "pop-local ~D" op)))
214 ((#b11110000 #b01110000)
215 (let ((op (extract-4-bit-op byte)))
216 (note "pop-n ~D" op)))
217 ((#b11110000 #b10000000)
218 (let ((op (extract-3-bit-op byte)))
219 (note "~:[~;named-~]call, ~D args"
220 (logbitp 3 byte) op)))
221 ((#b11110000 #b10010000)
222 (let ((op (extract-3-bit-op byte)))
223 (note "~:[~;named-~]tail-call, ~D args"
224 (logbitp 3 byte) op)))
225 ((#b11110000 #b10100000)
226 (let ((op (extract-3-bit-op byte)))
227 (note "~:[~;named-~]multiple-call, ~D args"
228 (logbitp 3 byte) op)))
229 ((#b11111000 #b10110000)
231 (let ((op (extract-3-bit-op byte))
232 (target (extract-24-bits)))
233 (note "local call ~D, ~D args" target op)))
234 ((#b11111000 #b10111000)
236 (let ((op (extract-3-bit-op byte))
237 (target (extract-24-bits)))
238 (note "local tail-call ~D, ~D args" target op)))
239 ((#b11111000 #b11000000)
240 ;; local-multiple-call
241 (let ((op (extract-3-bit-op byte))
242 (target (extract-24-bits)))
243 (note "local multiple-call ~D, ~D args" target op)))
244 ((#b11111000 #b11001000)
246 (let ((op (extract-3-bit-op byte)))
247 (note "return, ~D vals" op)))
248 ((#b11111110 #b11010000)
250 (note "branch ~D" (extract-branch-target byte)))
251 ((#b11111110 #b11010010)
253 (note "if-true ~D" (extract-branch-target byte)))
254 ((#b11111110 #b11010100)
256 (note "if-false ~D" (extract-branch-target byte)))
257 ((#b11111110 #b11010110)
259 (note "if-eq ~D" (extract-branch-target byte)))
260 ((#b11111000 #b11011000)
261 (/show "in XOP case")
263 (let* ((low-3-bits (extract-3-bit-op byte))
264 (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
266 (note "xop ~A~@[ ~D~]"
269 ((catch go unwind-protect)
271 ((type-check push-n-under)
272 (get-constant (extract-extended-op)))))))
274 ((#b11100000 #b11100000)
277 (inline-function-info-function
278 (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))