From ccc9a8ec2129cf26ad9f4ebc67d5f07757e22f13 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sun, 8 Dec 1991 03:30:26 +0000
Subject: [PATCH] Picked up a new version from Miles.  This is his 12/4 version
 verbatim.

---
 compiler/disassem.lisp | 1691 ++++++++++++++++++++++++++++++++++------
 1 file changed, 1435 insertions(+), 256 deletions(-)

diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp
index c1f91d707..534b10582 100644
--- a/compiler/disassem.lisp
+++ b/compiler/disassem.lisp
@@ -1,13 +1,13 @@
 ;;; -*- Package: DISASSEM -*-
 ;;;
 ;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
+;;; This code was written for the use of the CMU Common Lisp project at
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.3 1991/11/26 22:40:55 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.4 1991/12/08 03:30:26 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -26,11 +26,23 @@
 	  ;; main user entry-points
 	  disassemble
 	  disassemble-memory
+	  disassemble-function
+	  disassemble-code-component
 
 	  ;; some variables to set
 	  *opcode-column-width*
 	  *note-column*
 
+	  ;; slightly lower level entry-points
+	  create-dstate set-dstate-segment
+	  get-function-segments get-code-segments label-segments
+	  disassemble-segments disassemble-segment
+	  set-address-printing-range
+	  add-hook add-note-hook add-comment-hook
+
+	  ;; segment type
+	  segment seg-start seg-length seg-debug-function
+
 	  ;; for printing instructions
 	  print-field
 	  print-inst-using
@@ -46,6 +58,9 @@
 	  dstate-segment-start dstate-segment-length dstate-segment-sap
 	  dstate-get-prop
 
+	  ;; random types
+	  params inst inst-format field-type
+
 	  ;; 
 	  arg-value
 	  sign-extend
@@ -56,6 +71,8 @@
 	  maybe-note-nil-indexed-symbol-slot-ref
 	  maybe-note-nil-indexed-object
 	  maybe-note-assembler-routine
+	  maybe-note-single-storage-ref
+	  maybe-note-associated-storage-ref
 	  handle-break-args
 
 	  ;; taking over and printing...
@@ -68,6 +85,283 @@
 
 (import 'xp:*print-lines*)
 
+;;; This file implements a retargetable disassembler, that uses simple hooks
+;;; in the compiler-backend's instruction definitions to learn about a
+;;; machine's instruction set.
+;;;
+;;; Most of these hooks are actually called by the macros defined by
+;;; assembler.lisp, and only add a few new keyword arguments.  These are
+;;; described below.
+;;;
+;;; All of the symbols described here except for DEFINE-INSTRUCTION,
+;;; DEFINE-FORMAT, and DEFINE-ARGUMENT-TYPE (which are from assembler.lisp)
+;;; are interned in the DISASSEM package, which is not normally USEd by the
+;;; instruction definition files, and so would have "DISASSEM:" prepended in
+;;; normal use.
+;;;
+;;; The first thing that should be in the instruction definition file is a
+;;; call to SET-DISASSEM-PARAMS, where the possible keyword arguments are:
+;;;
+;;;  :INSTRUCTION-ALIGNMENT	Minimum alignment of instructions, in bytes.
+;;;  :ADDRESS-SIZE		Size of a machine address, in bits.
+;;;  :OPCODE-COLUMN-WIDTH	Width of the column used for printing the opcode
+;;;  				portion of the instruction, or NIL.
+;;;  :STORAGE-CLASS-SETS	A list of mappings (SET-NAME SC-NAME*), which
+;;;				defines which generic storage class [SET-NAME]
+;;;				the compilers SCs map into.
+;;;
+;;; The assembler definition macros should be in the following order:
+;;;  DEFINE-ARGUMENT-TYPE, DEFINE-FORMAT, DEFINE-INSTRUCTION.
+;;;
+;;;
+;;; *** New keyword arguments to DEFINE-ARGUMENT-TYPE:
+;;;
+;;;  :DISASSEM-PRINTER	Used to print an instruction field of this type.  Can
+;;;			be a string, which is used as a format-string, with
+;;;			the field's value as the only argument; a vector,
+;;;			which is indexed using the field's value, and printed
+;;;			using PRINC; T, meaning the field's value is printed
+;;;			verbatim, or a function, which is called with three
+;;;			arguments: the value, the output stream, and a
+;;;			structure of type DISASSEM-STATE (which can be used
+;;;			in various ways; see below).  Typically you should
+;;;			make sure that whatever you print or supply to be
+;;;			printed should respect *PRINT-CASE* (so, e.g., if you
+;;;			use an array of register names, they should probably
+;;;			be symbols instead of strings).
+;;;  :SIGN-EXTEND	Non-NIL if this field should be sign-extended when it's
+;;;			extracted from the instruction.
+;;;  :USE-LABEL		Indicates that this field should have an address
+;;;			label associated with it (which is then indicated at
+;;;			the point of definition, and printed in place of the
+;;;			field).  The value can be either T, in which case the
+;;;			value of the field is used directly, or a function
+;;;			taking two arguments, the value and a DISASSEM-STATE
+;;;			structure, which should return the proper value to
+;;;			use.
+;;;
+;;; The DISASSEM-STATE structure contains several fields of interest, notably
+;;; DSTATE-CURPOS, which is the address of the current instruction being
+;;; disassembled, and DSTATE-NEXTPOS, which is the address of the following
+;;; instruction, and is needed for calling several auxilarly functions;
+;;; notably at this point:
+;;;
+;;;  MAYBE-NOTE-ASSOCIATED-STORAGE-REF	Called with the an offset, a general
+;;;			storage-class set (as defined in SET-DISASSEM-
+;;;			PARAMS), a associated name, and a DISASSEM-STATE
+;;;			object.  This checks to see if there's a source
+;;;			variable mapped to OFFSET in the storage-class at
+;;;			this point in the function, and if so, makes a note
+;;;			saying that it's associated with the name you gave.
+;;;
+;;;
+;;; *** New keyword arguments to DEFINE-FIXUP-TYPE:  The same three as for
+;;;  DEFINE-ARGUMENT-TYPE. 
+;;;
+;;;
+;;; *** New keyword arguments to DEFINE-FORMAT:
+;;;  DEFINE-FORMAT takes two kinds of keyword arguments, one kind in the
+;;;  initial header, after the name, and one kind in each field description.
+;;;  To the header arguments is added:
+;;;
+;;;   :DISASSEM-PRINTER	Describes how instructions with this format should be
+;;;			printed unless otherwise specified.  It can be either
+;;;			a PRINTER-DESCRIPTION-LIST (described below), or a
+;;;			function called four arguments: the actual bits
+;;;			making it up, an instruction object, a stream and a
+;;;			disassem-state [functions are not normally used].
+;;;   :DISASSEM-CONTROL	A function that is called after the instruction has
+;;;			been entirely printed, to allow for other side
+;;;			effects; this function is called both during actual
+;;;			disassembly, and during the initial pass when labels
+;;;			are being calculated, at which time the STREAM
+;;;			argument is NIL (so you can test it and avoid doing
+;;;			things that only should happen during output).  Four
+;;;			arguments are supplied: a DCHUNK, which contains the
+;;;			actual bits of the instruction, and is usually just
+;;;			passed to other functions, an INST is a structure
+;;;			describing the instruction, a STREAM being currently
+;;;			output to (or NIL if no output is being done), and a
+;;;			DISASSEM-STATE.  Typically you use this function to
+;;;			do things like printing handy margin notes (functions
+;;;			to do which are described below).
+;;;
+;;;  To the field descriptions, only :DEFAULT-TYPE is added, which is
+;;;   analogous to :ARGUMENT in DEFINE-INSTRUCTION, and simply supplies a
+;;;   default for when the type is not specified in the instruction.  This is
+;;;   important because sometimes the disassembler wants to print a constant
+;;;   field as if it were a normal argument, and it needs to know the type to
+;;;   do it properly.
+;;;
+;;; *** PRINTER-DESCRIPTION-LISTs:
+;;;  These are a handy way to describe how an instruction should be printed,
+;;;   and are used as a value of :DISASSEM-PRINTER in both DEFINE-FORMAT and
+;;;   DEFINE-INSTRUCTION.  They are essentially a list, where each field is
+;;;   one of:
+;;;
+;;;    A string		Printed as if by PRINC.
+;;;    Something quoted	Printed as if by PRINC (so 'FOO respects
+;;;			*PRINT-CASE*, which "FOO" does not).
+;;;    :NAME		The name of the instruction is printed as if by
+;;;			PRINC.
+;;;    :TAB		The output is tabbed to the "argument column".
+;;;    An atom		Must be the name of a field in this instruction, which
+;;;			is printed according to its type.
+;;;    A list		The contents contents are printed as a PDL.
+;;;    (:CHOOSE choice1 choice2 ...)
+;;;			The choices are gone through in turn, and the first
+;;;			one in which *every* field reference (atom) is valid,
+;;;			is printed as a PDL (this includes a choice of NIL, if a
+;;;			default of nothing is wanted).  **All :CHOOSE operators
+;;;			are executed before anything else is done, and no other
+;;;    			grammar is paid attention to while this is being
+;;;     		done.**  This means you can use a :CHOOSE clause in
+;;;     		places where it might seem ungrammatical, such as the
+;;;     		field in a test-clause (see below).
+;;;    (:UNLESS test ...) If test is *not* true, then the rest of the list is
+;;;			printed as a PDL.  See below for a description of tests
+;;;    (:COND (test ...) ...)
+;;;			Analogous to lisp COND, the first clause in which the
+;;;			test is true has its cdr printed as a PDL.
+;;;
+;;;  Tests in :UNLESS and :COND are of either of the form:
+;;;
+;;;   T			Always true.
+;;;   ([field] :AND test ...)	True if all the sub-tests are true.
+;;;   ([field] :OR test ...)	True if any the sub-tests are true.
+;;;   ([field] :NOT test)	True if the subtest isn't true.
+;;;   ([field] :CONSTANT [value])
+;;;			True if field is a constant, (and when value is
+;;;			supplied, equal to it).
+;;;   ([field] :SAME-AS [other-field])
+;;;			True if field is constrained to be the same as some
+;;;			other field (which must be other-field if it is
+;;;			supplied).
+;;;
+;;;   Any test which ONLY has one element, may leave the parentheses out.
+;;;
+;;;   Note that the field in each is optional; if it is left out, then the
+;;;    field from the nearest ancestor in the whole test which supplied one
+;;;    is used.  If the top-most ancestor didn't, then the first atom in the
+;;;    PDL accompanying the test in the :UNLESS or :COND is used-- this can
+;;;    be very handy; a very commom idiom is:
+;;;	(:unless (:constant 0) ", " field)
+;;;    which prints ", <field contents>" unless the field is
+;;;    specified to be zero.  An example of inheriting otherwise is:
+;;;	(:unless (field1 :or (:constant 0) :same-as) field2)
+;;;    which prints field2 if field1 is either specified to be a constant 0,
+;;;    or to be the same as some other field (*not* just field2, though).
+;;;
+;;;   Also note that when a test does something based on whether a field is
+;;;    constant or the same as another one, this is *only* a *static* test--
+;;;    i.e., it means that an instruction which is specified with that
+;;;    constraint [(:constant something) or (:same-as something)] will be
+;;;    printed that way, but *not* cases where no instruction was defined
+;;;    with such a constraint, but where it just happened to be true.  So if
+;;;    you use a printer with a test of :constant 0 against a particular
+;;;    field but never define an instruction flavor with :constant 0 as the
+;;;    field description, then this test will never be true, even if
+;;;    instructions get disassembled where that particular field *is* zero.
+;;;
+;;;  Two examples:
+;;;
+;;;   (:name :tab
+;;;	     (:unless (:same-as dest-reg) source-reg-1 ", ")
+;;;	     (:choose source-reg-2 immed) ", "
+;;;	     dest-reg))
+;;;
+;;;   (:name :tab
+;;;	     (:choose (source-reg-1 (:unless (:constant 0) "+" immed))
+;;;		      (:cond ((source-reg-2 :constant 0) source-reg-1)
+;;;		    	     ((source-reg-1 :constant 0) source-reg-2)
+;;;		      	     (t source-reg-1 "+" source-reg-2)))
+;;;	     (:unless (:constant 0) ", " dest-reg)))
+;;;
+;;;
+;;; *** New keyword arguments to DEFINE-INSTRUCTION:
+;;;  DEFINE-INSTRUCTION takes two kinds of keyword arguments, one kind in the
+;;;  initial header, after the name, and one kind in each field description.
+;;;  To the header arguments is added the same two as DEFINE-FORMAT, which,
+;;;  if specified, override the default ones in this instruction's format.
+;;;
+;;;  To the individual field instructions are added:
+;;;
+;;;   :TYPE		Can be used to specify the type of this field when
+;;;			it's not done by :ARGUMENT (e.g., when it's a
+;;;			:CONSTANT).
+;;;   :MASK		Takes an integer constant.  For use with an :ARGUMENT
+;;;			field, specifies that only part of the field is
+;;;			actually variable-- those bits that are 1 in the
+;;;			mask.  The rest of the bits in the field are assumed
+;;;			to be constant 0.  This is needed in certain cases to
+;;;			make sure the instructions are unambiguous.
+;;;
+;;;
+;;; *** Handy functions that can be called from :DISASSEM-PRINTER or
+;;; :DISASSEM-CONTROL functions:
+;;;
+;;;  ARG-VALUE field-name dchunk inst
+;;;			Returns the value of the given field in the
+;;;			instruction.
+;;;  NOTE note dstate	Records a note to be printed in the end-of-line
+;;;			comments.  The note can be either a string, which is
+;;;			printed by PRINC, or a function taking a stream
+;;;			argument.
+;;;  MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF integer-offset dstate
+;;;			If the offset added to NIL points to a valid slot in
+;;;			a symbol, a note describing this is added to the
+;;;			end-of-line comments.
+;;;  MAYBE-NOTE-CODE-CONSTANT integer-offset dstate
+;;;			If the offset from the function's code-object refers
+;;;			to a valid constant-slot, a note describing this is
+;;;			added to the end-of-line comments.
+;;;  MAYBE-NOTE-SINGLE-STORAGE-REF integer-offset gen-storage-class-name dstate
+;;;			If there's a currently valid source-variable mapped
+;;;			at this offset in the storage class specified, a note
+;;;			to this effect is made for the end-of-line comments.
+;;;
+;;;
+;;; *** How to SPECIALIZE an instruction:
+;;;  Often it's desirable to have a different :DISASSEM-PRINTER only in
+;;;  certain cases, e.g., when a certain register field refers to a certain
+;;;  register.  One way you can do this is to define the instruction using a
+;;;  normal printer, and use the SPECIALIZE macro to define modified versions
+;;;  with different printer or control functions.  The syntax is like:
+;;;
+;;;   SPECIALIZE (inst-name [:DISASSEM-PRINTER printer]
+;;;			    [:DISASSEM-CONTROL control]
+;;;			    [:NAME new-name])
+;;;     	 field-constraint*
+;;;
+;;;  The keyword args are just like for DEFINE-FORMAT and
+;;;  DEFINE-INSTRUCTION.  The field-constraints are either just field names,
+;;;  which mean that the specialize operation should only affect flavors of
+;;;  the instruction that contain that field, or a field-name and a
+;;;  constraint, like:
+;;;
+;;;   (field-name :CONSTANT const-val)
+;;;  or
+;;;   (field-name :SAME-AS other-field-name)
+;;;
+;;;  Any instruction flavor that has all the specified fields will either
+;;;  have its printer, control, or name arguments modified, if all its
+;;;  constraints match those in the specialize, or will have a clone made
+;;;  with the field constraints tightened to match, and the clone will have
+;;;  the new printer, control, or name arguments as specified.  Also see the
+;;;  documentation for the SPECIALIZE macro.
+;;;
+;;;
+;;; *** Debugging hints:
+;;;  Because the disassembler caches the search tree that it builds to find
+;;;  instructions, if you use the disassemble command and subsequently
+;;;  re-execute some of the instruction-definitions with changes, it won't
+;;;  see the changes until you flush the cache, like:
+;;;  
+;;;   (setf (disassem::params-inst-space
+;;;	     (c:backend-disassem-params c:*target-backend*))
+;;;    	    nil)
+;;;  
+
 ;;; ----------------------------------------------------------------
 
 (defun req () (error "Required argument missing"))
