From: Stas Boukarev <stassats@gmail.com>
Date: Fri, 24 Aug 2012 23:34:47 +0000 (+0400)
Subject: disassemble: New customization variable sb-ext:*disassemble-annotate*.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6d9e2243954872457115bbb9ac1ecb1d161acced;p=sbcl.git

disassemble: New customization variable sb-ext:*disassemble-annotate*.

sb-ext:*disassemble-annotate*: Controls whether to annotate
DISASSEMBLE output with source forms, defaults to T.

Also remove an unused function.
---

diff --git a/NEWS b/NEWS
index 3caaead..647df01 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.58:
+  * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling
+    source annotation of DISASSEMBLE output. Defaults to T.
   * optimization: CL:SORT and CL:STABLE-SORT of lists are faster and use fewer
     comparisons, particularly on almost-sorted inputs.
   * documentation: a section on random number generation has been added to the
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 1ff195b..42e5b84 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -812,6 +812,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P"
                "DELETE-DIRECTORY"
                "SET-SBCL-SOURCE-LOCATION"
+               "*DISASSEMBLE-ANNOTATE*"
 
                ;; stepping interface
                "STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION"
diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 5f053c5..b1f09cc 100644
--- 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
@@ -1450,17 +1454,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 +1478,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