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 (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))
  25     (when (leaf-name fun)
  26       (let ((info (leaf-info fun)))
  27         (when info
  28           (format t "~6D: ~S~%"
  29                   (sb!assem:label-position (byte-lambda-info-label info))
  30                   (leaf-name fun))))))
  31
  32   (format t "~%;;;disassembly:~2%")
  33   (collect ((eps)
  34             (chunks))
  35     (dolist (x xeps)
  36       (let ((xep (cdr x)))
  37         (etypecase xep
  38           (simple-byte-function
  39            (eps (simple-byte-function-entry-point xep)))
  40           (hairy-byte-function
  41            (dolist (ep (hairy-byte-function-entry-points xep))
  42              (eps ep))
  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
  47     ;;      SEGMENT
  48     ;;      #'(LAMBDA (SAP BYTES) (CHUNKS (CONS SAP BYTES))))
  49     ;; -- WHN 19990811
  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)))
  62         (let ((offset 0))
  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
  69                            total-bytes
  70                            (map 'vector
  71                                 (lambda (x)
  72                                   (if (constant-p x)
  73                                       (constant-value x)
  74                                       x))
  75                                 (byte-component-info-constants
  76                                  (component-info component)))
  77                            (sort (eps) #'<))
  78         (terpri)
  79         (deallocate-system-memory buf total-bytes)
  80         (values)))))
  81
  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)
  87    (etypecase xep
  88      (simple-byte-function
  89       (list (simple-byte-function-entry-point xep)))
  90      (hairy-byte-function
  91       (sort (copy-list
  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)))
  96             #'<)))))
  97
  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)
 102                    sb!vm:word-bytes))
 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))))
 109     (without-gcing
 110       (disassem-byte-sap (code-instructions component) bytes
 111                          consts eps))
 112     (values)))
 113
 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)
 118   (let ((index 0))
 119     (labels ((newline ()
 120                (format t "~&~4D:" index))
 121              (next-byte ()
 122                (let ((byte (sap-ref-8 sap index)))
 123                  (format t " ~2,'0X" byte)
 124                  (incf index)
 125                  byte))
 126              (extract-24-bits ()
 127                (/show "in EXTRACT-24-BITS")
 128                (logior (ash (next-byte) 16)
 129                        (ash (next-byte) 8)
 130                        (next-byte)))
 131              (extract-extended-op ()
 132                (/show "in EXTRACT-EXTENDED-OP")
 133                (let ((byte (next-byte)))
 134                  (if (= byte 255)
 135                      (extract-24-bits)
 136                      byte)))
 137              (extract-4-bit-op (byte)
 138                (let ((4-bits (ldb (byte 4 0) byte)))
 139                  (if (= 4-bits 15)
 140                      (extract-extended-op)
 141                      4-bits)))
 142              (extract-3-bit-op (byte)
 143                (let ((3-bits (ldb (byte 3 0) byte)))
 144                  (if (= 3-bits 7)
 145                      :var
 146                      3-bits)))
 147              (extract-branch-target (byte)
 148                (/show "in EXTRACT-BRANCH-TARGET")
 149                (if (logbitp 0 byte)
 150                    (let ((disp (next-byte)))
 151                      (if (logbitp 7 disp)
 152                          (+ index disp -256)
 153                          (+ index disp)))
 154                    (extract-24-bits)))
 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)
 160                    "<bogus index>")))
 161       (loop
 162         (/show "at head of LOOP" index bytes)
 163         (unless (< index bytes)
 164           (return))
 165
 166         (when (eql index (first eps))
 167           (/show "in EQL INDEX (FIRST EPS) case")
 168           (newline)
 169           (pop eps)
 170           (let ((frame-size
 171                  (let ((byte (next-byte)))
 172                    (if (< byte 255)
 173                        (* byte 2)
 174                        (logior (ash (next-byte) 16)
 175                                (ash (next-byte) 8)
 176                                (next-byte))))))
 177             (note "Entry point, frame-size=~D~%" frame-size)))
 178
 179         (newline)
 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))
 185                                                  ,(cadar clause))
 186                                               ,@(cdr clause)))
 187                                         clauses))))
 188             (dispatch
 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)
 197                     (*print-lines* 2))
 198                 (note "push-const ~S" (get-constant (extract-4-bit-op byte)))))
 199              ((#b11110000 #b00110000)
 200               (let ((op (extract-4-bit-op byte))
 201                     (*print-level* 3)
 202                     (*print-lines* 2))
 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)
 230               ;; local call
 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)
 235               ;; local tail-call
 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)
 245               ;; return
 246               (let ((op (extract-3-bit-op byte)))
 247                 (note "return, ~D vals" op)))
 248              ((#b11111110 #b11010000)
 249               ;; branch
 250               (note "branch ~D" (extract-branch-target byte)))
 251              ((#b11111110 #b11010010)
 252               ;; if-true
 253               (note "if-true ~D" (extract-branch-target byte)))
 254              ((#b11111110 #b11010100)
 255               ;; if-false
 256               (note "if-false ~D" (extract-branch-target byte)))
 257              ((#b11111110 #b11010110)
 258               ;; if-eq
 259               (note "if-eq ~D" (extract-branch-target byte)))
 260              ((#b11111000 #b11011000)
 261               (/show "in XOP case")
 262               ;; XOP
 263               (let* ((low-3-bits (extract-3-bit-op byte))
 264                      (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
 265                                *xop-names*)))
 266                 (note "xop ~A~@[ ~D~]"
 267                       xop
 268                       (case xop
 269                         ((catch go unwind-protect)
 270                          (extract-24-bits))
 271                         ((type-check push-n-under)
 272                          (get-constant (extract-extended-op)))))))
 273
 274              ((#b11100000 #b11100000)
 275               ;; inline
 276               (note "inline ~A"
 277                     (inline-function-info-function
 278                      (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))