@@ -81,13 +375,13 @@
 (defvar *note-column* 45
   "The column in which end-of-line comments for notes are started.")
 
-(defconstant default-opcode-column-width 10)
+(defconstant default-opcode-column-width 6)
 (defconstant default-address-column-width 8)
-(defconstant label-column-width 5)
+(defconstant label-column-width 7)
 
 ;;; ----------------------------------------------------------------
 
-(defstruct params
+(defstruct (params (:print-function %print-params))
   (field-types (make-hash-table :test #'eq) :type hash-table)
   (inst-formats (make-hash-table :test #'eq) :type hash-table)
   (instructions (make-hash-table :test #'eq) :type hash-table)
@@ -95,19 +389,30 @@
   (instruction-alignment vm:word-bytes :type fixnum)
   (address-column-width default-address-column-width :type fixnum)
   (opcode-column-width default-opcode-column-width :type (or null fixnum))
+  (storage-class-sets nil :type list)
   (backend (req) :type c::backend)	; for convenience
   )
 
+(defun %print-params (params stream level)
+  (declare (ignore level))
+  (format stream "#<Disassem parameters for ~a>"
+	  (and (params-backend params)
+	       (c:backend-name (params-backend params)))))
+
 (defmacro set-disassem-params (&key instruction-alignment
 				    address-size
-				    (opcode-column-width nil opcode-column-width-p))
+				    (opcode-column-width nil opcode-column-width-p)
+				    storage-class-sets)
   "Specify global disassembler params for C:*TARGET-BACKEND*.  Currently
   includes:
 
-  :INSTRUCTION-ALIGNMENT	Minimum alignment of instructions, in bytes.
-  :ADDRESS-SIZE			Size of a machine address, in bytes.
+  :INSTRUCTION-ALIGNMENT	Minimum alignment of instructions, in bits.
+  :ADDRESS-SIZE			Size of a machine address, in bits.
   :OPCODE-COLUMN-WIDTH		Width of the column used for printing the opcode
-  				portion of the instruction, or NIL."
+  				portion of the instruction, or NIL.
+  :STORAGE-CLASS-SETS		A list of mappings (SET-NAME SC-NAME*), which
+				defines which generic storage class the
+  				compilers SCs map into."
   `(let ((params
 	  (or (c:backend-disassem-params c:*target-backend*)
 	      (setf (c:backend-disassem-params c:*target-backend*)
@@ -123,9 +428,13 @@
 	       (* 2 ,address-size)))
      ,(when opcode-column-width-p
 	`(setf (params-opcode-column-width params) ,opcode-column-width))
+     ,(when storage-class-sets
+	`(setf (params-storage-class-sets params) ,storage-class-sets))
      (values)))
 
 ;;; ----------------------------------------------------------------
+;;; A Dchunk contains the bits we look at to decode an
+;;; instruction.
 ;;; I tried to keep this abstract so that if using integers > the machine
 ;;; word size conses too much, it can be changed to use bit-vectors or
 ;;; something.
@@ -191,6 +500,13 @@
   (declare (type dchunk from))
   (ldb pos (the dchunk from)))
 
+(defun dchunk-corrected-extract (from pos unit-bits byte-order)
+  (declare (type dchunk from))
+  (if (eq byte-order :big-endian)
+      (ldb (byte (byte-size pos) (+ (byte-position pos) (- dchunk-bits unit-bits)))
+	   (the dchunk from))
+      (ldb pos (the dchunk from))))
+
 (defmacro dchunk-insertf (place pos value)
   `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
 
@@ -217,6 +533,20 @@
       (dpb int (byte size 0) -1)
       int))
 
+(defun aligned-p (num size)
+  "Returns non-NIL if NUM is aligned on a SIZE byte boundary."
+  (declare (type integer num)
+	   (type fixnum size))
+  (zerop (logand (1- size) num)))
+
+(defun align (num size)
+  "Return NUM aligned *upward* to a SIZE byte boundary."
+  (declare (type integer num)
+	   (type fixnum size))
+  (logandc1 (1- size) (+ (1- size) num)))
+
+;;; ----------------------------------------------------------------
+
 (defun integer-typespec-p (thing)
   (and (or (consp thing) (symbolp thing))
        (subtypep thing 'integer)))
@@ -296,6 +626,7 @@
   (length 0 :type fixnum)
   (fields nil :type list)	; of inst-format-field
   (printer nil)
+  (control nil)
   (ungrokable nil :type (member nil t))	;
   )
 
@@ -355,7 +686,8 @@
 		  disassembler except when INVERSE-FUNCTION is specified, which
 		  is a mapping from the bits in a field to the correct value.
   OPTIONS		Keyword options.  Currently includes:
-		  :DISASSEM-PRINTER 	default printer for this format."
+		  :DISASSEM-PRINTER 	Default printer for this format.
+		  :DISASSEM-CONTROL	Default control for this format."
   (multiple-value-bind (fields-form ungrokable)
       (gen-format-fields-maker-form field-specs bits)
     `(setf (gethash ',name
@@ -365,6 +697,7 @@
 			     :length (truncate ,bits vm:byte-bits)
 			     :fields ,fields-form
 			     :printer ,(getf options :disassem-printer)
+			     :control ,(getf options :disassem-control)
 			     :ungrokable ,ungrokable))))
 
 ;;; ----------------------------------------------------------------
@@ -391,10 +724,20 @@
   (declare (ignore level) (stream stream))
   (format stream "#<Instruction ~s ~:a {~s}>"
 	  (inst-name inst)
-	  (mapcar #'field-name
+	  (mapcar #'(lambda (field)
+		      (cond ((inst-field-same-as-p inst field)
+			     (format nil "~a=~a"
+				     (field-name field)
+				     (field-name (inst-field-same-as inst field))))
+			    ((inst-field-const-p inst field)
+			     (format nil "~a=~d"
+				     (field-name field)
+				     (inst-field-const-value inst field)))
+			    (t
+			     (field-name field))))
 		  (remove-if #'(lambda (field)
-				 (or (inst-field-const-p inst field)
-				     (inst-field-same-as-p inst field)))
+				 (and (inst-field-const-p inst field)
+				      (null (inst-field-type inst field))))
 			     (format-fields (inst-format inst))))
 	  (format-name (inst-format inst))))
     
@@ -499,6 +842,11 @@
 	(finst-type finst)
 	(field-default-type field))))
 
+(defun inst-field-same-as (inst field)
+  (let ((finst (find field (inst-args inst) :key #'finst-field)))
+    (and finst
+	 (finst-same-as finst))))
+
 (defun inst-field-const-value (inst field)
   "Returns the bit-pattern of FIELD in the instruction object INST."
   (dchunk-extract (inst-id inst) (field-pos field)))
@@ -507,8 +855,10 @@
   "Returns non-NIL if FIELD in the instruction object INST is constrained to
   be the constant bit-pattern VALUE.  If VALUE is NIL, then non-NIL is returned
   if it's constrained to be any constant at all."
-  (and (= (integer-length (dchunk-extract (inst-mask inst) (field-pos field)))
-	  (byte-size (field-pos field)))
+  (and (let ((field-mask (dchunk-make-mask (field-pos field))))
+	 ;; must be *all* ones
+	 (dchunk= (dchunk-and (inst-mask inst) field-mask)
+		  field-mask))
        (or (null value)			; any constant will do
 	   (= value
 	      (inst-field-const-value inst field)))))
@@ -755,6 +1105,12 @@
 	    (inst-args inst))))
 
 (defun create-inst (name format-name field-specs printer control use-label params)
+  (declare (type symbol name format-name)
+	   (type list field-specs)
+	   (type (or null list function) printer)
+	   (type (or null function) control)
+	   (type (or (member nil t) function) use-label)
+	   (type params params))
   (let ((inst-format (gethash format-name (params-inst-formats params)))
 	(field-types (params-field-types params)))
     (when (null inst-format)
@@ -770,7 +1126,7 @@
 			 :id id
 			 :format inst-format
 			 :args args
-			 :control control
+			 :control (or control (format-control inst-format))
 			 :use-label use-label
 			 :printer-source printer-source
 			 )))
@@ -820,7 +1176,6 @@
 		  (control ,disassem-control)
 		  (use-label ,disassem-use-label)
 		  (insts nil))
-	     (setf (params-inst-space params) nil)
 	     ,@flavor-forms
 	     ,(if augment
 		  `(dolist (flav insts)
@@ -1024,7 +1379,6 @@
 
   Only instruction flavors that contain all the the specified fields are used."
   `(let ((params (c:backend-disassem-params c:*target-backend*)))
-     (setf (params-inst-space params) nil)
      (setf (gethash ',inst-name (params-instructions params))
 	   (specialize-insts (gethash ',inst-name (params-instructions params))
 			     ,(make-specs-form specs)
@@ -1035,11 +1389,15 @@
 ;;; an instruction space holds all known machine instructions in a form that
 ;;; can be easily searched
 
-(defstruct (inst-space (:conc-name ispace-))
+(defstruct (inst-space (:conc-name ispace-) (:print-function %print-ispace))
   (valid-mask dchunk-zero :type dchunk)	; applies to *children*
   (choices nil :type (or list vector))
   )
 
+(defun %print-ispace (ispace stream level)
+  (declare (ignore level))
+  (format stream "#<Instruction-space {~x}>" (kernel:get-lisp-obj-address ispace)))
+
 (defstruct (inst-space-choice (:conc-name ischoice-))
   (common-id dchunk-zero :type dchunk)	; applies to *parent's* mask
   (subspace (req) :type (or inst-space inst))
@@ -1079,7 +1437,7 @@
 
 (defun find-inst (chunk inst-space)
   "Returns the instruction object within INST-SPACE corresponding to the
-  bit-pattern CHUNK."
+  bit-pattern CHUNK, or NIL if there isn't one."
   (declare (type dchunk chunk)
 	   (type (or null inst-space inst) inst-space))
   (cond ((null inst-space)
@@ -1266,20 +1624,124 @@
 				    (+ 4 indent)))
 	      (ispace-choices inst-space)))))
 
+;;;; ----------------------------------------------------------------
+;;;; the actual disassembly part
+;;;; ----------------------------------------------------------------
+
 ;;; ----------------------------------------------------------------
-;;; stuff used for printing
+;;; getting at the source code...
+
+(defstruct (source-form-cache (:conc-name sfcache-))
+  (debug-source nil :type (or null di:debug-source))
+  (top-level-form-index -1 :type fixnum)
+  (top-level-form nil :type list)
+  (form-number-mapping-table nil :type (or null (vector list)))
+  (last-location-retrieved nil :type (or null di:code-location))
+  (last-form-retrieved -1 :type fixnum)
+  )
+
+(defun get-top-level-form (debug-source tlf-index)
+  (let ((name (di:debug-source-name debug-source)))
+    (ecase (di:debug-source-from debug-source)
+      (:file
+       (cond ((not (probe-file name))
+	      (warn "The source file ~s no longer seems to exist" name)
+	      nil)
+	     (t
+	      (let ((start-positions
+		     (di:debug-source-start-positions debug-source)))
+		(cond ((null start-positions)
+		       (warn "No start positions map")
+		       nil)
+		      (t
+		       (let* ((local-tlf-index
+			       (- tlf-index
+				  (di:debug-source-root-number debug-source)))
+			      (char-offset
+			       (aref start-positions local-tlf-index)))
+			 (with-open-file (f name)
+			   (cond ((= (di:debug-source-created debug-source)
+				     (file-write-date name))
+				  (file-position f char-offset))
+				 (t
+				  (warn "Source file ~s has been modified; ~@
+					 Using form offset instead of file index"
+					name)
+				  (dotimes (i local-tlf-index) (read f))))
+			   (read f)
+			   ))))))))
+      ((:lisp :stream)
+       (aref name tlf-index)))))
+
+(defun cache-valid (loc cache)
+  (and cache
+       (and (eq (di:code-location-debug-source loc)
+		(sfcache-debug-source cache))
+	    (eq (di:code-location-top-level-form-offset loc)
+		(sfcache-top-level-form-index cache)))))
+
+(defun get-source-form (loc context &optional cache)
+  (let* ((cache-valid (cache-valid loc cache))
+	 (tlf-index (di:code-location-top-level-form-offset loc))
+	 (form-number (di:code-location-form-number loc))
+	 (top-level-form
+	  (if cache-valid
+	      (sfcache-top-level-form cache)
+	      (get-top-level-form (di:code-location-debug-source loc)
+				  tlf-index)))
+	 (mapping-table
+	  (if cache-valid
+	      (sfcache-form-number-mapping-table cache)
+	      (di:form-number-translations top-level-form tlf-index))))
+    (when (and (not cache-valid) cache)
+      (setf (sfcache-debug-source cache) (di:code-location-debug-source loc)
+	    (sfcache-top-level-form-index cache) tlf-index
+	    (sfcache-top-level-form cache) top-level-form
+	    (sfcache-form-number-mapping-table cache) mapping-table))
+    (cond ((null top-level-form)
+	   nil)
+	  ((> form-number (length mapping-table))
+	   (warn "Bogus form-number in form!  The source file has probably ~@
+		  been changed too much to cope with")
+	   (when cache
+	     ;; disable future warnings
+	     (setf (sfcache-top-level-form cache) nil))
+	   nil)
+	  (t
+	   (when cache
+	     (setf (sfcache-last-location-retrieved cache) loc)
+	     (setf (sfcache-last-form-retrieved cache) form-number))
+	   (di:source-path-context top-level-form
+				   (aref mapping-table form-number)
+				   context)))))
+
+(defun get-different-source-form (loc context &optional cache)
+  (if (and (cache-valid loc cache)
+	   (or (= (di:code-location-form-number loc)
+		  (sfcache-last-form-retrieved cache))
+	       (and (sfcache-last-location-retrieved cache)
+		    (di:code-location= loc (sfcache-last-location-retrieved cache)))))
+      (values nil nil)
+      (values (get-source-form loc context cache) t)))
+
+;;; ----------------------------------------------------------------
+;;;
 
 ;;; All state during disassembly.  We store some seemingly redundant
 ;;; information so that we can allow garbage collect during disassembly and
 ;;; not get tripped up by a code block being moved...
-(defstruct (disassem-state (:conc-name dstate- ))
+(defstruct (disassem-state (:conc-name dstate-)
+			   (:print-function %print-dstate))
   (curpos 0 :type integer)		; address of current instruction
   (nextpos 0 :type integer)		; address of next instruction
 
-  (code nil)				; code object or nil
-  (code-insts-addr 0 :type integer)	; address of instructions area (only
+  (code nil :type (or null kernel:code-component))
+  (real-code-insts-addr 0 :type integer) ; address of instructions area (only
 					; used for avoiding gc effects) in
 					; the code object
+  (code-insts-addr 0 :type integer)	; the instruction area fixed at
+					; creation time (doesn't change with
+					; a gc)
   (code-insts-offset 0 :type fixnum)	; offset of instruction area from the
 					; start of the code object
 
@@ -1291,21 +1753,49 @@
   (segment-length 0 :type fixnum)	; length thereof
 
   (alignment vm:word-bytes :type fixnum) ; what to align to in most cases
-  (byte-order :little-endian :type (member :big-endian :little-endian))
+  (byte-order :little-endian
+	      :type (member :big-endian :little-endian))
 
   (properties nil :type list)		; for user code to hang stuff off of
 
-  (addr-print-len nil :type (or null fixnum)) ; used for prettifying printing
+  (addr-print-len nil :type		; used for prettifying printing
+		  (or null fixnum))
   (argument-column 0 :type fixnum)
+  (output-state :beginning		; to make output look nicer
+		  :type (member :beginning
+				:block-boundary
+				nil))
 
-  (labels nil :type list)		; alist of (address . name)
-  (label-hash (make-hash-table) :type hash-table) ; same info in a different format
+  (labels nil :type list)		; alist of (address . label-number)
   (fun-header-addresses nil :type list)	; list of byte-offsets from code
-  (pending-notes nil :type list)	; list of strings or functions to print
+  (hooks nil :type list)		; alist of (address . function)
+
+  (label-hash (make-hash-table)		; same info in a different form
+	      :type hash-table)
+
+  ;; versions of the above being run through
+  (cur-labels nil :type list)		; alist of (address . label-number)
+  (cur-fun-header-addresses nil :type list) ; list of byte-offsets from code
+  (cur-hooks nil :type list)		; alist of (address . function)
+
+  (notes nil :type list)		; for the current location
+
+  (storage-info nil			; info about source variables
+		:type (or null storage-info))
+  (current-valid-locations nil		; currently active source variables
+			   :type (or null (vector bit)))
 
   (params (req) :type params)		; a handy pointer ...
   )
 
+(defun %print-dstate (dstate stream level)
+  (declare (ignore level))
+  (format stream "#<Disassembly state at #x~x in #x~x[~d]~@[ in ~s~]>"
+	  (dstate-curpos dstate)
+	  (dstate-segment-start dstate)
+	  (dstate-segment-length dstate)
+	  (dstate-code dstate)))
+
 (defmacro dstate-get-prop (dstate name)
   "Get the value of the property called NAME in DSTATE.  Also setf'able."
   `(getf (dstate-properties ,dstate) ,name))
@@ -1388,7 +1878,7 @@
 		   ((stringp printer)
 		    (format stream printer value))
 		   ((vectorp printer)
-		    (princ (aref printer value)))
+		    (princ (aref printer value) stream))
 		   (t
 		    (funcall printer value stream dstate)))))
 	  (t
@@ -1414,7 +1904,7 @@
        (write-string element stream))
       (symbol
        (if (eq element :tab)
-	   (format stream "~vt" (dstate-argument-column dstate))
+	   (format stream "~v,1t" (dstate-argument-column dstate))
 	   (print-field element chunk inst stream dstate)))
       (cons
        (if (eq (car element) 'quote)
@@ -1424,7 +1914,8 @@
 
 (defun print-inst (chunk inst stream dstate)
   "Print a disassembled version of the instruction with bit-pattern CHUNK,
-  and corresponding to the instruction object INST to STREAM."
+  and corresponding to the instruction object INST to STREAM.  DSTATE is a
+  DISASSEM-STATE object."
   (declare (type dchunk chunk)
 	   (type inst inst)
 	   (type stream stream)
@@ -1478,17 +1969,20 @@
 
 (defconstant lra-size (to-bytes 1))
 
-(defun aligned-p (num size)
-  "Returns non-NIL if NUM is aligned on a SIZE byte boundary."
-  (declare (type integer num)
-	   (type fixnum size))
-  (zerop (logand (1- size) num)))
-
-(defun align (num size)
-  "Return NUM aligned *upward* to a SIZE byte boundary."
-  (declare (type integer num)
-	   (type fixnum size))
-  (logandc1 (1- size) (+ (1- size) num)))
+(defmacro with-matching-addresses ((thing-var address alist-place) &body body)
+  (let ((source-alist-var (gensym))
+	(cell-var (gensym))
+	(address-var (gensym)))
+    `(let ((,source-alist-var ,alist-place)
+	   (,address-var ,address))
+       (loop
+	 (unless (and ,source-alist-var (<= (caar ,source-alist-var) ,address-var))
+	   (return))
+	 (let ((,cell-var (pop ,source-alist-var)))
+	   (when (= (car ,cell-var) ,address-var)
+	     (let ((,thing-var (cdr ,cell-var)))
+	       ,@body))
+	   (setf ,alist-place ,source-alist-var))))))
 
 ;;; ----------------------------------------------------------------
 ;;; Routines to find things in the lisp environment.  Obviously highly
@@ -1570,23 +2064,86 @@ symbol object that we know about.")
   (gethash address *assembler-routines-by-addr*))
 
 ;;; ----------------------------------------------------------------
+;;; function ops
 
-(defun code-addr-offset (code addr)
-  "Returns the offset from the beginning of the code-object CODE of ADDR."
-  (declare (type integer addr))
-  (- addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address code))))
+(defun fun-self (fun)
+  (declare (type compiled-function fun))
+  (ext:truly-the compiled-function (system:%primitive function-self fun)))
 
-(defun code-offs-address (code offs)
-  "Returns the ADDRESS of OFFS from the beginning of the code-object CODE."
-  (declare (type fixnum offs))
-  (+ offs (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address code))))
+(defun fun-code (fun)
+  (declare (type compiled-function fun))
+  (kernel:function-code-header (fun-self fun)))
 
-(defun dstate-cur-code-offset (dstate)
-  "Returns the offset of the current position in DSTATE from the beginning of
-  its code object.  Insensitive to GC."
-  (declare (type disassem-state dstate))
-  (+ (- (dstate-curpos dstate) (dstate-segment-start dstate))
-     (- (system:sap-int (dstate-segment-sap dstate))
+(defun fun-next (fun)
+  (declare (type compiled-function fun))
+  (ext:truly-the compiled-function (system:%primitive function-next fun)))
+
+(defun fun-address (function)
+  (declare (type compiled-function function))
+  (- (kernel:get-lisp-obj-address function)
+     vm:function-pointer-type))
+
+(defun fun-offset (function)
+  (declare (type compiled-function function))
+  (- (fun-address function)
+     (system:sap-int (kernel:code-instructions (fun-code function)))))
+
+;;; ----------------------------------------------------------------
+;;; Operations on code-components (which hold the instructions for
+;;; one or more functions).
+
+(defun code-inst-area-length (code-component)
+  "Returns the length of the instruction area in CODE-COMPONENT."
+  (declare (type kernel:code-component code-component))
+  (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
+
+(defun code-inst-area-address (code-component)
+  "Returns the address of the instruction area in CODE-COMPONENT."
+  (declare (type kernel:code-component code-component))
+  (system:sap-int (kernel:code-instructions code-component)))
+
+(defun code-first-function (code-component)
+  "Returns the first function in CODE-COMPONENT."
+  (declare (type kernel:code-component code-component))
+  (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
+
+(defun code-addr-offset (code-component addr)
+  "Returns the offset from the beginning of CODE-COMPONENT of ADDR."
+  (declare (type kernel:code-component code-component)
+	   (type integer addr))
+  (- addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address code-component))))
+
+(defun code-offs-address (code-component offs)
+  "Returns the address of OFFS bytes from the beginning of CODE-COMPONENT."
+  (declare (type kernel:code-component code-component)
+	   (type fixnum offs))
+  (+ offs (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address code-component))))
+
+;;; ----------------------------------------------------------------
+
+(defun dstate-code-insts-offs-address (dstate offs)
+  (declare (type disassem-state dstate)
+	   (type fixnum offs))
+  (+ (dstate-code-insts-addr dstate)
+     offs))
+
+(defun dstate-true-code-address (dstate address)
+  "Translates a canonical address in DSTATE's code-component (e.g.,
+  at the position when DSTATE was first created) to the actual
+  address, which could be different if the code-component was moved
+  by a GC."
+  (declare (type disassem-state dstate)
+	   (type integer address))
+  (+ (- address
+	(dstate-code-insts-addr dstate))
+     (dstate-real-code-insts-addr dstate)))
+
+(defun dstate-code-addr-offset (dstate address)
+  "Translates an address in DSTATE's code-component to the address
+  it would be if no GCs had occurred since DSTATE was created."
+  (declare (type disassem-state dstate)
+	   (type integer address))
+  (+ (- address
 	(dstate-code-insts-addr dstate))
      (dstate-code-insts-offset dstate)))
 
@@ -1594,7 +2151,7 @@ symbol object that we know about.")
   "Returns a sorted list of the ADDRESSES of function-headers in the
   code-object CODE."
   (do ((fun (kernel:code-header-ref code vm:code-entry-points-slot)
-	    (system:%primitive function-next fun))
+	    (fun-next fun))
        (fun-header-addrs nil))
       ((null fun)
        (sort fun-header-addrs #'<))
@@ -1609,30 +2166,48 @@ symbol object that we know about.")
   (declare (type dchunk chunk)
 	   (type disassem-state dstate))
   (and (aligned-p (dstate-curpos dstate) (* 2 vm:word-bytes))
-       (let ((byte-offset (dstate-cur-code-offset dstate)))
-	 (= (dchunk-extract chunk
-			    (correct-dchunk-bytespec-for-endianness
-			     (byte vm:word-bits 0)
-			     vm:word-bits
-			     (dstate-byte-order dstate)))
+       (let ((byte-offset
+	      (dstate-code-addr-offset dstate (dstate-curpos dstate))))
+	 (= (dchunk-corrected-extract chunk
+				      (byte vm:word-bits 0)
+				      vm:word-bits
+				      (dstate-byte-order dstate))
 	    (logior (ash (to-words byte-offset) vm:type-bits)
 		    vm:return-pc-header-type)))))
 
 (defun at-fun-header-p (dstate)
   "Returns non-NIL if DSTATE is currently pointing at a function header."
   (declare (type disassem-state dstate))
-  (let ((header-addresses (dstate-fun-header-addresses dstate)))
-    (and header-addresses
-	 (= (dstate-curpos dstate) (car header-addresses)))))
+  (let ((header-addresses (dstate-cur-fun-header-addresses dstate)))
+    (when header-addresses
+      (let ((addr (dstate-curpos dstate)))
+	(if (< (car header-addresses) addr)
+	    (do ()
+		((or (null header-addresses)
+		     (>= (car header-addresses) addr))
+		 (cond ((and header-addresses
+			     (= addr (car header-addresses)))
+			(setf (dstate-cur-fun-header-addresses dstate) (cdr header-addresses))
+			t)
+		       (t
+			(setf (dstate-cur-fun-header-addresses dstate) header-addresses)
+			nil)))
+	      (pop header-addresses))
+	    (if (= addr (car header-addresses))
+		(progn
+		  (setf (dstate-cur-fun-header-addresses dstate) (cdr header-addresses))
+		  t)
+		nil))))))
 
 (defun print-fun-header (stream dstate)
   "Print the function-header (entry-point) pseudo-instruction at the current
   location in DSTATE to STREAM."
   (declare (type stream stream)
 	   (type disassem-state dstate))
-  (pop (dstate-fun-header-addresses dstate))
   (let* ((code (dstate-code dstate))
-	 (woffs (to-words (dstate-cur-code-offset dstate)))
+	 (woffs
+	  (to-words
+	   (dstate-code-addr-offset dstate (dstate-curpos dstate))))
 	 (name
 	  (kernel:code-header-ref code (+ woffs vm:function-header-name-slot)))
 	 (args
@@ -1647,40 +2222,49 @@ symbol object that we know about.")
 (defun check-for-moved-code (dstate)
   "If the code object in DSTATE has moved since we last checked, make the sap
   pointing to the start of the segment point to its corresponding location at
-  the new address."
+  the new address.  Isn't worth much unless called with GCing turned off."
   (declare (type disassem-state dstate))
   (let ((code (dstate-code dstate)))
     (when code
-      (let ((old-code-insts-addr
-	     (dstate-code-insts-addr dstate))
-	    (new-code-insts-addr
-	     (system:sap-int (kernel:code-instructions code))))
+      (let ((old-code-insts-addr (dstate-real-code-insts-addr dstate))
+	    (new-code-insts-addr (code-inst-area-address code)))
 	(when (/= old-code-insts-addr
 		  new-code-insts-addr)
+#+nil	  (format t "~&;;; CODE MOVED: #x~x --> #x~x~%"
+		  old-code-insts-addr
+		  new-code-insts-addr)
 	  (setf (dstate-segment-sap dstate)
 		(system:int-sap
 		 (+ new-code-insts-addr
-		    (- (system:sap-int (dstate-segment-sap dstate))
-		       old-code-insts-addr))))
-	  (setf (dstate-code-insts-addr dstate)
+		    (- (dstate-segment-start dstate)
+		       (dstate-code-insts-addr dstate)))))
+#+nil	  (format t "~&;;; SAP now points at #x~x (#~x+~d)~%"
+		  (system:sap-int (dstate-segment-sap dstate))
+		  new-code-insts-addr
+		  (- (dstate-segment-start dstate)
+		       (dstate-code-insts-addr dstate)))
+	  (setf (dstate-real-code-insts-addr dstate)
 		new-code-insts-addr))))))
 
 ;;; ----------------------------------------------------------------
 
+(defun rewind-current-segment (dstate)
+  (declare (type disassem-state dstate))
+  (setf (dstate-curpos dstate) (dstate-segment-start dstate)
+	(dstate-cur-fun-header-addresses dstate) (dstate-fun-header-addresses dstate)
+	(dstate-cur-labels dstate) (dstate-labels dstate)))
+
 (defun compute-labels (dstate)
   "Make an initial non-printing disassembly pass through DSTATE, noting any
-  addresses that are referenced by instructions that point within its segment,
-  and recording them in the LABEL-HASH (a hashtable mapping addresses to
-  label-names) and LABELS (an alist of (address . label-name) sorted by
-  address) fields of DSTATE."
+  addresses that are referenced by instructions."
+  ;; add labels at the beginning with a label-number of nil; we'll notice
+  ;; later and fill them in (and sort them)
   (declare (type disassem-state dstate))
-  (let ((base-address (dstate-segment-start dstate))
-	(length (dstate-segment-length dstate))
-	(byte-order (dstate-byte-order dstate))
-	(ispace (params-inst-space (dstate-params dstate)))
-	(addrs nil))
+  (let ((byte-order (dstate-byte-order dstate))
+	(ispace (get-inst-space (dstate-params dstate)))
+	(labels (dstate-labels dstate)))
 
-    (setf (dstate-curpos dstate) (dstate-segment-start dstate))
+    (rewind-current-segment dstate)
 
     (loop
       (unless (aligned-p (dstate-curpos dstate) (dstate-alignment dstate))
@@ -1690,19 +2274,11 @@ symbol object that we know about.")
       (let ((offs (- (dstate-curpos dstate) (dstate-segment-start dstate))))
 	(when (>= offs (dstate-segment-length dstate))
 	  ;; done!
-	  (let ((label-count 0)
-		(label-hash (dstate-label-hash dstate)))
-	    (setf (dstate-labels dstate)
-		  (mapcar #'(lambda (addr)
-			      (let ((name (format nil "L~d" label-count)))
-				(incf label-count)
-				(setf (gethash addr label-hash) name)
-				(cons addr name)))
-			  (sort addrs #'<))))
-	  (setf (dstate-pending-notes dstate) nil) ; just in case any got
+	  (setf (dstate-labels dstate) labels)
+	  (setf (dstate-notes dstate) nil) ; just in case any got
 					; left there by labeling
 					; (they shouldn't but...)
-	  (return))
+	  (return labels))
 
 	(system:without-gcing
 	 (check-for-moved-code dstate)
@@ -1717,10 +2293,8 @@ symbol object that we know about.")
 					byte-order))
 		       (inst (find-inst chunk ispace)))
 		  (labels ((add-label (addr)
-			     (unless (or (< addr base-address)
-					 (>= addr (+ base-address length))
-					 (find addr addrs :test #'=))
-			       (push addr addrs)))
+			     (unless (find addr labels :test #'= :key #'car)
+			       (push (cons addr nil) labels)))
 			   (maybe-label-field (field type)
 			     (when (field-type-p type)
 			       (let ((use-label (ftype-use-label type)))
@@ -1776,6 +2350,27 @@ symbol object that we know about.")
 				 (dstate-nextpos dstate))
 			   )))))))))))
 
+(defun number-labels (dstate)
+  "If any labels in DSTATE have been added since the last call to this
+  function, give them label-numbers, enter them in the hash-table, and make
+  sure the label list is in sorted order."
+  (let ((labels (dstate-labels dstate)))
+    (when (and labels (null (cdar labels)))
+      ;; at least one label left un-numbered
+      (setf labels (sort labels #'< :key #'car))
+      (let ((max -1)
+	    (label-hash (dstate-label-hash dstate)))
+	(dolist (label labels)
+	  (when (not (null (cdr label)))
+	    (setf max (max max (cdr label)))))
+	(dolist (label labels)
+	  (when (null (cdr label))
+	    (incf max)
+	    (setf (cdr label) max)
+	    (setf (gethash (car label) label-hash)
+		  (format nil "L~d" max)))))
+      (setf (dstate-labels dstate) labels))))
+
 ;;; ----------------------------------------------------------------
 
 (defun get-inst-space (params)
@@ -1794,6 +2389,40 @@ symbol object that we know about.")
     ispace))  
 
 ;;; ----------------------------------------------------------------
+;;; add global hooks
+
+(defun add-hook (dstate addr hook)
+  (let ((entry (cons addr hook)))
+    (if (null (dstate-hooks dstate))
+	(setf (dstate-hooks dstate) (list entry))
+	(push entry (cdr (last (dstate-hooks dstate)))))))
+
+(defun add-note-hook (dstate addr note)
+  (add-hook dstate
+	    addr
+	    #'(lambda (stream)
+		(when stream
+		  (note note dstate)))))
+
+(defun add-comment-hook (dstate addr comment)
+  (add-hook dstate
+	    addr
+	    #'(lambda (stream)
+		(when stream
+		  (write-string ";;; " stream)
+		  (etypecase comment
+		    (string
+		     (write-string comment stream))
+		    (function
+		     (funcall comment stream)))
+		  (terpri stream)))))
+
+;;; ----------------------------------------------------------------
+
+(defun set-address-printing-range (dstate from length)
+  (setf (dstate-addr-print-len dstate)
+	;; 4 bits per hex digit
+	(ceiling (integer-length (logxor from (+ from length))) 4)))
 
 (defun print-current-address (stream dstate)
   "Print the current address in DSTATE to STREAM, plus any labels that
@@ -1803,54 +2432,27 @@ symbol object that we know about.")
   (let ((address (dstate-curpos dstate))
 	(address-column-width
 	 (params-address-column-width (dstate-params dstate)))
-	(plen (dstate-addr-print-len dstate))
-	(labels (dstate-labels dstate)))
+	(plen (dstate-addr-print-len dstate)))
+
     (when (null plen)
       (setf plen address-column-width)
-      (setf (dstate-addr-print-len dstate)
-	    ;; 4 bits per hex digit
-	    (ceiling (integer-length
-			  (logxor (dstate-segment-start dstate)
-				  (+ (dstate-segment-start dstate)
-				     (dstate-segment-length dstate))))
-		     4)))
-    (cond ((and labels (= (caar labels) address))
-	   (format stream "~v,0t~v,'0x: ~5@<~a:~> "
-		   (- address-column-width plen)
-		   plen
-		   (ldb (byte (* 4 plen) 0) address)
-		   (cdar labels))
-	   (pop (dstate-labels dstate)))
-	  (t
-	   (format stream "~v,0t~v,'0x:       "
-		   (- address-column-width plen)
-		   plen
-		   (ldb (byte (* 4 plen) 0) address))))))
+      (set-address-printing-range dstate
+				  (dstate-segment-start dstate)
+				  (dstate-segment-length dstate)))
+    (when (eq (dstate-output-state dstate) :beginning)
+      (setf plen address-column-width))
+
+    (format stream "~&~v,0t~v,'0x:"
+	    (- address-column-width plen)
+	    plen
+	    (ldb (byte (* 4 plen) 0) address))
+    (with-matching-addresses (label-number address (dstate-cur-labels dstate))
+      (format stream " L~d:" label-number))
+    (format stream "~v,0t" (+ address-column-width 1 label-column-width))
+    ))
 
 ;;; ----------------------------------------------------------------
 
-;;; If DSTATE isn't aligned, align it while printing an appropiate `.ALIGN'
-;;; pseudo-instruction to STREAM and starting a new instruction line.  If
-;;; this would put us past the end of the segment, don't print anything.
-(defun maybe-align (stream dstate)
-  (declare (type stream stream)
-	   (type disassem-state dstate))
-  (unless (aligned-p (dstate-curpos dstate) (dstate-alignment dstate))
-    (let ((aligned-pos
-	   (align (dstate-curpos dstate) (dstate-alignment dstate))))
-
-      (setf (dstate-curpos dstate) aligned-pos)
-
-      (unless (>= aligned-pos		; we might be done anyway
-		  (+ (dstate-segment-start dstate)
-		     (dstate-segment-length dstate)))
-	(format stream ".ALIGN~vt~d"
-		(dstate-argument-column dstate)
-		(dstate-alignment dstate))
-	(print-notes-and-newline stream dstate)
-	(print-current-address stream dstate))
-    t)))
-
 (defmacro with-print-restrictions (&rest body)
   `(let ((*print-pretty* t)
 	 (*print-lines* 2)
@@ -1865,16 +2467,16 @@ symbol object that we know about.")
   (declare (type stream stream)
 	   (type disassem-state dstate))
   (with-print-restrictions
-    (dolist (note (dstate-pending-notes dstate))
+    (dolist (note (dstate-notes dstate))
       (format stream "~vt; " *note-column*)
       (etypecase note
 	(string
 	 (write-string note stream))
 	(function
 	 (funcall note stream)))
-      (terpri))
-    (fresh-line)
-    (setf (dstate-pending-notes dstate) nil)))
+      (terpri stream))
+    (fresh-line stream)
+    (setf (dstate-notes dstate) nil)))
 
 (defun print-bytes (num stream dstate)
   "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
@@ -1894,7 +2496,6 @@ symbol object that we know about.")
   (declare (type fixnum num)
 	   (type stream stream)
 	   (type disassem-state dstate))
-  (maybe-align stream dstate)
   (format stream "~a~vt" 'WORD (dstate-argument-column dstate))
   (let ((sap (dstate-segment-sap dstate))
 	(start-offs (- (dstate-curpos dstate) (dstate-segment-start dstate))))
@@ -1902,52 +2503,44 @@ symbol object that we know about.")
       (unless (zerop offs)
 	(write-string ", " stream))
       (format stream "#x~8,'0x"
-	      (system:sap-ref-32 sap
-				 (/ (+ offs start-offs)
-				    vm:word-bytes))))))
+	      (system:sap-ref-32 sap (to-words (+ offs start-offs)))))))
 
 ;;; ----------------------------------------------------------------
 
-(defun create-dstate (base length code params)
-  "Make a disassembler-state object for the area from BASE, LENGTH long,
-  corresponding to the code object CODE.  BASE may be either a sap or an
-  integer address; the call to this function should probably be done with GC
-  disabled, but if CODE is non-NIL, then it's safe to turn GCing back on 
+(defun create-dstate (code params)
+  "Make a disassembler-state object for the code-component CODE (which may
+  also be NIL).  the call to this function should probably be done with GC
+  disabled, but if CODE is non-NIL, then it's safe to turn GCing back on
   again after it returns."
-  (declare (type (or integer system:system-area-pointer) base)
-	   (type fixnum length)
-	   ;?? (type code code)
+  (declare (type (or null kernel:code-component) code)
 	   (type params params))
-  (let ((sap (if (integerp base) (system:int-sap base) base))
-	(addr (if (integerp base) base (system:sap-int base)))
-	(inst-area-sap (kernel:code-instructions code)))
+  (let ((sap
+	 ;; something safe; it will get changed later
+	 (if code
+	     (kernel:code-instructions code)
+	     (system:int-sap
+	      (- (kernel:get-lisp-obj-address nil) vm:list-pointer-type) )))
+	(inst-area-addr (if code (code-inst-area-address code) 0)))
     (make-disassem-state :code code
 			 :segment-sap sap
-			 :segment-start addr
-			 :segment-length length
+			 :segment-start 0
+			 :segment-length 0
 			 :params params
 
 			 :fun-header-addresses
 			   (and code
-				(remove-if #'(lambda (fun-header-addr)
-					       (< fun-header-addr addr))
-					   (make-sorted-fun-header-addr-list
-					    code)))
+				(make-sorted-fun-header-addr-list code))
+			 :real-code-insts-addr inst-area-addr
+			 :code-insts-addr inst-area-addr
 			 :code-insts-offset
-			   (if code
-			       (code-addr-offset code
-						 (system:sap-int
-						   inst-area-sap))
-			       0)
-			 :code-insts-addr
-			   (if code
-			       (system:sap-int inst-area-sap)
-			       0)
+			   (if code (code-addr-offset code inst-area-addr) 0)
+
 			 :argument-column
 			   (+ (or *opcode-column-width*
 				  (params-opcode-column-width params)
 				  0)
 			      (params-address-column-width params)
+			      1
 			      label-column-width)
 			 :alignment
 			   (params-instruction-alignment params)
@@ -1955,36 +2548,55 @@ symbol object that we know about.")
 			   (c:backend-byte-order (params-backend params))
 			 )))
 
-(defun disassemble-segment (dstate stream &optional (use-labels t))
-  "Disassemble the memory segment in DSTATE to STREAM.  If USE-LABELS is
-  non-NIL, calculate and print labels for branches, etc, instead of using raw
-  addresses-- this requires that two passes be made."
+(defun set-dstate-segment (dstate base length)
+  "Make the current segment in DSTATE to start at BASE and be LENGTH long"
+  (let ((sap
+	 (if (integerp base)
+	     (system:int-sap (dstate-true-code-address dstate base))
+	     base))
+	(addr (if (integerp base) base (system:sap-int base))))
+    (setf (dstate-segment-sap dstate) sap
+	  (dstate-segment-start dstate) addr
+	  (dstate-segment-length dstate) length)
+    nil))
+
+(defun disassemble-current-segment (dstate stream)
+  "Disassemble the current memory segment in DSTATE to STREAM."
   (declare (type stream stream)
 	   (type disassem-state dstate)
 	   (type (member t nil) t))
   (let ((ispace (get-inst-space (dstate-params dstate))))
-
-    (when use-labels
-      (compute-labels dstate))
-
-    (fresh-line)			; otherwise, was tabbing funny on the
+    (fresh-line stream)			; otherwise, was tabbing funny on the
 					; first line
 
-    (setf (dstate-curpos dstate) (dstate-segment-start dstate))
+    (number-labels dstate)
+    (rewind-current-segment dstate)
 
     (loop
-      (let ((offs (- (dstate-curpos dstate) (dstate-segment-start dstate))))
-	(when (>= offs (dstate-segment-length dstate))
-	  ;; done!
-	  (return))
-
-	(print-current-address stream dstate)
-
-	(when (maybe-align stream dstate)
-	  (setf offs (- (dstate-curpos dstate) (dstate-segment-start dstate)))
-	  (when (>= offs (dstate-segment-length dstate))
-	    ;; done!
-	    (return)))
+      (let (offs)
+	(loop
+	  (let ((curpos (dstate-curpos dstate))
+		(align (dstate-alignment dstate)))
+	    (setf offs (- curpos (dstate-segment-start dstate)))
+	    (when (>= offs (dstate-segment-length dstate))
+	      ;; done!
+	      (return-from disassemble-current-segment))
+
+	    (with-matching-addresses (hook curpos (dstate-cur-hooks dstate))
+	      (funcall hook stream))
+
+	    (print-current-address stream dstate)
+
+	    (when (aligned-p curpos align)
+	      ;; stop trying to align things
+	      (return))
+
+	    (format stream "~a~vt~d~%" '.align
+		    (dstate-argument-column dstate)
+		    align)
+	    (setf (dstate-curpos dstate) (align curpos align))
+	    ;; now go around and try again!
+	    ))
 
 	(system:without-gcing
 	 (check-for-moved-code dstate)
@@ -2025,31 +2637,23 @@ symbol object that we know about.")
 			 (setf (dstate-curpos dstate)
 			       (dstate-nextpos dstate))))))))
 
-	(print-notes-and-newline stream dstate)))))
+	(print-notes-and-newline stream dstate)
+	(setf (dstate-output-state dstate) nil)
+	))))
 
 ;;; ----------------------------------------------------------------
-;;; top level calls... stolen from pmax-disassem.lisp
-
-(defun compile-function-lambda-expr (function)
-  (multiple-value-bind
-      (lambda closurep name)
-      (function-lambda-expression function)
-    (declare (ignore name))
-    (when closurep
-      (error "Cannot compile lexical closure."))
-    (compile nil lambda)))
 
 ;;; just for fun
 (defun print-fun-headers (function)
   (declare (type compiled-function function))
-  (let* ((self (system:%primitive function-self function))
+  (let* ((self (fun-self function))
 	 (code (kernel:function-code-header self)))
     (format t "Code-header ~s: size: ~s, trace-table-offset: ~s~%"
 	    code
 	    (kernel:code-header-ref code vm:code-code-size-slot)
 	    (kernel:code-header-ref code vm:code-trace-table-offset-slot))
     (do ((fun (kernel:code-header-ref code vm:code-entry-points-slot)
-	      (system:%primitive function-next fun)))
+	      (fun-next fun)))
 	((null fun))
       (let ((fun-offset (kernel:get-closure-length fun)))
 	;; There is function header fun-offset words from the
@@ -2064,35 +2668,490 @@ symbol object that we know about.")
 		(kernel:code-header-ref
 		 code (+ fun-offset vm:function-header-type-slot)))))))
 
-(defun fun-code (fun)
-  (declare (type compiled-function fun))
-  (kernel:function-code-header (system:%primitive function-self fun)))
+;;; ----------------------------------------------------------------
+;;; stuff to use debugging-info to augment the disassembly
 
-(defun disassemble-function (function &key (stream *standard-output*)
-				           (use-labels t)
-					   (backend c:*backend*))
+(defun code-function-map (code)
+  (declare (type kernel:code-component code))
+  (di::get-debug-info-function-map
+   (kernel:code-header-ref code vm:code-debug-info-slot)))
+
+(defstruct storage-class
+  (name nil :type symbol)
+  (locations #() :type (vector (or list fixnum)))
+  )
+
+(defstruct storage-info
+  (classes nil :type list)		; alist of (name . sc-info)
+  (debug-variables #() :type vector)
+  )
+
+(defun dstate-debug-variables (dstate)
+  "Return the vector of debug-variables currently associated with DSTATE."
+  (declare (type disassem-state dstate))
+  (storage-info-debug-variables (dstate-storage-info dstate)))
+
+(defun find-valid-storage-location (offset sc-name dstate)
+  "Given the OFFSET of a location within the storage class SC-NAME (which is
+  *not* the same as the compiler's SC), see if there's a current mapping to a
+  source variable in DSTATE, and if so, return the offset of that variable in
+  the current debug-variable vector."
+  (declare (type fixnum offset)
+	   (type symbol sc-name)
+	   (type disassem-state dstate))
+  (let* ((storage-info
+	  (dstate-storage-info dstate))
+	 (storage-class
+	  (and storage-info
+	       (cdr (assoc sc-name (storage-info-classes storage-info)))))
+	 (currently-valid
+	  (dstate-current-valid-locations dstate)))
+    (and storage-class
+	 (not (null currently-valid))
+	 (let ((locations (storage-class-locations storage-class)))
+	   (and (< offset (length locations))
+		(let ((used-by (aref locations offset)))
+		  (and used-by
+		       (let ((debug-var-num
+			      (typecase used-by
+				(fixnum
+				 (and (not
+				       (zerop (bit currently-valid used-by)))
+				      used-by))
+				(list
+				 (some #'(lambda (num)
+					   (and (not
+						 (zerop
+						  (bit currently-valid num)))
+						num))
+				       used-by)))))
+			 (and debug-var-num
+			      (progn
+				;; Found a valid storage reference!
+				;; can't use it again until it's revalidated...
+				(setf (bit (dstate-current-valid-locations dstate)
+					   debug-var-num)
+				      0)
+				debug-var-num))
+			 ))))))))
+
+(defun copy-bit-vector (bvec)
+  "This is stupid."
+  (declare (type simple-bit-vector bvec))
+  (let ((copy (bit-not bvec)))
+    (bit-not copy copy)
+    copy))
+
+(defun grow-vector (vec new-len &optional initial-element)
+  "Return a new vector which has the same contents as the old one VEC, plus
+  new cells (for a total size of NEW-LEN).  The additional elements are
+  initailized to INITIAL-ELEMENT."
+  (declare (type vector vec)
+	   (type fixnum new-len)) 
+  (let ((new
+	 (make-sequence `(vector ,(array-element-type vec) ,new-len)
+			new-len
+			:initial-element initial-element)))
+    (dotimes (i (length vec))
+      (setf (aref new i) (aref vec i)))
+    new))
+
+(defun storage-info-for-debug-function (debug-function dstate)
+  "Returns a STORAGE-INFO struction describing the object-to-source
+  variable mappings from DEBUG-FUNCTION."
+  (declare (type di:debug-function debug-function)
+	   (type disassem-state dstate))
+  (let ((compiler-sc-vec
+	 (c::backend-sc-numbers
+	  (params-backend (dstate-params dstate))))
+	(sc-sets
+	 (params-storage-class-sets
+	  (dstate-params dstate)))
+	(classes
+	 nil)
+	(debug-variables
+	 (di::debug-function-debug-variables debug-function)))
+    (dotimes (debug-var-offset (length debug-variables))
+      (let ((debug-var (aref debug-variables debug-var-offset)))
+#+nil	(format t ";;; At offset ~d: ~s~%" debug-var-offset debug-var)
+	(let* ((compiler-sc-offset
+		(di::compiled-debug-variable-sc-offset debug-var))
+	       (compiler-sc
+		(aref compiler-sc-vec
+		      (c:sc-offset-scn compiler-sc-offset)))
+	       (compiler-sc-name
+		(c:sc-name compiler-sc))
+	       (set-name
+		(car (find compiler-sc-name sc-sets
+			   :test #'(lambda (name set)
+				     (member name (cdr set)))))))
+#+nil	  (format t ";;; CSC: ~s, SET: ~s[~d]~%" compiler-sc-name set-name
+		  (c:sc-offset-offset compiler-sc-offset))
+	  (unless (null set-name)
+	    (let ((class (cdr (assoc set-name classes))))
+	      (when (null class)
+		(setf class (make-storage-class :name set-name))
+		(push `(,set-name . ,class) classes))
+	      (let* ((locations (storage-class-locations class))
+		     (length (length locations))
+		     (offset (c:sc-offset-offset compiler-sc-offset)))
+		(when (>= offset length)
+		  (setf locations
+			(grow-vector locations
+				     (max (* 2 length)
+					  (1+ offset))
+				     nil)
+			(storage-class-locations class)
+			locations))
+		(let ((already-there (aref locations offset)))
+		  (cond ((null already-there)
+			 (setf (aref locations offset) debug-var-offset))
+			((eql already-there debug-var-offset))
+			(t
+			 (if (listp already-there)
+			     (pushnew debug-var-offset (aref locations offset))
+			     (setf (aref locations offset)
+				   (list debug-var-offset already-there)))))
+		  )))))))
+    (make-storage-info :classes classes
+		       :debug-variables debug-variables)))
+
+(defun source-available-p (debug-function)
+  (handler-case
+      (di:do-blocks (block debug-function)
+	(declare (ignore block))
+	(return t))
+    (di:no-debug-blocks () nil)))
+
+(defun print-block-boundary (stream dstate)
+  (let ((os (dstate-output-state dstate)))
+    (when (not (eq os :beginning))
+      (when (not (eq os :block-boundary))
+	(terpri stream))
+      (setf (dstate-output-state dstate)
+	    :block-boundary))))
+
+(defun source-tracking-hooks-for-debug-function (debug-function dstate &optional sfcache)
+  "Return a set of hooks to track to track the source code from DEBUG-FUNCTION during
+  disassembly.  SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
+  structure, in which case it is used to cache forms from files."
+  (declare (type di:debug-function debug-function)
+	   (type (or null source-form-cache) sfcache)
+	   (type disassem-state dstate))
+  (let ((last-block-pc -1)
+	(hooks nil))
+    (flet ((add-hook (pc fun)
+	     (push (cons (dstate-code-insts-offs-address dstate pc) fun)
+		   hooks)))
+      (handler-case
+	  (di:do-blocks (block debug-function)
+	    (let ((first-location-in-block-p t))
+	      (di:do-debug-block-locations (loc block)
+		(let ((pc (di::compiled-code-location-pc loc)))
+
+		  ;; Put blank lines in at block boundaries
+		  (when (and first-location-in-block-p
+			     (/= pc last-block-pc))
+		    (setf first-location-in-block-p nil)
+		    (add-hook pc #'(lambda (stream)
+				     (print-block-boundary stream dstate)))
+		    (setf last-block-pc pc))
+
+		  ;; Print out corresponding source; this information is not all
+		  ;; that accurate, but it's better than nothing
+		  (unless (zerop (di:code-location-form-number loc))
+		    (multiple-value-bind (form new)
+			(get-different-source-form loc 0 sfcache)
+		      (when new
+			 (let ((at-block-begin (= pc last-block-pc)))
+			   (add-hook pc
+				     #'(lambda (stream)
+					 (when stream
+					   (unless at-block-begin
+					     (terpri stream))
+					   (format stream ";;; [~d] "
+						   (di:code-location-form-number loc))
+					   (prin1-short form stream)
+					   (terpri stream)
+					   (terpri stream))))))))
+
+		  ;; Keep track of variable live-ness as best we can
+		  (let ((live-set
+			 (copy-bit-vector
+			  (di::compiled-code-location-live-set loc))))
+		    (add-hook pc
+			      #'(lambda (stream)
+				  (declare (ignore stream))
+				  (setf (dstate-current-valid-locations dstate)
+					live-set)
+      #+nil			    (note #'(lambda (stream)
+					    (let ((*print-length* nil))
+					      (format stream "Live set: ~s" live-set)))
+					dstate))))
+		  ))))
+	(di:no-debug-blocks () nil)))
+    (nreverse hooks)))
+
+;;; ----------------------------------------------------------------
+
+(defstruct (segment (:conc-name seg-)
+		    (:print-function %print-segment))
+  (start 0 :type integer)
+  (length 0 :type fixnum)
+  (debug-function nil :type (or null di:debug-function))
+  (storage-info nil :type (or null storage-info))
+  (hooks nil :type list)
+  )
+
+(defun %print-segment (seg stream level)
+  (declare (ignore level))
+  (format stream "#<Memory segment #x~x[~d]~@[ in ~s~]>"
+	  (seg-start seg)
+	  (seg-length seg)
+	  (and (seg-debug-function seg)
+	       (di:debug-function-name (seg-debug-function seg)))))
+
+(defun create-segment (addr length debug-function dstate &optional sfcache)
+  "Return a memory segment starting at ADDR and LENGTH bytes long, and using
+  debugging information from DEBUG-FUNCTION unless it's NIL.  SFCACHE may be
+  optionally supplied to improve access to the source-code."
+  (let ((storage-info
+	 (and debug-function
+	      (storage-info-for-debug-function debug-function
+					       dstate)))
+	(hooks
+	 (and debug-function
+	      (source-tracking-hooks-for-debug-function debug-function
+							dstate
+							sfcache))))
+    (when debug-function
+      (let ((kind (di:debug-function-kind debug-function)))
+	(flet ((anh (n)
+	         (push (cons addr
+			     #'(lambda (stream)
+				 (declare (ignore stream))
+				 (note n dstate)))
+		       hooks)))
+	  (case kind
+	    (:external)
+	    ((nil)
+	     (anh "No-arg-parsing entry point"))
+	    (t
+	     (anh #'(lambda (stream)
+		      (format stream "~s entry point" kind))))))))
+    (make-segment :start addr
+		  :length length
+		  :debug-function debug-function
+		  :storage-info storage-info
+		  :hooks hooks)))
+
+(defun get-function-segments (function dstate)
+  "Returns a list of the segments of memory containing machine code
+  instructions for FUNCTION.  DSTATE is used to translate from instruction
+  offsets to addresses."
   (declare (type compiled-function function))
   (let* ((code (fun-code function))
-	 (trace-table-offset
-	  (kernel:code-header-ref code vm:code-trace-table-offset-slot))
-	 (dstate
+	 (function-map (code-function-map code))
+	 (fname (kernel:%function-header-name function))
+	 (sfcache (make-source-form-cache)))
+    (let ((first-block-seen-p nil)
+	  (nil-block-seen-p nil)
+	  (last-offset 0)
+	  (last-debug-function nil)
+	  (segments nil))
+      (flet ((add-seg (offs len df)
+	       (when (> len 0)
+		 (push (create-segment
+			(dstate-code-insts-offs-address dstate offs)
+			len
+			df
+			dstate
+			sfcache)
+		       segments))))
+	(dotimes (fmap-index (length function-map))
+	  (let ((fmap-entry (aref function-map fmap-index)))
+	    (etypecase fmap-entry
+	      (integer
+	       (when first-block-seen-p
+		 (add-seg last-offset
+			  (- fmap-entry last-offset)
+			  last-debug-function)
+		 (setf last-debug-function nil))
+	       (setf last-offset fmap-entry))
+	      (c::compiled-debug-function
+	       (let ((name (c::compiled-debug-function-name fmap-entry))
+		     (kind (c::compiled-debug-function-kind fmap-entry)))
+#+nil	         (format t ";;; SAW ~s ~s ~s,~s ~d,~d~%"
+				       name kind first-block-seen-p nil-block-seen-p
+				       last-offset (c::compiled-debug-function-start-pc fmap-entry))
+		 (cond (#+nil (eq last-offset fun-offset)
+			      (and (equal name fname) (not first-block-seen-p))
+			      (setf first-block-seen-p t))
+		       ((eq kind :external)
+			(when first-block-seen-p
+			  (return)))
+		       ((eq kind nil)
+			(when nil-block-seen-p
+			  (return))
+			(when first-block-seen-p
+			  (setf nil-block-seen-p t))))
+		 (setf last-debug-function
+		       (di::make-compiled-debug-function fmap-entry code))
+		 )))))
+	(let ((max-offset (code-inst-area-length code)))
+	  (when (and first-block-seen-p last-debug-function)
+	    (add-seg last-offset
+		     (- max-offset last-offset)
+		     last-debug-function))
+	  (if (null segments)
+	      (let ((offs (fun-offset function)))
+		(make-segment
+		 :start (dstate-code-insts-offs-address dstate offs)
+		 :length (- max-offset offs)))
+	      (nreverse segments)))))))
+
+(defun get-code-segments (dstate &optional
+				 (start (dstate-code-insts-addr dstate))
+				 (length (code-inst-area-length (dstate-code dstate))))
+  "Returns a list of the segments of memory containing machine code
+  instructions for the code-component in DSTATE.  If START and/or LENGTH is
+  supplied, only that part of the code-segment is used (but these are
+  constrained to lie within the code-segment)."
+  (declare (type disassem-state dstate)
+	   (type integer start)
+	   (type fixnum length))
+  (let ((code-component (dstate-code dstate))
+	(segments nil))
+    (when code-component
+      (let ((function-map (code-function-map code-component))
+	    (sfcache (make-source-form-cache)))
+	(let ((last-offset 0)
+	      (last-debug-function nil))
+	  (flet ((add-seg (offs len df)
+			  (let* ((raw-addr (dstate-code-insts-offs-address dstate offs))
+				 (addr (min (max start raw-addr) (+ start length)))
+				 (len
+				  (- (min (max start (+ raw-addr len)) (+ start length))
+				     addr)))
+			    (when (> len 0)
+			      (push (create-segment addr len df dstate sfcache)
+				    segments)))))
+	    (dotimes (fmap-index (length function-map))
+	      (let ((fmap-entry (aref function-map fmap-index)))
+		(etypecase fmap-entry
+		  (integer
+		   (add-seg last-offset (- fmap-entry last-offset) last-debug-function)
+		   (setf last-debug-function nil)
+		   (setf last-offset fmap-entry))
+		  (c::compiled-debug-function
+		   (setf last-debug-function
+			 (di::make-compiled-debug-function fmap-entry code-component)))
+		  )))
+	    (when last-debug-function
+	      (add-seg last-offset
+		       (- (code-inst-area-length code-component) last-offset)
+		       last-debug-function))))))
+    (if (null segments)
+	(make-segment :start start :length length)
+	(nreverse segments))))
+
+;;; ----------------------------------------------------------------
+
+#+nil
+(defun find-function-segment (fun)
+  "Return the address of the instructions for function and its length.
+  The length is computed using a heuristic, and so may not be accurate."
+  (declare (type compiled-function fun))
+  (let* ((code
+	  (fun-code fun))
+	 (fun-addr
+	  (- (kernel:get-lisp-obj-address fun)
+	     vm:function-pointer-type))
+	 (max-length
+	  (code-inst-area-length code))
+	 (upper-bound
+	  (+ (code-inst-area-address code) max-length)))
+    (do ((some-fun (code-first-function code)
+		   (fun-next some-fun)))
+	((null some-fun)
+	 (values fun-addr (- upper-bound fun-addr)))
+      (let ((some-addr (fun-address some-fun)))
+	(when (and (> some-addr fun-addr)
+		   (< some-addr upper-bound))
+	  (setf upper-bound some-addr))))))
+
+;;; ----------------------------------------------------------------
+
+(defun label-segments (seglist dstate)
+  "Computes labels for all the memory segments in SEGLIST and adds them to
+  DSTATE.  It's important to call this function with all the segments you're
+  interested in, so it can find references from one to another."
+  (declare (type list seglist)
+	   (type disassem-state dstate))
+  (dolist (seg seglist)
+    (set-dstate-segment dstate (seg-start seg) (seg-length seg))
+    (compute-labels dstate)))
+
+(defun disassemble-segment (segment stream dstate)
+  "Disassemble the machine code instructions in SEGMENT to STREAM."
+  (set-dstate-segment dstate (seg-start segment) (seg-length segment))
+  (setf (dstate-storage-info dstate) (seg-storage-info segment))
+  (setf (dstate-cur-hooks dstate)
+	(sort (append (seg-hooks segment) (dstate-hooks dstate)) #'< :key #'car))
+  (disassemble-current-segment dstate stream))
+
+(defun disassemble-segments (segments stream dstate)
+  "Disassemble the machine code instructions in each memory segment in
+  SEGMENTS in turn to STREAM."
+  (unless (null segments)
+    (let ((first (car segments))
+	  (last (car (last segments))))
+      (set-address-printing-range dstate
+				  (seg-start first)
+				  (- (+ (seg-start last) (seg-length last))
+				     (seg-start first)))
+      (setf (dstate-output-state dstate) :beginning)
+      (unless (and (seg-debug-function first)
+		   (source-available-p (seg-debug-function first)))
+	(format stream "~&;;; Not enough debugging information to find source code~%"))
+      (dolist (seg segments)
+	(disassemble-segment seg stream dstate)))))
+
+;;; ----------------------------------------------------------------
+;;; top-level functions
+
+(defun disassemble-function (function &key (stream *standard-output*)
+				      (use-labels t)
+				      (backend c:*backend*))
+  "Disassemble the machine code instructions for FUNCTION."
+  (declare (type compiled-function function)
+	   (type stream stream)
+	   (type (member t nil) use-labels)
+	   (type c::backend backend))
+  (let* ((dstate
 	  (system:without-gcing
-	   (create-dstate (kernel:code-instructions code)
-			  trace-table-offset
-			  code
-			  (c:backend-disassem-params backend)))))
-    (disassemble-segment dstate stream use-labels)))
+	   (create-dstate (fun-code function)
+			  (c:backend-disassem-params backend))))
+	 (segments (get-function-segments function dstate)))
+    (when use-labels
+      (label-segments segments dstate))
+    (disassemble-segments segments stream dstate)))
+
+(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 "Cannot compile a lexical closure"))
+    (compile nil lambda)))
 
-(defun compiled-function-or-lose (thing)
+(defun compiled-function-or-lose (thing &optional (name thing))
   (cond ((or (symbolp thing)
 	     (and (listp thing)
 		  (eq (car thing) 'lisp:setf)))
-	 (let ((temp (fdefinition thing)))
-	   (when (not (functionp temp))
-	     (error "~s has no function" thing))
-	   (if (eval:interpreted-function-p temp)
-	       (compile-function-lambda-expr temp)
-	       temp)))
+	 (compiled-function-or-lose (fdefinition thing) thing))
 	((eval:interpreted-function-p thing)
 	 (compile-function-lambda-expr thing))
 	((functionp thing)
@@ -2101,53 +3160,86 @@ symbol object that we know about.")
 	      (eq (car thing) 'lisp::lambda))
 	 (compile nil thing))
 	(t
-	 (error "Invalid argument to disassemble: ~S"
-		thing))))
+	 (error "Can't make a compiled function from ~S" name))))
 
 (defun disassemble (object &optional (stream *standard-output*)
 			   &key (use-labels t)
-			        (backend c:*backend*))
+			   (backend c:*backend*))
   "Disassemble the machine code associated with OBJECT, which can be a
   function, a lambda expression, or a symbol with a function definition.  If
   it is not already compiled, the compiler is called to produce something to
-  disassemble.  Note that the code often includes multiple entry points, of
-  which only one is the actual function-- others include the code to DEFUN
-  the object, etc.  It should be obvious which entry point is the correct
-  one, however.  If STREAM is NIL, *STANDARD-OUTPUT* is used (so you can 
+  disassemble.  If STREAM is T, *STANDARD-OUTPUT* is used (so you can 
   use the keywords without having to type it!)."
   (declare (type (or function symbol cons) object)
-	   (type (or null stream) stream)
+	   (type (or (member t) stream) stream)
 	   (type (member t nil) use-labels)
 	   (type c::backend backend))
-  (disassemble-function (compiled-function-or-lose object)
-			:stream (or stream *standard-output*)
+  (disassemble-function (fun-self	; we can't detect closures, so
+					; be careful
+			 (compiled-function-or-lose object))
+			:stream (if (eq stream t)
+				    *standard-output*
+				    stream)
 			:use-labels use-labels
 			:backend backend))
 
 (defun disassemble-memory (address length
 				   &key (stream *standard-output*)
+				   code-component
 				   (use-labels t) (backend c:*backend*))
   "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
-  Note that if this memory could move during a GC, you'd better disable it
-  around the call to this function."
+  Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
+  you'd better disable it around the call to this function."
   (declare (type (or integer system:system-area-pointer) address)
 	   (type fixnum length)
 	   (type stream stream)
+	   (type (or null kernel:code-component) code-component)
 	   (type (member t nil) use-labels)
 	   (type c::backend backend))
-  (disassemble-segment (create-dstate address
-				      length
-				      nil
-				      (c:backend-disassem-params
-				       backend))
-		       stream
-		       use-labels))
+  (let*	((dstate
+	  (system:without-gcing
+	   (create-dstate code-component
+			  (c:backend-disassem-params backend))))
+	 (segments
+	  (if code-component
+	      (get-code-segments dstate address length)
+	      (list (make-segment :start address :length length)))))
+    (when use-labels
+      (label-segments segments dstate))
+    (disassemble-segments segments stream dstate)))
+
+(defun disassemble-code-component (code-component &key
+						  (stream *standard-output*)
+						  (use-labels t)
+						  (backend c:*backend*))
+  "Disassemble the machine code instructions associated with
+  CODE-COMPONENT (this may include multiple entry points)."
+  (declare (type (or null kernel:code-component compiled-function) code-component)
+	   (type stream stream)
+	   (type (member t nil) use-labels)
+	   (type c::backend backend))
+  (let*	((dstate
+	  (system:without-gcing
+	   (create-dstate (if (functionp code-component)
+			      (fun-code code-component)
+			      code-component)
+			  (c:backend-disassem-params backend))))
+	 (segments
+	  (get-code-segments dstate)))
+    (when use-labels
+      (label-segments segments dstate))
+    (disassemble-segments segments stream dstate)))
 
 ;;; ----------------------------------------------------------------
 ;;; some handy function for machine-dependent code to use...
 
 (defun note (note dstate)
-  (push note (dstate-pending-notes dstate)))
+  "Store NOTE (which can be either a string or a function with a single
+  stream argument) to be printed as an end-of-line comment after the current
+  instruction is disassembled."
+  (declare (type (or string function) note)
+	   (type disassem-state dstate))
+  (push note (dstate-notes dstate)))
 
 (defun prin1-short (thing stream)
   (with-print-restrictions
@@ -2159,6 +3251,11 @@ symbol object that we know about.")
       (prin1-short `',thing stream)))
 
 (defun note-code-constant (byte-offset dstate)
+  "Store a note about the lisp constant located BYTE-OFFSET bytes from the
+  current code-component, to be printed as an end-of-line comment after the
+  current instruction is disassembled."
+  (declare (type fixnum byte-offset)
+	   (type disassem-state dstate))
   (multiple-value-bind (const valid)
       (get-code-constant byte-offset dstate)
     (when valid
@@ -2168,15 +3265,30 @@ symbol object that we know about.")
     const))
 
 (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
+  "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
+  is a valid slot in a symbol, store a note describing which symbol and slot,
+  to be printed as an end-of-line comment after the current instruction is
+  disassembled.  Returns non-NIL iff a note was recorded."
+  (declare (type fixnum nil-byte-offset)
+	   (type disassem-state dstate))
   (multiple-value-bind (symbol access-fun)
       (grok-nil-indexed-symbol-slot-ref nil-byte-offset)
     (when access-fun
       (note #'(lambda (stream)
-		(prin1 `(,access-fun ',symbol) stream))
+		(prin1 (if (eq access-fun 'symbol-value)
+			   symbol
+			   `(,access-fun ',symbol))
+		       stream))
 	    dstate))
     access-fun))
 
 (defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
+  "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
+  is a valid lisp object, store a note describing which symbol and slot, to
+  be printed as an end-of-line comment after the current instruction is
+  disassembled.  Returns non-NIL iff a note was recorded."
+  (declare (type fixnum nil-byte-offset)
+	   (type disassem-state dstate))
   (let ((obj (get-nil-indexed-object nil-byte-offset)))
     (note #'(lambda (stream)
 	      (prin1-quoted-short obj stream))
@@ -2184,6 +3296,12 @@ symbol object that we know about.")
     t))
 
 (defun maybe-note-assembler-routine (address dstate)
+  "If ADDRESS is the address of a primitive assembler routine, store a note
+  describing which one, to be printed as an end-of-line comment after the
+  current instruction is disassembled.  Returns non-NIL iff a note was
+  recorded."
+  (declare (type integer address)
+	   (type disassem-state dstate))
   (let ((name (find-assembler-routine address)))
     (unless (null name)
       (note #'(lambda (stream)
@@ -2191,6 +3309,48 @@ symbol object that we know about.")
 	    dstate))
     name))
 
+(defun maybe-note-single-storage-ref (offset sc-name dstate)
+  "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
+  source variable, make a note of the source-variable name, to be printed as
+  an end-of-line comment after the current instruction is disassembled.
+  Returns non-NIL iff a note was recorded."
+  (declare (type fixnum offset)
+	   (type symbol sc-name)
+	   (type disassem-state dstate))
+  (let ((storage-location
+	 (find-valid-storage-location offset sc-name dstate)))
+    (when storage-location
+      (note #'(lambda (stream)
+		(princ (di:debug-variable-symbol
+			(aref (storage-info-debug-variables
+			       (dstate-storage-info dstate))
+			      storage-location))
+		       stream))
+	    dstate)
+      t)))
+
+(defun maybe-note-associated-storage-ref (offset sc-name assoc-with dstate)
+  "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
+  source variable, make a note equating ASSOC-WITH with the source-variable
+  name, to be printed as an end-of-line comment after the current instruction
+  is disassembled.  Returns non-NIL iff a note was recorded."
+  (declare (type fixnum offset)
+	   (type symbol sc-name)
+	   (type (or symbol string) assoc-with)
+	   (type disassem-state dstate))
+  (let ((storage-location
+	 (find-valid-storage-location offset sc-name dstate)))
+    (when storage-location
+      (note #'(lambda (stream)
+		(format stream "~a = ~s"
+			assoc-with
+			(di:debug-variable-symbol
+			 (aref (dstate-debug-variables dstate)
+			       storage-location))
+		       stream))
+	    dstate)
+      t)))
+
 ;;; ----------------------------------------------------------------
 ;;; these should be somewhere else...
 
@@ -2207,6 +3367,25 @@ symbol object that we know about.")
 ;;; ----------------------------------------------------------------
 
 (defun handle-break-args (error-parse-fun stream dstate)
+  "When called from an error break instruction's :DISASSEM-CONTROL (or
+  :DISASSEM-PRINTER) function, will correctly deal with printing the
+  arguments to the break.
+
+  ERROR-PARSE-FUN should be a function that accepts:
+    1) a SYSTEM-AREA-POINTER
+    2) a BYTE-OFFSET from the SAP to begin at
+    3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
+       the byte length of the arguments (to avoid unnecessary consing)
+  It should read information from the SAP starting at BYTE-OFFSET, and return
+  four values:
+    1) the error number
+    2) the total length, in bytes, of the information
+    3) a list of SC-OFFSETs of the locations of the error parameters
+    4) a list of the length (as read from the SAP), in bytes, of each of the
+       return-values." 
+  (declare (type function error-parse-fun)
+	   (type (or null stream) stream)
+	   (type disassem-state dstate))
   (multiple-value-bind (errnum adjust sc-offsets lengths)
       (funcall error-parse-fun
 	       (dstate-segment-sap dstate)
-- 
GitLab