Changeset 12949

Timestamp:

Oct 9, 2009, 11:01:30 AM (15 years ago)

Author:

gz

Message:

cleanup of function inspectors and disassembly (r12650, r12682, r12756, r12838, r12846, r12848)

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-disassemble.lisp (modified) (8 diffs)
• compiler/X86/x862.lisp (modified) (2 diffs)
• lib/describe.lisp (modified) (31 diffs)
• lib/misc.lisp (modified) (1 diff)

branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

@@ -2671 +2671 @@
 
 
-    
+(defmethod x86-lap-operand-constant-offset (op ds)
+  (declare (ignore op ds))
+  nil)
+
+(defmethod x86-lap-operand-constant-offset ((op x86::x86-memory-operand) ds)
+  (let* ((disp (x86::x86-memory-operand-disp op)) 
+         (base (x86::x86-memory-operand-base op))
+         (index (x86::x86-memory-operand-index op))
+         (scale (x86::x86-memory-operand-scale op))
+         (code-limit (x86-ds-code-limit ds))
+         (val (and base
+                   (eq (x86::x86-register-operand-entry base)
+                       (if (x86-ds-mode-64 ds)
+                         (x86::x86-reg64 13)
+                         (x86::x86-reg32 x8632::fn)))
+                   (null index)
+                   (or (eql scale 0) (null scale))
+                   (typecase disp
+                     (constant-x86-lap-expression
+                      (+ (x86-ds-entry-point ds)
+                         (constant-x86-lap-expression-value disp)))
+                     (integer
+                      (+ (x86-ds-entry-point ds) disp))
+                     (t nil)))))
+    (when (and val (>= val code-limit))
+      (- val code-limit))))
+
+(defun x86-lap-operand-constant (op ds)
+  (let ((diff (x86-lap-operand-constant-offset op ds)))
+    (when diff
+      (values (uvref (x86-ds-constants-vector ds)
+                     (1+ (ash diff (if (x86-ds-mode-64 ds)
+                                     (- x8664::word-shift)
+                                     (- x8632::word-shift)))))
+              t))))
+
+
 (defmethod unparse-x86-lap-operand ((x x86::x86-memory-operand) ds)
-  (let* ((seg (x86::x86-memory-operand-seg x))
-         (disp (x86::x86-memory-operand-disp x)) 
-         (base (x86::x86-memory-operand-base x))
-         (index (x86::x86-memory-operand-index x))
-         (scale (x86::x86-memory-operand-scale x))
-         (val nil))
-    (if (and base
-             (eq (x86::x86-register-operand-entry base)
-                 (if (x86-ds-mode-64 ds)
-                   (x86::x86-reg64 13)
-                   (x86::x86-reg32 x8632::fn)))
-             (null index)
-             (or (eql scale 0) (null scale))
-             (and (if (typep disp 'constant-x86-lap-expression)
-                    (+ (x86-ds-entry-point ds)
-                                  (constant-x86-lap-expression-value disp))
-                    (unless (typep disp 'x86-lap-expression)
-                      (setq val (if disp
-                                  (+ (x86-ds-entry-point ds)
-                                     disp)))))
-                  (>= val (x86-ds-code-limit ds))))
-      (let* ((diff (- val (x86-ds-code-limit ds)))
-             (constant (uvref (x86-ds-constants-vector ds)
-                              (1+ (ash diff (if (x86-ds-mode-64 ds)
-                                              (- x8664::word-shift)
-                                              (- x8632::word-shift)))))))
-        `(@ ',constant ,(unparse-x86-lap-operand base ds)))
-      (collect ((subforms))
-        (subforms '@)
-        (if seg
-          (subforms (unparse-x86-lap-operand seg ds)))
-        (if disp
-          (subforms (unparse-x86-lap-expression disp ds)))
-        (if base
-          (subforms (unparse-x86-lap-operand base ds)))
-        (if index
-          (subforms (unparse-x86-lap-operand index ds)))
-        (if (and scale (not (eql scale 0)))
-          (subforms (ash 1 scale)))
-        (subforms)))))
+  (multiple-value-bind (constant foundp) (x86-lap-operand-constant x ds)
+    (if foundp
+      `(@ ',constant ,(unparse-x86-lap-operand (x86::x86-memory-operand-base x) ds))
+      (let* ((seg (x86::x86-memory-operand-seg x))
+             (disp (x86::x86-memory-operand-disp x)) 
+             (base (x86::x86-memory-operand-base x))
+             (index (x86::x86-memory-operand-index x))
+             (scale (x86::x86-memory-operand-scale x)))
+        (collect ((subforms))
+          (subforms '@)
+          (if seg
+            (subforms (unparse-x86-lap-operand seg ds)))
+          (if disp
+            (subforms (unparse-x86-lap-expression disp ds)))
+          (if base
+            (subforms (unparse-x86-lap-operand base ds)))
+          (if index
+            (subforms (unparse-x86-lap-operand index ds)))
+          (if (and scale (not (eql scale 0)))
+            (subforms (ash 1 scale)))
+          (subforms))))))
     
 (defmethod unparse-x86-lap-operand :around ((op x86::x86-operand)
@@ -2722 +2739 @@
       `(* ,usual)
       usual)))
+
+(defun write-x86-lap-operand (stream op ds)
+  ;; Basically, have to princ because some parts are already stringified,
+  ;; plus don't want package prefixes on assembler syntax.  But want to
+  ;; prin1 immediates. 
+  (let ((expr (unparse-x86-lap-operand op ds)))
+    (format stream " ")
+    (labels ((out (stream expr)
+               (cond ((atom expr)
+                      (format stream "~a" expr))
+                     ((quoted-form-p expr)
+                      (format stream "'~s" (cadr expr)))
+                     (t
+                      (loop for item in expr as pre = "(" then " "
+                        do (format stream pre)
+                        do (out stream item))
+                      (format stream ")")))))
+      (out stream expr))))
 
 (defvar *previous-source-note*)
@@ -2749 +2784 @@
            (op2 (x86-di-op2 instruction)))
       (when op0
-        (format t " ~a" (unparse-x86-lap-operand op0 ds))
+        (write-x86-lap-operand t op0 ds)
         (when op1
-          (format t " ~a" (unparse-x86-lap-operand op1 ds))
+        (write-x86-lap-operand t op1 ds)
           (when op2
-            (format t " ~a" (unparse-x86-lap-operand op2 ds))))))
+            (write-x86-lap-operand t op2 ds)))))
     (format t ")")
     (format t "~%")
@@ -2769 +2804 @@
       (ensure-source-note-text source-note))))
 
-(defun x8664-disassemble-xfunction (function xfunction
-                                    &key (symbolic-names x8664::*x8664-symbolic-register-names*)
-                                         (collect-function #'x86-print-disassembled-instruction)
-                                         (header-function #'x86-print-disassembled-function-header))
+(defun x86-disassemble-xfunction (function xfunction
+                                  &key (symbolic-names #+x8664-target target::*x8664-symbolic-register-names*
+                                                       #+x8632-target target::*x8632-symbolic-register-names*)
+                                       (collect-function #'x86-print-disassembled-instruction)
+                                       (header-function #'x86-print-disassembled-function-header))
   (check-type xfunction xfunction)
   (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
-  (let* ((ds (make-x86-disassembly-state
+  (let* ((entry-point  #+x8664-target 7  #+x8632-target 2)
+         (ds (make-x86-disassembly-state
+              :mode-64 #+x8664-target t #+x8632-target nil
               :code-vector (uvref xfunction 0)
               :constants-vector xfunction
-              :entry-point 7
-              :code-pointer 0           ; for next-u32 below
+              :entry-point entry-point
+              :code-pointer 0           ; for next-u32/next-u16 below
               :symbolic-names symbolic-names
-              :pending-labels (list 7)))
+              :pending-labels (list entry-point)))
          (blocks (x86-ds-blocks ds)))
     (setf (x86-ds-code-limit ds)
-          (ash (x86-ds-next-u32 ds) 3))
+          #+x8664-target (ash (x86-ds-next-u32 ds) 3)
+          #+x8632-target (ash (x86-ds-next-u16 ds) 2))
     (do* ()
          ((null (x86-ds-pending-labels ds)))
@@ -2790 +2829 @@
         (or (x86-dis-find-label lab blocks)
             (x86-disassemble-new-block ds lab))))
-    (when (and blocks (let ((something-to-disassemble nil))
-                        (do-dll-nodes (block blocks)
-                          (do-dll-nodes (instruction (x86-dis-block-instructions block))
-                            (setf something-to-disassemble t)))
-                        something-to-disassemble))
+    (when (and header-function
+               blocks
+               (let ((something-to-disassemble nil))
+                 (do-dll-nodes (block blocks)
+                   (do-dll-nodes (instruction (x86-dis-block-instructions block))
+                     (setf something-to-disassemble t)))
+                 something-to-disassemble))
       (funcall header-function function xfunction))
     (let* ((seq 0)
@@ -2803 +2844 @@
           (setq seq (funcall collect-function ds instruction seq function)))))))
 
-(defun x8632-disassemble-xfunction (function xfunction
-                                    &key (symbolic-names x8632::*x8632-symbolic-register-names*)
-                                         (collect-function #'x86-print-disassembled-instruction)
-                                         (header-function #'x86-print-disassembled-function-header))
-  (check-type xfunction xfunction)
-  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
-  (let* ((ds (make-x86-disassembly-state
-              :mode-64 nil
-              :code-vector (uvref xfunction 0)
-              :constants-vector xfunction
-              :entry-point 2
-              :code-pointer 0           ; for next-u16 below
-              :symbolic-names symbolic-names
-              :pending-labels (list 2)))
-         (blocks (x86-ds-blocks ds)))
-    (setf (x86-ds-code-limit ds) (ash (x86-ds-next-u16 ds) 2))
-    (do* ()
-         ((null (x86-ds-pending-labels ds)))
-      (let* ((lab (pop (x86-ds-pending-labels ds))))
-        (or (x86-dis-find-label lab blocks)
-            (x86-disassemble-new-block ds lab))))
-    (when (and blocks (let ((something-to-disassemble nil))
-                        (do-dll-nodes (block blocks)
-                          (do-dll-nodes (instruction (x86-dis-block-instructions block))
-                            (setf something-to-disassemble t)))
-                        something-to-disassemble))
-      (funcall header-function function xfunction))
-    (let* ((seq 0)
-           (*previous-source-note* nil))
-      (declare (special *previous-source-note*))
-      (do-dll-nodes (block blocks)
-        (do-dll-nodes (instruction (x86-dis-block-instructions block))
-          (setq seq (funcall collect-function ds instruction seq function)))))))
-
-#+x8664-target
-(defun x8664-xdisassemble (function
-                           &optional (collect-function #'x86-print-disassembled-instruction)
-                                     (header-function #'x86-print-disassembled-function-header))
-  (let* ((fv (%function-to-function-vector function))
+(defun x86-xdisassemble (function
+                         &optional (collect-function #'x86-print-disassembled-instruction)
+                                   (header-function #'x86-print-disassembled-function-header))
+  (let* ((fv (function-to-function-vector function))
          (function-size-in-words (uvsize fv))
          (code-words (%function-code-words function))
-         (ncode-bytes (ash function-size-in-words x8664::word-shift))
+         (ncode-bytes (ash function-size-in-words target::word-shift))
          (code-bytes (make-array ncode-bytes
                                  :element-type '(unsigned-byte 8)))
@@ -2855 +2861 @@
           (j 1 (1+ j)))
          ((= k function-size-in-words)
-          (x8664-disassemble-xfunction function xfunction
-                                       :collect-function collect-function
-                                       :header-function header-function))
+          (x86-disassemble-xfunction function xfunction
+                                     :collect-function collect-function
+                                     :header-function header-function))
       (declare (fixnum j k))
       (setf (uvref xfunction j) (uvref fv k)))))
 
-#+x8632-target
-(defun x8632-xdisassemble (function
-                           &optional (collect-function #'x86-print-disassembled-instruction)
-                                     (header-function #'x86-print-disassembled-function-header))
-  (let* ((fv (function-to-function-vector function))
-         (function-size-in-words (uvsize fv))
-         (code-words (%function-code-words function))
-         (ncode-bytes (ash function-size-in-words x8632::word-shift))
-         (code-bytes (make-array ncode-bytes
-                                 :element-type '(unsigned-byte 8)))
-         (numimms (- function-size-in-words code-words))
-         (xfunction (%alloc-misc (the fixnum (1+ numimms)) target::subtag-xfunction)))
-    (declare (fixnum code-words ncode-bytes numimms))
-    (%copy-ivector-to-ivector fv 0 code-bytes 0 ncode-bytes)
-    (setf (uvref xfunction 0) code-bytes)
-    (do* ((k code-words (1+ k))
-          (j 1 (1+ j)))
-         ((= k function-size-in-words)
-          (x8632-disassemble-xfunction function xfunction
-                                       :collect-function collect-function
-                                       :header-function header-function))
-      (declare (fixnum j k))
-      (setf (uvref xfunction j) (uvref fv k)))))
-
 (defun disassemble-list (function)
   (collect ((instructions))
-    (#+x8632-target x8632-xdisassemble #+x8664-target x8664-xdisassemble
+    (x86-xdisassemble
      function
      #'(lambda (ds instruction seq function)
@@ -2913 +2895 @@
                      (insn (unparse-x86-lap-operand op2 ds))  ))))
              (instructions (insn))
-             (1+ seq)))))
+             (1+ seq))))
+     nil)
     (instructions)))
-                         
-             
-
-           
-         
-
-                                     
-            
-      
-            
-             
+
+(defun x86-disassembled-instruction-line (ds instruction function &optional string-stream)
+  (if (null string-stream)
+    (with-output-to-string (stream)
+      (return-from x86-disassembled-instruction-line
+                   (x86-disassembled-instruction-line ds instruction function stream)))
+    (let* ((addr (x86-di-address instruction))
+           (entry (x86-ds-entry-point ds))
+           (pc (- addr entry))
+           (op0 (x86-di-op0 instruction))
+           (op1 (x86-di-op1 instruction))
+           (op2 (x86-di-op2 instruction))
+           (label (if (x86-di-labeled instruction) (list :label pc) pc))
+           (instr (progn
+                    (dolist (p (x86-di-prefixes instruction))
+                      (format string-stream "(~a) " p))
+                    (format string-stream "(~a" (x86-di-mnemonic instruction))
+                    (when op0 (write-x86-lap-operand string-stream op0 ds))
+                    (when op1 (write-x86-lap-operand string-stream op1 ds))
+                    (when op2 (write-x86-lap-operand string-stream op2 ds))
+                    (format string-stream ")")
+                    (get-output-stream-string string-stream)))
+           (comment (let ((source-note (find-source-note-at-pc function pc)))
+                      (unless (eql (source-note-file-range source-note)
+                                   (source-note-file-range *previous-source-note*))
+                        (setf *previous-source-note* source-note)
+                        (let* ((source-text (source-note-text source-note))
+                               (text (if source-text
+                                       (string-sans-most-whitespace source-text 100)
+                                       "#<no source text>")))
+                          (format string-stream ";;; ~A" text)
+                          (get-output-stream-string string-stream)))))
+           (imms (let ((imms nil))
+                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op2 ds)
+                     (when foundp (push imm imms)))
+                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op1 ds)
+                     (when foundp (push imm imms)))
+                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op0 ds)
+                     (when foundp (push imm imms)))
+                   imms)))
+      ;; Subtle difference between no imms and a single NIL imm, so if anybody ever
+      ;; cares for some reason, they could distinguish the two cases.
+      (if imms
+        (values comment label instr (if (cdr imms) (coerce imms 'vector) (car imms)))
+        (values comment label instr)))))
+
+(defun disassemble-lines (function)
+  (let ((source-note (function-source-note function)))
+    (when source-note
+      ;; Fetch source from file if don't already have it.
+      (ensure-source-note-text source-note)))
+  (let ((lines (make-array 20 :adjustable t :fill-pointer 0)))
+    (with-output-to-string (stream)
+      (x86-xdisassemble
+       function
+       #'(lambda (ds instruction seq function)
+           (declare (ignore seq))
+           (multiple-value-bind (comment label instr object)
+                                (x86-disassembled-instruction-line ds instruction function stream)
+             (when comment
+               (vector-push-extend comment lines))
+             (vector-push-extend (list object label instr) lines)))
+       nil))
+    (coerce lines 'simple-vector)))

branches/working-0711/ccl/compiler/X86/x862.lisp

@@ -10131 +10131 @@
       (when disassemble
         (format t "~%~%")
-        (apply #'x8664-disassemble-xfunction
+        (apply #'x86-disassemble-xfunction
                xlfun
                (unless symbolic-names (list nil))))
@@ -10153 +10153 @@
         (let ((*target-backend* backend))
           (format t "~%~%")
-          (apply #'x8632-disassemble-xfunction
+          (apply #'x86-disassemble-xfunction
                  xlfun
                  (unless symbolic-names (list nil)))))

branches/working-0711/ccl/lib/describe.lisp

@@ -20 +20 @@
            "COMPUTE-LINE-COUNT"
            "LINE-N"
+           "INSPECTOR-OBJECT"
+           "INSPECTOR-LINE-COUNT"
 
            "*INSPECTOR-DISASSEMBLY*"))
@@ -35 +37 @@
 (defclass inspector ()
   ((object :accessor inspector-object :initarg :object)
-   (line-count :accessor inspector-line-count :initarg :line-count :initform nil)))
+   (line-count :accessor inspector-line-count :initarg :line-count :initform nil)
+   ;; so can refresh.
+   (initargs :reader inspector-initargs :initform nil)))
+
+(defmethod initialize-instance :before ((i inspector) &rest initargs)
+  (setf (slot-value i 'initargs) initargs))
 
 ;;; The usual way to cons up an inspector
@@ -45 +52 @@
   (when update-line-count
     (update-line-count i)))
+
+(defmethod refresh-inspector ((i inspector))
+  (apply #'make-instance (class-of i) (slot-value i 'initargs)))
+
+;; New protocol, used by gui inspector instead of the line-n protocol, which isn't quite right.
+;; Perhaps tty inspector should use it as well.  Returns the line inspector rather than object,
+;; and returns the value string rather than having the caller print it.
+(defmethod inspector-line ((i inspector) index)
+  (let ((line-i (multiple-value-bind (value label type) (inspector::line-n i index)
+                  (and (not (eq (parse-type i type) :comment))
+                       (line-n-inspector i index value label type)))))
+    (multiple-value-bind (label-string value-string) (line-n-strings i index)
+      (values line-i label-string value-string))))
+
+;; for a comment value = nil, label = "the comment" type = :comment
+;;; => line-i = nil
 
 ;;;;;;;
@@ -89 +112 @@
   (multiple-value-call #'prin1-line i stream (line-n i n)))
 
-(defmethod prin1-line ((i inspector) stream value &optional
-                       label type function)
+(defmethod prin1-line ((i inspector) stream value &optional label type function)
   (unless function
     (setq function (inspector-print-function i type)))
   (funcall function i stream value label type))
 
+(defvar *collect-labels-if-list* t)
+
+(defmethod end-of-label ((stream string-output-stream))
+  (when (listp *collect-labels-if-list*)
+    (push (get-output-stream-string stream) *collect-labels-if-list*)))
+
+(defmethod line-n-strings ((i inspector) n)
+  (let* ((*collect-labels-if-list* ())
+         (value-string (with-output-to-string (stream)
+                         (prin1-line-n i stream n)))
+         (label-string (pop *collect-labels-if-list*))
+         (end (or (position-if-not #'whitespacep label-string :from-end t) -1)))
+    (assert (null *collect-labels-if-list*))
+    (unless (and (>= end 0) (eql (char label-string end) #\:)) (incf end))
+    (setq label-string (subseq label-string 0 end))
+    (values label-string value-string)))
+
 (defmethod inspector-print-function ((i inspector) type)
-  (if (consp type) (setq type (car type)))
-  (if (eq type :comment)
-    'prin1-comment
-    'prin1-normal-line))
-
+  (declare (ignore type))
+  'prin1-normal-line)
 
 ; Print a value to a stream.
@@ -111 +147 @@
       (if colon-p (princ ": " stream)))
     (end-of-label stream)              ; used by cacheing code
-    (prin1-value i stream value label type)))
+    (unless (eq type-sym :comment)
+      (prin1-value i stream value label type))))
 
 (defun prin1-colon-line (i stream value &optional label type)
@@ -126 +163 @@
   (prin1 value stream))
 
-(defmethod prin1-comment ((i inspector) stream value &optional label type)
-  (when label
-    (prin1-label i stream value label type)
-    (end-of-label stream)))
-  
 ;;; Call function on the inspector object and its value, label, & type, for
 ;;; each line in the selected range (default to the whole thing).
@@ -139 +171 @@
                       (start 0) 
                       end)
+  (when (null (inspector-line-count i))
+    (update-line-count i))
   (unless end
     (setq end (inspector-line-count i)))
@@ -144 +178 @@
     (let ((index start))
       (dotimes (c (- end start))
-        (declare (fixnum c))
-        (multiple-value-call function i (line-n i index))
+        (multiple-value-call function i index (inspector-line i index))
         (incf index)))))
 
@@ -213 +246 @@
          (*signal-printing-errors* nil))
      ,@body))
+
+(defun format-line-for-tty (stream label-string value-string)
+  (when (equal label-string "") (setq label-string nil))
+  (when (equal value-string "") (setq value-string nil))
+  (format stream "~@[~a~]~@[~a~]~@[~a~]"
+          label-string
+          (and label-string
+               value-string 
+               (not (eql #\space (char label-string (1- (length label-string)))))
+               ": ")
+          value-string))
 
 (defun describe (object &optional stream)
@@ -226 +270 @@
 (defmethod describe-object (object stream)
   (let ((inspector (make-inspector object)))
-    (when (null (inspector-line-count inspector))
-      (update-line-count inspector))
     (with-errorfree-printing
         (let* ((*print-pretty* (or *print-pretty* *describe-pretty*))
-               (temp #'(lambda (i value &rest rest)
-                         (declare (dynamic-extent rest))
-                         (apply #'prin1-line i stream value rest)
-                         (terpri stream))))
+               (temp #'(lambda (i index child &optional label-string value-string)
+                         (declare (ignore i index child))
+                         (format-line-for-tty stream label-string value-string)
+                         (terpri stream))))
           (declare (dynamic-extent temp))
           (map-lines inspector temp))))
@@ -257 +299 @@
 (defmethod prin1-line ((i formatting-inspector) stream value
                        &optional label type (format-string "~s"))
-  (if (eq :comment (if (consp type) (car type) type))
-    (prin1-comment i stream value label type)
-    (funcall (if (listp format-string) #'apply #'funcall)
-             #'format-normal-line i stream value label type format-string)))
+  (funcall (if (listp format-string) #'apply #'funcall)
+           #'format-normal-line i stream value label type format-string))
 
 (defmethod format-normal-line ((i inspector) stream value &optional 
@@ -267 +307 @@
     (if (eq type-sym :colon) (setq colon-p t))
     (when label
-      (if (stringp label)
-          (write-string label stream)
-          (princ label stream))
+      (prin1-label i stream value label type)
       (if colon-p (princ ": " stream)))
     (end-of-label stream)              ; used by cacheing code
-    (format stream format-string value)))
+    (unless (eq type-sym :comment)
+      (format stream format-string value))))
 
 ;;;;;;;
@@ -353 +392 @@
       (2 (values (class-of object) "Class: " :static))
       (t (call-next-method i (- n 3))))))
+
+(defmethod line-n-inspector :around ((i basics-first-mixin) n value label type)
+  (if (< n 3)
+    (make-inspector value)
+    (call-next-method i (- n 3) value label type)))
 
 (defmethod (setf line-n) :around (new-value (i basics-first-mixin) n)
@@ -981 +1025 @@
       (find-class sym nil)))
 
-(defmethod inspector-class ((sym symbol)) 'usual-inspector)
+(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector)
 
 (defmethod compute-line-count ((sym symbol))
-  (+ 1                                  ; The symbol
-     (if (symbol-has-bindings-p sym) 1 0)
+  (+ (if (symbol-has-bindings-p sym) 1 0)
      1                                  ; package
      1                                  ; symbol-name
@@ -997 +1040 @@
 
 (defmethod normalize-line-number ((sym symbol) n)
-  (if (and (>= n 1) (not (symbol-has-bindings-p sym))) (incf n))
-  (if (and (>= n 6) (not (fboundp sym))) (incf n))
+  (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n))
+  (if (and (>= n 5) (not (fboundp sym))) (incf n))
   n)
 
@@ -1007 +1050 @@
         (static :static))
     (ecase n
-      (0 (values sym "Symbol: " type))
-      (1 (values nil (symbol-type-line sym) comment))
-      (2 (let ((p (symbol-package sym)))
+      (0 (values nil (symbol-type-line sym) comment))
+      (1 (let ((p (symbol-package sym)))
            (if (null p)
              (values nil "No home package." comment)
@@ -1018 +1060 @@
                          (format nil "~a in package: " kind))
                        static)))))
-      (3 (values (symbol-name sym) "Print name: " static))
-      (4 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
+      (2 (values (symbol-name sym) "Print name: " static))
+      (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
                  "Value: " type))
-      (5 (values (if (fboundp sym)
+      (4 (values (if (fboundp sym)
                    (cond ((macro-function sym))
                          ((special-operator-p sym) sym)
@@ -1027 +1069 @@
                    *unbound-marker*)
                  "Function: " type))
-      (6 (values (and (fboundp sym) (arglist sym))
+      (5 (values (and (fboundp sym) (arglist sym))
                  "Arglist: " static))
-      (7 (values (symbol-plist sym) "Plist: " type))
-      (8 (values (find-class sym) "Class: " static)))))
+      (6 (values (symbol-plist sym) "Plist: " type))
+      (7 (values (find-class sym) "Class: " static)))))
 
 (defmethod (setf line-n) (value (sym symbol) n)
@@ -1037 +1079 @@
     (setq value (restore-unbound value))
     (ecase n
-      (0 (replace-object *inspector* value))
-      ((1 2 3 6) (setf-line-n-out-of-range sym n))
-      (4 (setf resample-p (not (boundp sym))
+      ((0 1 2 5) (setf-line-n-out-of-range sym n))
+      (3 (setf resample-p (not (boundp sym))
                (symbol-value sym) value))
-      (5 (setf resample-p (not (fboundp sym))
+      (4 (setf resample-p (not (fboundp sym))
                (symbol-function sym) value))
-      (7 (setf (symbol-plist sym) value)))
+      (6 (setf (symbol-plist sym) value)))
     (when resample-p (resample-it))
     value))
@@ -1105 +1146 @@
   (declare (ignore label type))
   (setq n (normalize-line-number sym n))
-  (if (eql n 7)
+  (if (eql n 6)
     (make-instance 'plist-inspector :symbol sym :object value)
     (call-next-method)))
@@ -1143 +1184 @@
 ;;
 (defclass function-inspector (inspector)
-  ((disasm-p :accessor disasm-p :initform *inspector-disassembly*)
+  ((header-lines :initform nil :reader header-lines)
+   (disasm-p :accessor disasm-p :initform *inspector-disassembly*)
    (disasm-info :accessor disasm-info)
    (pc-width :accessor pc-width)
    (pc :initarg :pc :initform nil :accessor pc)))
 
+(defmethod standard-header-count ((f function-inspector)) (length (header-lines f)))
+
+(defmethod header-count ((f function-inspector)) (standard-header-count f))
+
 (defclass closure-inspector (function-inspector)
   ((n-closed :accessor closure-n-closed)))
 
-
-
 (defmethod inspector-class ((f function)) 'function-inspector)
 (defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector)
 
+(defmethod compute-line-count :before ((f function-inspector))
+  (let* ((o (inspector-object f))
+         (doc (documentation o t))
+         (sn (ccl::function-source-note o))
+         (lines (nconc (list (list o ""))
+                       (list (list (function-name o) "Name" :colon))
+                       (list (multiple-value-bind (arglist type) (arglist o)
+                               (let ((label (if type
+                                              (format nil "Arglist (~(~a~))" type)
+                                              "Arglist unknown")))
+                                 (list arglist label (if type :colon '(:comment (:plain)))))))
+                       (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon)))
+                       (when sn (list (list sn "Source Location" :colon))))))
+    (setf (slot-value f 'header-lines) lines)))
+
 (defmethod compute-line-count ((f function-inspector))
-  (+ 1                                  ; the function
-     1                                  ; name
-     1                                  ; arglist
-     (let* ((doc (documentation (inspector-object f) t)))
-       (if doc 1 0))
-     (compute-disassembly-lines f))) 
+  (+ (header-count f) (compute-disassembly-lines f)))
+
+(defmethod line-n-strings ((f function-inspector) n)
+  (if (< (decf n (header-count f)) 0)
+    (call-next-method)
+    (disassembly-line-n-strings f n)))
+
+(defmethod line-n-inspector ((f function-inspector) n value label type)
+  (declare (ignore value label type))
+  (if (< (decf n (header-count f)) 0)
+    (call-next-method)
+    (disassembly-line-n-inspector f n)))
 
 (defmethod line-n ((f function-inspector) n)
-  (let* ((o (inspector-object f))
-         (doc (documentation o t)))
-    (case n
-      (0 (values o ""))
-      (1 (values (function-name o) "Name" :colon))
-      (2 (multiple-value-bind (arglist type) (arglist o)
-           (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown")))
-             (values arglist label (if type :colon '(:comment (:plain)))))))
-      (3 (if doc
-           (values (substitute #\space #\newline doc) "Documentation" :colon)
-           (disassembly-line-n f (- n 3))))
-      (t (disassembly-line-n f (- n (if doc 4 3)))))))
-
-(defmethod compute-line-count ((f closure-inspector))
+  (let* ((lines (header-lines f))
+         (nlines (length lines)))
+    (if (< n nlines)
+      (apply #'values (nth n lines))
+      (disassembly-line-n f (- n nlines)))))
+
+(defmethod compute-line-count :before ((f closure-inspector))
   (let* ((o (inspector-object f))
          (nclosed (nth-value 8 (function-args (ccl::closure-function o)))))
-    (setf (closure-n-closed f) nclosed)
-    (+ (call-next-method)
-       1                              ; the function we close over
-       1                              ; "Closed over values"
-       nclosed
-       (if (disasm-p f) 1 0))))      ; "Disassembly"
+    (setf (closure-n-closed f) nclosed)))
+
+(defmethod header-count ((f closure-inspector))
+  (+ (standard-header-count f)
+     1                              ; the function we close over
+     1                              ; "Closed over values"
+     (closure-n-closed f)))
 
 (defmethod line-n ((f closure-inspector) n)
   (let ((o (inspector-object f))
         (nclosed (closure-n-closed f)))
-    (if (<= (decf n 2) 0)
+    (if (< (decf n (standard-header-count f)) 0)
       (call-next-method)
-      (cond ((eql (decf n) 0)
+      (cond ((< (decf n) 0)
              (values (ccl::closure-function o) "Inner lfun: " :static))
-            ((eql (decf n) 0)
-             (values nclosed "Closed over values" :comment #'prin1-comment))
-            ((< (decf n) nclosed)
+            ((< (decf n) 0)
+             (values nclosed "Closed over values" :comment))
+            ((< n nclosed)
              (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
                     (map (car (ccl::function-symbol-map (ccl::closure-function o))))
@@ -1207 +1266 @@
                        label (format nil "(~a)" label)))
                (values value label (if cellp :normal :static) #'prin1-colon-line)))
-            ((eql (decf n nclosed) 0)
-             (values 0 "Disassembly" :comment #'prin1-comment))
-            (t (disassembly-line-n f (- n 1)))))))
+            (t (disassembly-line-n f (- n nclosed)))))))
 
 (defmethod (setf line-n) (new-value (f function-inspector) n)
-  (let ((o (inspector-object f)))
-    (case n
-      (0 (replace-object f new-value))
-      (1 (ccl::lfun-name o new-value) (resample-it))
-      (2 (setf (arglist o) new-value))
-      (t
-       (if (>= n 3) 
-         (set-disassembly-line-n f (- n 3) new-value)
-         (setf-line-n-out-of-range f n)))))
+  (let ((o (inspector-object f))
+        (standard-header-count (standard-header-count f)))
+    (if (< n standard-header-count)
+      (case n
+        (0 (replace-object f new-value))
+        (1 (ccl::lfun-name o new-value) (resample-it))
+        (t (setf-line-n-out-of-range f n)))
+      (set-disassembly-line-n f (- n standard-header-count) new-value)))
   new-value)
 
@@ -1226 +1282 @@
   (let ((o (inspector-object f))
         (nclosed (closure-n-closed f)))
-    (if (<= (decf n 2) 0)               ; function itself, name, or arglist
+    (if (< (decf n (standard-header-count f)) 0)
       (call-next-method)
-      (cond ((<= (decf n 2) 0)          ; inner-lfun or "Closed over values"
+      (cond ((< (decf n 2) 0)          ; inner-lfun or "Closed over values"
              (setf-line-n-out-of-range f en))
-            ((< (decf n) nclosed)       ; closed-over variable
+            ((< n nclosed)       ; closed-over variable
              (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
                     (cellp (ccl::closed-over-value-p value)))
                (unless cellp (setf-line-n-out-of-range f en))
                (ccl::set-closed-over-value value new-value)))
-            ((eql (decf n nclosed) 0)   ; "Disassembly"
-             (setf-line-n-out-of-range f en))
-            (t (set-disassembly-line-n f (- n 1) new-value))))))
+            (t (set-disassembly-line-n f (- n nclosed) new-value))))))
 
 (defun compute-disassembly-lines (f &optional (function (inspector-object f)))
-  (if (functionp function)
-    (let* ((info (and (disasm-p f)  (list-to-vector (ccl::disassemble-list function))))
-           (length (length info))
-           (last-pc (if info (car (svref info (1- length))) 0)))
-      (if (listp last-pc) (setq last-pc (cadr last-pc)))
-      (setf (pc-width f) (length (format nil "~d" last-pc)))
-      (setf (disasm-info f) info)
-      length)
+  (if (and (functionp function) (disasm-p f))
+    (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr)
+           (length (length lines))
+           (last-label (loop for n from (1- length) downto 0 as line = (aref lines n)
+                             thereis (and (consp line) (cadr line))))
+           (max-pc (if (consp last-label) (cadr last-label) last-label)))
+      (setf (pc-width f) (length (format nil "~d" max-pc)))
+      (setf (disasm-info f) lines)
+      (1+ length))
     0))
 
-(defun list-to-vector (list)
-  (let* ((length (length list))
-         (vec (make-array length)))
-    (dotimes (i length)
-      (declare (fixnum i))
-      (setf (svref vec i) (pop list)))
-    vec))
-
 (defun disassembly-line-n (f n)
-  (let* ((line (svref (disasm-info f) n))
-         (value (disasm-line-immediate line)))
-    (values value line (if value :static :comment))))
+  (if (< (decf n) 0)
+    (values nil "Disassembly:" :comment)
+    (let ((line (svref (disasm-info f) n)))
+      (if (consp line)
+        (destructuring-bind (object label instr) line
+          (values object (cons label instr) :static))
+        (values nil (cons nil line) :static)))))
+
+(defun disassembly-line-n-inspector (f n)
+  (unless (< (decf n) 0)
+    (let ((line (svref (disasm-info f) n)))
+      (and (consp line)
+           (car line)
+           (make-inspector (car line))))))
+
+(defun disassembly-line-n-strings (f n)
+  (if (< (decf n) 0)
+    (values "Disassembly:" nil)
+    (let ((line (svref (disasm-info f) n)))
+      (if (consp line)
+        (destructuring-bind (object label instr) line
+          (declare (ignore object))
+          (unless (stringp label)
+            (setq label (with-output-to-string (stream)
+                          (prin1-disassembly-label f stream label))))
+          (values label instr))
+        (values nil line)))))
 
 (defun set-disassembly-line-n (f n new-value &optional 
@@ -1268 +1339 @@
   (setf-line-n-out-of-range f n))
 
-(defun disasm-line-immediate (line &optional (lookup-functions t))
-  (pop line)                        ; remove address
-  (when (eq (car line) 'ccl::jsr_subprim)
-    (return-from disasm-line-immediate (find-symbol (cadr line) :ccl)))
-  (let ((res nil))
-    (labels ((inner-last (l)
-               (cond ((atom l) l)
-                     ((null (cdr l)) (car l))
-                     (t (inner-last (last l))))))
-      (dolist (e line)
-        (cond ((numberp e) (when (null res) (setq res e)))
-              ((consp e)
-               (cond ((eq (car e) 'function)
-                      (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
-                     ((eq (car e) 17)   ; locative
-                      (setq e (cadr e))
-                      (unless (atom e)
-                        (cond ((eq (car e) 'special) 
-                               (setq res (cadr e)))
-                              ((eq (car e) 'function) 
-                               (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
-                              (t (setq res (inner-last e))))))
-                     ((or (null res) (numberp res))
-                      (setq res (inner-last e))))))))
-    res))
-
-(defmethod inspector-print-function ((i function-inspector) type)
-  (declare (ignore type))
-  'prin1-normal-line)
-
-(defmethod prin1-label ((f function-inspector) stream value &optional label type)
+(defmethod prin1-label ((f function-inspector) stream value &optional data type)
   (declare (ignore value type))
-  (if (atom label)                      ; not a disassembly line
+  (if (atom data)                      ; not a disassembly line
     (call-next-method)
-    (let* ((pc (car label))
-           (label-p (and (listp pc) (setq pc (cadr pc))))
-           (pc-mark (pc f)))
-      (if (eq pc pc-mark)
-        (format stream "*~vd" (pc-width f) pc)
-        (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc))
-      (write-char (if label-p #\= #\ ) stream))))
+    (prin1-disassembly-label f stream (car data))))
+
+(defun prin1-disassembly-label (f stream label)
+  (let* ((pc label)
+         (label-p (and (consp pc) (setq pc (cadr pc))))
+         (pc-mark (pc f))
+         (pc-width (pc-width f)))
+    (when pc
+      (write-char (if (eql pc pc-mark) #\* #\Space) stream)
+      (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc))))
+
+#+x86-target
+(defmethod prin1-value ((f function-inspector) stream value &optional data type)
+  (declare (ignore value type))
+  (if (atom data) ;; not a disassembly line
+    (call-next-method)
+    (princ (cdr data) stream)))
+
 
 #+ppc-target
@@ -1327 +1379 @@
 ;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
 (defclass gf-inspector (function-inspector)
-  ((method-count :accessor method-count)
-   (slot-count :accessor slot-count :initform 0)))
+  ((method-count :accessor method-count)))
 
 (defmethod inspector-class ((f standard-generic-function))
@@ -1335 +1386 @@
     'standard-object-inspector))
 
-(defmethod compute-line-count ((f gf-inspector))
+(defmethod compute-line-count :before ((f gf-inspector))
   (let* ((gf (inspector-object f))
-         (count (length (generic-function-methods gf)))
-         (res (+ 1 (setf (method-count f) count)  
-                 (call-next-method))))
-    (if (disasm-p f) (1+ res) res)))
+         (count (length (generic-function-methods gf))))
+    (setf (method-count f) count)))
+
+(defmethod header-count ((f gf-inspector))
+  (+ (standard-header-count f) 1 (method-count f)))
 
 (defmethod line-n ((f gf-inspector) n)
   (let* ((count (method-count f))
-         (slot-count (slot-count f))
-         (lines (1+ count)))
-    (if (<= 3 n (+ lines slot-count 3))
-      (let ((methods (generic-function-methods (inspector-object f))))
-        (cond ((eql (decf n 3) 0) (values methods "Methods: " :static))
-              ((<= n count)
-               (values (nth (- n 1) methods) nil :static))
-              ((< (decf n (1+ count)) slot-count)
-               (standard-object-line-n f n))
-              (t
-               (values 0 "Disassembly" :comment #'prin1-comment))))
-      (call-next-method f (if (< n 3) n (- n lines slot-count 1))))))
+         (methods (generic-function-methods (inspector-object f))))
+    (cond ((< (decf n  (standard-header-count f)) 0)
+           (call-next-method))
+          ((< (decf n) 0)
+           (values methods "Methods: " :comment))
+          ((< n count)
+           (values (nth n methods) nil :static))
+          (t (disassembly-line-n f (- n count))))))
 
 (defmethod (setf line-n) (new-value (f gf-inspector) n)
   (let* ((count (method-count f))
-         (slot-count (slot-count f))
-         (lines (1+ count)))
-    (if (<= 3 n (+ lines slot-count 3))
-      (let ((en n))
-        (cond ((<= (decf en 3) count)
-               (setf-line-n-out-of-range f n))
-              ((< (decf en (1+ count)) slot-count)
-               (standard-object-setf-line-n new-value f en))
-              (t (setf-line-n-out-of-range f n))))
-      (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1))))))
+         (en n))
+    (cond ((< (decf n (standard-header-count f)) 0)
+           (call-next-method))
+          ((< (decf n) count)
+           (setf-line-n-out-of-range f en))
+          (t (set-disassembly-line-n f (- n count) new-value)))))
 
 #|
@@ -1383 +1427 @@
       (call-next-method))))
 |#
-
-(defclass method-inspector (standard-object-inspector function-inspector)
-  ((standard-object-lines :accessor standard-object-lines)))
-
-(defmethod inspector-class ((object standard-method))
-  'method-inspector)
-
-(defmethod compute-line-count ((i method-inspector))
-  (+ (setf (standard-object-lines i) (call-next-method))
-     (if (disasm-p i) 1 0)              ; "Disassembly"
-     (compute-disassembly-lines i (method-function (inspector-object i)))))
-
-(defmethod line-n ((i method-inspector) n)
-  (let ((sol (standard-object-lines i)))
-    (cond ((< n sol) (call-next-method))
-          ((eql n sol) (values nil "Disassembly" :comment))
-          (t (disassembly-line-n i (- n sol 1))))))
-
-(defmethod (setf line-n) (new-value (i method-inspector) n)
-  (let ((sol (standard-object-lines i)))
-    (cond ((< n sol) (call-next-method))
-          ((eql n sol) (setf-line-n-out-of-range i n))
-          (t (set-disassembly-line-n
-              i n new-value (method-function (inspector-object i)))))))
-
-;;; funtion-inspector never does prin1-comment.
-(defmethod prin1-normal-line ((i method-inspector) stream value &optional
-                              label type colon-p)
-  (declare (ignore colon-p))
-  (if (eq type :comment)
-    (prin1-comment i stream value label type)
-    (call-next-method)))
-
 
 ;;;;;;;
@@ -1565 +1576 @@
 
 (defmethod initialize-addresses ((f error-frame))
-  (let* ((addresses (list-to-vector (ccl::%stack-frames-in-context (context f)))))
+  (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector)))
       (setf (frame-count f) (length addresses)
             (addresses f) addresses)))
@@ -1786 +1797 @@
 (defmethod ui-present ((ui inspector-tty-ui))
   (let* ((inspector (inspector-ui-inspector ui)))
-    (when (null (inspector-line-count inspector))
-      (update-line-count inspector))
     (with-errorfree-printing
         (let* ((stream *debug-io*)
@@ -1795 +1804 @@
                (n (compute-line-count inspector))
                (end (min page-end n))
-               (tag origin)
+               (tag -1)
                (*print-pretty* (or *print-pretty* *describe-pretty*))
                (*print-length* 5)
                (*print-level* 5)
-               (func #'(lambda (i value &rest rest)
-                         (declare (dynamic-extent rest))
-                         (let* ((type (cadr rest)))
-                           (unless (or (eq type :comment)
-                                   (and (consp type)
-                                        (eq (car type) :comment)))
-                             (format stream "[~d] " tag))
-                           (incf tag))
-                         (format stream "~8t")
-                         (apply #'prin1-line i stream value rest)
-                         (terpri stream))))
+               (func #'(lambda (i index child &optional label-string value-string)
+                         (declare (ignore i))
+                         (when child (incf tag))
+                         (unless (< index origin)
+                           (format stream "~@[[~d]~]~8t" (and child tag))
+                           (format-line-for-tty stream label-string value-string)
+                           (terpri stream)))))
           (declare (dynamic-extent func))
-          (map-lines inspector func origin end)))
+          (map-lines inspector func 0 end)))
     (values)))
 
@@ -1893 +1898 @@
 
 (defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
-  (let* ((inspector (inspector-ui-inspector ui)))
-    (multiple-value-bind (value label type)
-        (line-n inspector n)
-      (unless (or (eq type :comment)
-                  (and (consp type) (eq (car type) :comment)))
-        (let* ((new-inspector (line-n-inspector inspector n value label type))
-               (ccl::@ value))
-          (inspector-ui-inspect
-           (make-instance 'inspector-tty-ui
-                          :level (1+ (inspector-ui-level ui))
-                          :inspector new-inspector)))))))
-      
+  (let* ((inspector (inspector-ui-inspector ui))
+         (new-inspector (block nil
+                          (let* ((tag -1)
+                                 (func #'(lambda (i index child &rest strings)
+                                           (declare (ignore i index strings))
+                                           (when (and child (eql (incf tag) n)) (return child)))))
+                            (declare (dynamic-extent func))
+                            (map-lines inspector func))))
+         (ccl::@ (inspector-object new-inspector)))
+    (inspector-ui-inspect
+     (make-instance 'inspector-tty-ui
+       :level (1+ (inspector-ui-level ui))
+       :inspector new-inspector))))
+
 (defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
 

branches/working-0711/ccl/lib/misc.lisp

@@ -774 +774 @@
   disassemble."
   (#+ppc-target ppc-xdisassemble
-   #+x8632-target x8632-xdisassemble
-   #+x8664-target x8664-xdisassemble
+   #+x86-target x86-xdisassemble
    (require-type (function-for-disassembly thing) 'compiled-function)))