Constant-fold backquote of constant expressions

[sbcl.git] / src / compiler / target-disassem.lisp

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 5f053c5..86eafc6 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1228,11 +1228,15 @@
                   ))))
         (sb!di:no-debug-blocks () nil)))))
 
+(defvar *disassemble-annotate* t
+  "Annotate DISASSEMBLE output with source code.")
+
 (defun add-debugging-hooks (segment debug-fun &optional sfcache)
   (when debug-fun
     (setf (seg-storage-info segment)
           (storage-info-for-debug-fun debug-fun))
-    (add-source-tracking-hooks segment debug-fun sfcache)
+    (when *disassemble-annotate*
+      (add-source-tracking-hooks segment debug-fun sfcache))
     (let ((kind (sb!di:debug-fun-kind debug-fun)))
       (flet ((add-new-hook (n)
                (push (make-offs-hook
@@ -1424,13 +1428,15 @@
            (type stream stream)
            (type disassem-state dstate))
   (unless (null segments)
+    (format stream "~&; Size: ~a bytes"
+            (reduce #'+ segments :key #'seg-length))
     (let ((first (car segments))
           (last (car (last segments))))
       (set-location-printing-range dstate
-                                  (seg-virtual-location first)
-                                  (- (+ (seg-virtual-location last)
-                                        (seg-length last))
-                                     (seg-virtual-location first)))
+                                   (seg-virtual-location first)
+                                   (- (+ (seg-virtual-location last)
+                                         (seg-length last))
+                                      (seg-virtual-location first)))
       (setf (dstate-output-state dstate) :beginning)
       (dolist (seg segments)
         (disassemble-segment seg stream dstate)))))
@@ -1450,17 +1456,6 @@
       (label-segments segments dstate))
     (disassemble-segments segments stream dstate)))
 
-;;; FIXME: We probably don't need this any more now that there are
-;;; no interpreted functions, only compiled ones.
-(defun compile-function-lambda-expr (function)
-  (declare (type function function))
-  (multiple-value-bind (lambda closurep name)
-      (function-lambda-expression function)
-    (declare (ignore name))
-    (when closurep
-      (error "can't compile a lexical closure"))
-    (compile nil lambda)))
-
 (defun valid-extended-function-designators-for-disassemble-p (thing)
   (cond ((legal-fun-name-p thing)
          (compiled-funs-or-lose (fdefinition thing) thing))
@@ -1485,7 +1480,7 @@
         (error 'simple-type-error
                :datum thing
                :expected-type '(satisfies valid-extended-function-designators-for-disassemble-p)
-               :format-control "can't make a compiled function from ~S"
+               :format-control "Can't make a compiled function from ~S"
                :format-arguments (list name)))))
 
 (defun disassemble (object &key
@@ -1690,10 +1685,10 @@
 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
 ;;; in a symbol object that we know about
 (defparameter *grokked-symbol-slots*
-  (sort `((,sb!vm:symbol-value-slot . symbol-value)
-          (,sb!vm:symbol-plist-slot . symbol-plist)
-          (,sb!vm:symbol-name-slot . symbol-name)
-          (,sb!vm:symbol-package-slot . symbol-package))
+  (sort (copy-list `((,sb!vm:symbol-value-slot . symbol-value)
+                     (,sb!vm:symbol-plist-slot . symbol-plist)
+                     (,sb!vm:symbol-name-slot . symbol-name)
+                     (,sb!vm:symbol-package-slot . symbol-package)))
         #'<
         :key #'car))