X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-byte-comp.lisp;h=8b8d9773645da686562fd247705ae44a79a1d73a;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=7ef94e8cdc81f7510b7895da8a02f53c64391d40;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp
index 7ef94e8..8b8d977 100644
--- a/src/compiler/target-byte-comp.lisp
+++ b/src/compiler/target-byte-comp.lisp
@@ -13,15 +13,11 @@
 
 (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:~%")
@@ -53,32 +49,35 @@
     ;; -- 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)
@@ -96,8 +95,8 @@
 		 (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))
@@ -116,6 +115,7 @@
 (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 ()
@@ -150,7 +150,7 @@
 			 (+ 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)
@@ -169,16 +169,20 @@
 		       (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)))
@@ -187,6 +191,9 @@
 	      (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)))))