(in-package "SB!C")
-(file-comment
- "$Header$")
-
;;; Generate trace-file output for the byte compiler back-end.
;;;
;;; (Note: As of sbcl-0.6.7, this is target-only code not because it's
;;; logically target-only, but just because it's still implemented in
;;; terms of SAPs.)
-#!+sb-show
(defun describe-byte-component (component xeps segment *standard-output*)
(format t "~|~%;;;; byte component ~S~2%" (component-name component))
(format t ";;; functions:~%")
;; -- WHN 19990811
(sb!assem:on-segment-contents-vectorly segment
(lambda (chunk) (chunks chunk)))
- (let* ((total-bytes (reduce #'+ (mapcar #'cdr (chunks))))
- ;; KLUDGE: It's not clear that BUF has to be a SAP instead
- ;; of a nice high-level, safe, friendly vector. Perhaps
- ;; this code could be rewritten to use ordinary indices and
- ;; vectors instead of SAP references to chunks of raw
- ;; system memory? -- WHN 19990811
- (buf (allocate-system-memory total-bytes)))
- (let ((offset 0))
- (dolist (chunk (chunks))
- (declare (type (simple-array (unsigned-byte 8)) chunk))
- (copy-byte-vector-to-system-area chunk buf offset)
- (incf offset chunk-n-bits)))
-
- (disassem-byte-sap buf
- total-bytes
- (map 'vector
- #'(lambda (x)
+ (flet ((chunk-n-bytes (chunk) (length chunk)))
+ (let* ((total-bytes (reduce #'+ (chunks) :key #'chunk-n-bytes))
+ ;; FIXME: It's not clear that BUF has to be a SAP instead
+ ;; of a nice high-level, safe, friendly vector. Perhaps
+ ;; this code could be rewritten to use ordinary indices and
+ ;; vectors instead of SAP references to chunks of raw
+ ;; system memory? Failing that, the DEALLOCATE-SYSTEM-MEMORY
+ ;; operation below should probably be tied to the
+ ;; allocation here with an UNWIND-PROTECT relationship.
+ (buf (allocate-system-memory total-bytes)))
+ (let ((offset 0))
+ (dolist (chunk (chunks))
+ (let ((chunk-n-bits (* (chunk-n-bytes chunk) sb!vm:byte-bits)))
+ (declare (type (simple-array (unsigned-byte 8)) chunk))
+ (copy-byte-vector-to-system-area chunk buf offset)
+ (incf offset chunk-n-bits))))
+ (disassem-byte-sap buf
+ total-bytes
+ (map 'vector
+ (lambda (x)
(if (constant-p x)
(constant-value x)
x))
- (byte-component-info-constants
- (component-info component)))
- (sort (eps) #'<))
- (terpri)
- (deallocate-system-memory buf total-bytes)
- (values))))
+ (byte-component-info-constants
+ (component-info component)))
+ (sort (eps) #'<))
+ (terpri)
+ (deallocate-system-memory buf total-bytes)
+ (values)))))
;;; Given a byte-compiled function, disassemble it to standard output.
(defun disassem-byte-fun (xep)
(hairy-byte-function-entry-points xep)))
#'<)))))
-;;; Given a byte-compiled component, disassemble it to standard output.
-;;; EPS is a list of the entry points.
+;;; Given a byte-compiled component, disassemble it to standard
+;;; output. EPS is a list of the entry points.
(defun disassem-byte-component (component &optional (eps '(0)))
(let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot)
sb!vm:word-bytes))
(defun disassem-byte-sap (sap bytes constants eps)
(declare (optimize (inhibit-warnings 3)))
(let ((index 0))
+ (declare (type index index))
(labels ((newline ()
(format t "~&~4D:" index))
(next-byte ()
(+ index disp)))
(extract-24-bits)))
(note (string &rest noise)
- (format t "~12T~?" string noise))
+ (format t " ~14T~?" string noise))
(get-constant (index)
(if (< -1 index (length constants))
(aref constants index)
(logior (ash (next-byte) 16)
(ash (next-byte) 8)
(next-byte))))))
- (note "Entry point, frame-size=~D~%" frame-size)))
+ (note "entry point, frame-size=~D~%" frame-size)))
(newline)
(let ((byte (next-byte)))
(macrolet ((dispatch (&rest clauses)
- `(cond ,@(mapcar #'(lambda (clause)
- `((= (logand byte ,(caar clause))
- ,(cadar clause))
- ,@(cdr clause)))
- clauses))))
+ `(cond ,@(mapcar (lambda (clause)
+ (destructuring-bind
+ ((mask match) &body body)
+ clause
+ `((= (logand byte ,mask) ,match)
+ ,@body)))
+ clauses)
+ (t (error "disassembly failure for bytecode ~X"
+ byte)))))
(dispatch
((#b11110000 #b00000000)
(let ((op (extract-4-bit-op byte)))
(let ((op (extract-4-bit-op byte)))
(note "push-arg ~D" op)))
((#b11110000 #b00100000)
+ ;; FIXME: could use WITH-PRINT-RESTRICTIONS here and in
+ ;; next clause (or just in LABELS NOTE) instead of
+ ;; hand-rolling values in each case here
(let ((*print-level* 3)
(*print-lines* 2))
(note "push-const ~S" (get-constant (extract-4-bit-op byte)))))