Changeset 12846


Ignore:
Timestamp:
Sep 16, 2009, 6:33:00 PM (10 years ago)
Author:
gz
Message:

Make the gui inspector show function disassembly. Extend the inspector protocol to support this a little better. Fix a number of bugs in closing and method inspectors.

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/inspector.lisp

    r12135 r12846  
    117117      (with-slots (next-index viewed-inspector-items) wc
    118118        (let ((ii (get-child (inspector-item wc) row)))
    119           (if (and (< next-index (fill-pointer viewed-inspector-items))
    120                    (eq ii (aref viewed-inspector-items next-index)))
    121             ;;If the ii is the same as the next history item, then just go forward in history
    122             (set-current-inspector-item wc next-index)
    123             ;;Otherwise forget the forward history
    124             (push-inspector-item wc ii)))))))
     119          (when (lisp-inspector ii)
     120            (if (and (< next-index (fill-pointer viewed-inspector-items))
     121                     (eql ii (aref viewed-inspector-items next-index)))
     122                ;;If the ii is the same as the next history item, then just go forward in history
     123                (set-current-inspector-item wc next-index)
     124                ;;Otherwise forget the forward history
     125                (push-inspector-item wc ii))))))))
    125126
    126127(objc:defmethod (#/inspectSelectionInNewWindow: :void) ((wc ninspector-window-controller) sender)
     
    130131      (with-slots (next-index viewed-inspector-items) wc
    131132        (let* ((ii (get-child (inspector-item wc) row))
    132                (ob (inspector-object ii)))
    133           (make-inspector ob))))))
     133               (li (lisp-inspector ii)))
     134          (when li
     135            (make-inspector-window li)))))))
    134136
    135137(objc:defmethod (#/inspectSelectionInSameWindow: :void) ((wc ninspector-window-controller) sender)
     
    149151(objc:defmethod (#/doRefresh: :void) ((wc ninspector-window-controller) sender)
    150152  (declare (ignore sender))
    151   (push-inspector-item wc (make-inspector-item (inspector-object (inspector-item wc)))))
     153  (let ((inspector::*inspector-disassembly* t))
     154    (push-inspector-item wc (make-inspector-item (inspector::refresh-inspector (lisp-inspector wc))))))
    152155
    153156(defclass inspector-item (ns:ns-object)
    154   ((lisp-inspector :accessor lisp-inspector)
     157  ((lisp-inspector :accessor lisp-inspector) ;; null for non-inspectable
    155158   (label :accessor inspector-item-label) ;NSString
    156159   (ob-string :accessor inspector-item-ob-string) ;NSString
    157    (type :accessor inspector-item-type) ; oneof: nil :normal :colon :comment :static
    158160   (children :initform nil)) ;initialized lazily
    159161  (:metaclass ns:+ns-object))
     
    161163(defmethod inspector-item-children ((ii inspector-item))
    162164  (or (slot-value ii 'children)
    163       (let* ((li (lisp-inspector ii)))
    164         (when (null (inspector::inspector-line-count li))
    165           (inspector::update-line-count li))       
    166         (setf (slot-value ii 'children)
    167             (make-array (inspector::inspector-line-count li) :initial-element nil)))))
     165      (setf (slot-value ii 'children)
     166            (make-array (inspector-line-count ii) :initial-element nil))))
    168167
    169168(defmethod inspector-object ((ii inspector-item))
    170   (inspector::inspector-object (lisp-inspector ii)))
     169  (let ((li (lisp-inspector ii)))
     170    (and li (inspector::inspector-object li))))
    171171
    172172(defmethod inspector-line-count ((ii inspector-item))
    173173  (let ((li (lisp-inspector ii)))
    174     (or  (inspector::inspector-line-count li)
     174    (or  (and (null li) 0)
     175         (inspector::inspector-line-count li)
    175176         (progn
    176177           (inspector::update-line-count li)
    177178           (inspector::inspector-line-count li)))))
    178179
    179 (defun inspector-object-nsstring (ob)
    180   (let ((*print-readably* nil)
     180(defun inspector-object-nsstring (li)
     181  (let ((ob (inspector::inspector-object li))
     182        (*print-readably* nil)
    181183        (*signal-printing-errors* nil)
    182184        (*print-circle* t)
     
    185187    (%make-nsstring (prin1-to-string ob))))
    186188
    187 (defun make-inspector-item (value &optional label type)
    188   (let* ((item (make-instance 'inspector-item))
    189          (li (inspector::make-inspector value)))
     189(defun make-inspector-item (li &optional label-string value-string)
     190  (let* ((item (make-instance 'inspector-item)))
    190191    (setf (lisp-inspector item) li
    191           (inspector-item-ob-string item) (inspector-object-nsstring value)
    192           (inspector-item-label item) label
    193           (inspector-item-type item) type)
     192          (inspector-item-ob-string item) (if value-string
     193                                            (%make-nsstring value-string)
     194                                            (inspector-object-nsstring li))
     195          (inspector-item-label item) (%make-nsstring (or label-string "")))
    194196    item))
    195 
     197 
    196198(defun make-inspector (ob)
     199  (let ((inspector::*inspector-disassembly* t))
     200    (make-inspector-window (inspector::make-inspector ob))))
     201
     202(defun make-inspector-window (li)
    197203  (let* ((wc (make-instance 'ninspector-window-controller))
    198          (ii (make-inspector-item ob)))
     204         (ii (make-inspector-item li)))
    199205    (push-inspector-item wc ii)
    200206    (#/showWindow: wc nil)
     
    216222  (setf (slot-value wc 'inspector-item) ii)
    217223  (let* ((w (#/window wc))
    218          (title (inspector-item-ob-string ii)))
    219     (#/setTitle: w (%make-nsstring (concatenate 'string  "Inspector: "
     224         (title (inspector-object-nsstring (lisp-inspector ii))))
     225    (#/setTitle: w (%make-nsstring (concatenate 'string  "Inspect: "
    220226                                                (lisp-string-from-nsstring title))))
    221227    (#/setStringValue: (object-label wc) title)
     
    260266        (i (1+ index)))
    261267    (or (svref arr i)
    262         (multiple-value-bind (ob label type) (inspector::line-n (lisp-inspector ii) i)
    263           (setf (svref arr i) (make-inspector-item ob (%make-nsstring (princ-to-string label)) type))))))
    264 
    265 ;;; Make INSPECT call CINSPECT.
     268        (setf (svref arr i)
     269              (let ((li (lisp-inspector ii))
     270                    (inspector::*inspector-disassembly* t))
     271                (multiple-value-bind (child label-string value-string) (inspector::inspector-line li i)
     272                  (make-inspector-item child (or label-string "") (or value-string ""))))))))
     273
     274;;; Make CL:INSPECT call NINSPECT.
    266275(setq inspector::*default-inspector-ui-creation-function* 'ninspect)
     276
  • trunk/source/compiler/PPC/ppc-disassemble.lisp

    r11373 r12846  
    435435    (nreverse res)))
    436436
     437(defun disassemble-lines (thing)
     438  (let ((dll (function-to-dll-header (function-for-disassembly thing)))
     439        (address 0)
     440        (label-p nil)
     441        (lines (make-array 20 :adjustable t :fill-pointer 0)))
     442    (do-dll-nodes (i dll)
     443      (setq address (instruction-element-address i))
     444      (etypecase i
     445        (lap-label
     446         (setq label-p (lap-label-name i)))
     447        (lap-instruction
     448         (let* ((opcode (lap-instruction-opcode i))
     449                (operands (lap-instruction-parsed-operands i))
     450                (imms (loop for op in operands
     451                         when (and (consp op)
     452                                   (consp (cdr op))
     453                                   (null (cddr op))
     454                                   (or (eq (%car op) 'quote) (eq (%car op) 'function)))
     455                         collect op)))
     456           (vector-push-extend (list (if (cdr imms) (coerce imms 'vector) (car imms))
     457                                     (if label-p `(:label address) address)
     458                                     (with-output-to-string (s)
     459                                       (format s "(~a" (if (symbolp opcode) opcode (opcode-name opcode)))
     460                                       (loop for op in operands
     461                                          do (princ " " s)
     462                                          do (disasm-prin1 op s))
     463                                       (format s ")")))
     464                               lines)
     465           (setq label-p nil)))))
     466    lines))
     467
    437468#+ppc-target
    438469(defun disasm-prin1 (thing stream)
  • trunk/source/compiler/X86/x86-disassemble.lisp

    r12838 r12846  
    28982898     nil)
    28992899    (instructions)))
     2900
     2901(defun x86-disassembled-instruction-line (ds instruction function &optional string-stream)
     2902  (if (null string-stream)
     2903    (with-output-to-string (stream)
     2904      (return-from x86-disassembled-instruction-line
     2905                   (x86-disassembled-instruction-line ds instruction function stream)))
     2906    (let* ((addr (x86-di-address instruction))
     2907           (entry (x86-ds-entry-point ds))
     2908           (pc (- addr entry))
     2909           (op0 (x86-di-op0 instruction))
     2910           (op1 (x86-di-op1 instruction))
     2911           (op2 (x86-di-op2 instruction))
     2912           (label (if (x86-di-labeled instruction) (list :label pc) pc))
     2913           (instr (progn
     2914                    (dolist (p (x86-di-prefixes instruction))
     2915                      (format string-stream "(~a) " p))
     2916                    (format string-stream "(~a" (x86-di-mnemonic instruction))
     2917                    (when op0 (write-x86-lap-operand string-stream op0 ds))
     2918                    (when op1 (write-x86-lap-operand string-stream op1 ds))
     2919                    (when op2 (write-x86-lap-operand string-stream op2 ds))
     2920                    (format string-stream ")")
     2921                    (get-output-stream-string string-stream)))
     2922           (comment (let ((source-note (find-source-note-at-pc function pc)))
     2923                      (unless (eql (source-note-file-range source-note)
     2924                                   (source-note-file-range *previous-source-note*))
     2925                        (setf *previous-source-note* source-note)
     2926                        (let* ((source-text (source-note-text source-note))
     2927                               (text (if source-text
     2928                                       (string-sans-most-whitespace source-text 100)
     2929                                       "#<no source text>")))
     2930                          (format string-stream ";;; ~A" text)
     2931                          (get-output-stream-string string-stream)))))
     2932           (imms (let ((imms nil))
     2933                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op2 ds)
     2934                     (when foundp (push imm imms)))
     2935                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op1 ds)
     2936                     (when foundp (push imm imms)))
     2937                   (multiple-value-bind (imm foundp) (x86-lap-operand-constant op0 ds)
     2938                     (when foundp (push imm imms)))
     2939                   imms)))
     2940      ;; Subtle difference between no imms and a single NIL imm, so if anybody ever
     2941      ;; cares for some reason, they could distinguish the two cases.
     2942      (if imms
     2943        (values comment label instr (if (cdr imms) (coerce imms 'vector) (car imms)))
     2944        (values comment label instr)))))
     2945
     2946(defun disassemble-lines (function)
     2947  (let ((source-note (function-source-note function)))
     2948    (when source-note
     2949      ;; Fetch source from file if don't already have it.
     2950      (ensure-source-note-text source-note)))
     2951  (let ((lines (make-array 20 :adjustable t :fill-pointer 0)))
     2952    (with-output-to-string (stream)
     2953      (x86-xdisassemble
     2954       function
     2955       #'(lambda (ds instruction seq function)
     2956           (declare (ignore seq))
     2957           (multiple-value-bind (comment label instr object)
     2958                                (x86-disassembled-instruction-line ds instruction function stream)
     2959             (when comment
     2960               (vector-push-extend comment lines))
     2961             (vector-push-extend (list object label instr) lines)))
     2962       nil))
     2963    (coerce lines 'simple-vector)))
  • trunk/source/lib/describe.lisp

    r12765 r12846  
    3737(defclass inspector ()
    3838  ((object :accessor inspector-object :initarg :object)
    39    (line-count :accessor inspector-line-count :initarg :line-count :initform nil)))
     39   (line-count :accessor inspector-line-count :initarg :line-count :initform nil)
     40   ;; so can refresh.
     41   (initargs :reader inspector-initargs :initform nil)))
     42
     43(defmethod initialize-instance :before ((i inspector) &rest initargs)
     44  (setf (slot-value i 'initargs) initargs))
    4045
    4146;;; The usual way to cons up an inspector
     
    4752  (when update-line-count
    4853    (update-line-count i)))
     54
     55(defmethod refresh-inspector ((i inspector))
     56  (apply #'make-instance (class-of i) (slot-value i 'initargs)))
     57
     58;; New protocol, used by gui inspector instead of the line-n protocol, which isn't quite right.
     59;; Perhaps tty inspector should use it as well.  Returns the line inspector rather than object,
     60;; and returns the value string rather than having the caller print it.
     61(defmethod inspector-line ((i inspector) index)
     62  (let ((line-i (multiple-value-bind (value label type) (inspector::line-n i index)
     63                  (and (not (eq (parse-type i type) :comment))
     64                       (line-n-inspector i index value label type)))))
     65    (multiple-value-bind (label-string value-string) (line-n-strings i index)
     66      (values line-i label-string value-string))))
     67
     68;; for a comment value = nil, label = "the comment" type = :comment
     69;;; => line-i = nil
    4970
    5071;;;;;;;
     
    96117  (funcall function i stream value label type))
    97118
     119(defvar *collect-labels-if-list* t)
     120
     121(defmethod end-of-label ((stream string-output-stream))
     122  (when (listp *collect-labels-if-list*)
     123    (push (get-output-stream-string stream) *collect-labels-if-list*)))
     124
     125(defmethod line-n-strings ((i inspector) n)
     126  (let* ((*collect-labels-if-list* ())
     127         (value-string (with-output-to-string (stream)
     128                         (prin1-line-n i stream n)))
     129         (label-string (pop *collect-labels-if-list*))
     130         (end (or (position-if-not #'whitespacep label-string :from-end t) -1)))
     131    (assert (null *collect-labels-if-list*))
     132    (unless (and (>= end 0) (eql (char label-string end) #\:)) (incf end))
     133    (setq label-string (subseq label-string 0 end))
     134    (values label-string value-string)))
     135
    98136(defmethod inspector-print-function ((i inspector) type)
    99   (if (consp type) (setq type (car type)))
    100   (if (eq type :comment)
    101     'prin1-comment
    102     'prin1-normal-line))
    103 
     137  (declare (ignore type))
     138  'prin1-normal-line)
    104139
    105140; Print a value to a stream.
     
    112147      (if colon-p (princ ": " stream)))
    113148    (end-of-label stream)              ; used by cacheing code
    114     (prin1-value i stream value label type)))
     149    (unless (eq type-sym :comment)
     150      (prin1-value i stream value label type))))
    115151
    116152(defun prin1-colon-line (i stream value &optional label type)
     
    127163  (prin1 value stream))
    128164
    129 (defmethod prin1-comment ((i inspector) stream value &optional label type)
    130   (when label
    131     (prin1-label i stream value label type)
    132     (end-of-label stream)))
    133  
    134165;;; Call function on the inspector object and its value, label, & type, for
    135166;;; each line in the selected range (default to the whole thing).
     
    140171                      (start 0)
    141172                      end)
     173  (when (null (inspector-line-count i))
     174    (update-line-count i))
    142175  (unless end
    143176    (setq end (inspector-line-count i)))
     
    145178    (let ((index start))
    146179      (dotimes (c (- end start))
    147         (declare (fixnum c))
    148         (multiple-value-call function i (line-n i index))
     180        (multiple-value-call function i index (inspector-line i index))
    149181        (incf index)))))
    150182
     
    214246         (*signal-printing-errors* nil))
    215247     ,@body))
     248
     249(defun format-line-for-tty (stream label-string value-string)
     250  (when (equal label-string "") (setq label-string nil))
     251  (when (equal value-string "") (setq value-string nil))
     252  (format stream "~@[~a~]~@[~a~]~@[~a~]"
     253          label-string
     254          (and label-string
     255               value-string
     256               (not (eql #\space (char label-string (1- (length label-string)))))
     257               ": ")
     258          value-string))
    216259
    217260(defun describe (object &optional stream)
     
    227270(defmethod describe-object (object stream)
    228271  (let ((inspector (make-inspector object)))
    229     (when (null (inspector-line-count inspector))
    230       (update-line-count inspector))
    231272    (with-errorfree-printing
    232273        (let* ((*print-pretty* (or *print-pretty* *describe-pretty*))
    233                (temp #'(lambda (i value &rest rest)
    234                          (declare (dynamic-extent rest))
    235                          (apply #'prin1-line i stream value rest)
    236                         (terpri stream))))
     274               (temp #'(lambda (i index child &optional label-string value-string)
     275                         (declare (ignore i index child))
     276                         (format-line-for-tty stream label-string value-string)
     277                        (terpri stream))))
    237278          (declare (dynamic-extent temp))
    238279          (map-lines inspector temp))))
     
    258299(defmethod prin1-line ((i formatting-inspector) stream value
    259300                       &optional label type (format-string "~s"))
    260   (if (eq :comment (if (consp type) (car type) type))
    261     (prin1-comment i stream value label type)
    262     (funcall (if (listp format-string) #'apply #'funcall)
    263              #'format-normal-line i stream value label type format-string)))
     301  (funcall (if (listp format-string) #'apply #'funcall)
     302           #'format-normal-line i stream value label type format-string))
    264303
    265304(defmethod format-normal-line ((i inspector) stream value &optional
     
    271310      (if colon-p (princ ": " stream)))
    272311    (end-of-label stream)              ; used by cacheing code
    273     (format stream format-string value)))
     312    (unless (eq type-sym :comment)
     313      (format stream format-string value))))
    274314
    275315;;;;;;;
     
    352392      (2 (values (class-of object) "Class: " :static))
    353393      (t (call-next-method i (- n 3))))))
     394
     395(defmethod line-n-inspector :around ((i basics-first-mixin) n value label type)
     396  (if (< n 3)
     397    (make-inspector value)
     398    (call-next-method i (- n 3) value label type)))
    354399
    355400(defmethod (setf line-n) :around (new-value (i basics-first-mixin) n)
     
    9991044      (find-class sym nil)))
    10001045
    1001 (defmethod inspector-class ((sym symbol)) 'usual-inspector)
     1046(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector)
    10021047
    10031048(defmethod compute-line-count ((sym symbol))
    1004   (+ 1                                  ; The symbol
    1005      (if (symbol-has-bindings-p sym) 1 0)
     1049  (+ (if (symbol-has-bindings-p sym) 1 0)
    10061050     1                                  ; package
    10071051     1                                  ; symbol-name
     
    10151059
    10161060(defmethod normalize-line-number ((sym symbol) n)
    1017   (if (and (>= n 1) (not (symbol-has-bindings-p sym))) (incf n))
    1018   (if (and (>= n 6) (not (fboundp sym))) (incf n))
     1061  (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n))
     1062  (if (and (>= n 5) (not (fboundp sym))) (incf n))
    10191063  n)
    10201064
     
    10251069        (static :static))
    10261070    (ecase n
    1027       (0 (values sym "Symbol: " type))
    1028       (1 (values nil (symbol-type-line sym) comment))
    1029       (2 (let ((p (symbol-package sym)))
     1071      (0 (values nil (symbol-type-line sym) comment))
     1072      (1 (let ((p (symbol-package sym)))
    10301073           (if (null p)
    10311074             (values nil "No home package." comment)
     
    10361079                         (format nil "~a in package: " kind))
    10371080                       static)))))
    1038       (3 (values (symbol-name sym) "Print name: " static))
    1039       (4 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
     1081      (2 (values (symbol-name sym) "Print name: " static))
     1082      (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
    10401083                 "Value: " type))
    1041       (5 (values (if (fboundp sym)
     1084      (4 (values (if (fboundp sym)
    10421085                   (cond ((macro-function sym))
    10431086                         ((special-operator-p sym) sym)
     
    10451088                   *unbound-marker*)
    10461089                 "Function: " type))
    1047       (6 (values (and (fboundp sym) (arglist sym))
     1090      (5 (values (and (fboundp sym) (arglist sym))
    10481091                 "Arglist: " static))
    1049       (7 (values (symbol-plist sym) "Plist: " type))
    1050       (8 (values (find-class sym) "Class: " static)))))
     1092      (6 (values (symbol-plist sym) "Plist: " type))
     1093      (7 (values (find-class sym) "Class: " static)))))
    10511094
    10521095(defmethod (setf line-n) (value (sym symbol) n)
     
    10551098    (setq value (restore-unbound value))
    10561099    (ecase n
    1057       (0 (replace-object *inspector* value))
    1058       ((1 2 3 6) (setf-line-n-out-of-range sym n))
    1059       (4 (setf resample-p (not (boundp sym))
     1100      ((0 1 2 5) (setf-line-n-out-of-range sym n))
     1101      (3 (setf resample-p (not (boundp sym))
    10601102               (symbol-value sym) value))
    1061       (5 (setf resample-p (not (fboundp sym))
     1103      (4 (setf resample-p (not (fboundp sym))
    10621104               (symbol-function sym) value))
    1063       (7 (setf (symbol-plist sym) value)))
     1105      (6 (setf (symbol-plist sym) value)))
    10641106    (when resample-p (resample-it))
    10651107    value))
     
    11231165  (declare (ignore label type))
    11241166  (setq n (normalize-line-number sym n))
    1125   (if (eql n 7)
     1167  (if (eql n 6)
    11261168    (make-instance 'plist-inspector :symbol sym :object value)
    11271169    (call-next-method)))
     
    11671209   (pc :initarg :pc :initform nil :accessor pc)))
    11681210
    1169 (defmethod header-count ((i function-inspector)) (length (header-lines i)))
     1211(defmethod standard-header-count ((f function-inspector)) (length (header-lines f)))
     1212
     1213(defmethod header-count ((f function-inspector)) (standard-header-count f))
    11701214
    11711215(defclass closure-inspector (function-inspector)
    11721216  ((n-closed :accessor closure-n-closed)))
    11731217
    1174 
    1175 
    11761218(defmethod inspector-class ((f function)) 'function-inspector)
    11771219(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector)
    11781220
    1179 (defmethod compute-line-count ((f function-inspector))
     1221(defmethod compute-line-count :before ((f function-inspector))
    11801222  (let* ((o (inspector-object f))
    11811223         (doc (documentation o t))
     
    11901232                       (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon)))
    11911233                       (when sn (list (list sn "Source Location" :colon))))))
    1192     (setf (slot-value f 'header-lines) lines)
    1193     (+ (length lines) (compute-disassembly-lines f))))
     1234    (setf (slot-value f 'header-lines) lines)))
     1235
     1236(defmethod compute-line-count ((f function-inspector))
     1237  (+ (header-count f) (compute-disassembly-lines f)))
     1238
     1239(defmethod line-n-strings ((f function-inspector) n)
     1240  (if (< (decf n (header-count f)) 0)
     1241    (call-next-method)
     1242    (disassembly-line-n-strings f n)))
     1243
     1244(defmethod line-n-inspector ((f function-inspector) n value label type)
     1245  (declare (ignore value label type))
     1246  (if (< (decf n (header-count f)) 0)
     1247    (call-next-method)
     1248    (disassembly-line-n-inspector f n)))
    11941249
    11951250(defmethod line-n ((f function-inspector) n)
     
    12001255      (disassembly-line-n f (- n nlines)))))
    12011256
    1202 (defmethod compute-line-count ((f closure-inspector))
     1257(defmethod compute-line-count :before ((f closure-inspector))
    12031258  (let* ((o (inspector-object f))
    12041259         (nclosed (nth-value 8 (function-args (ccl::closure-function o)))))
    1205     (setf (closure-n-closed f) nclosed)
    1206     (+ (call-next-method)
    1207        1                              ; the function we close over
    1208        1                              ; "Closed over values"
    1209        nclosed
    1210        (if (disasm-p f) 1 0))))      ; "Disassembly"
     1260    (setf (closure-n-closed f) nclosed)))
     1261
     1262(defmethod header-count ((f closure-inspector))
     1263  (+ (standard-header-count f)
     1264     1                              ; the function we close over
     1265     1                              ; "Closed over values"
     1266     (closure-n-closed f)))
    12111267
    12121268(defmethod line-n ((f closure-inspector) n)
    12131269  (let ((o (inspector-object f))
    12141270        (nclosed (closure-n-closed f)))
    1215     (if (< (decf n (header-count f)) 0)
     1271    (if (< (decf n (standard-header-count f)) 0)
    12161272      (call-next-method)
    12171273      (cond ((< (decf n) 0)
    12181274             (values (ccl::closure-function o) "Inner lfun: " :static))
    12191275            ((< (decf n) 0)
    1220              (values nclosed "Closed over values" :comment #'prin1-comment))
     1276             (values nclosed "Closed over values" :comment))
    12211277            ((< n nclosed)
    12221278             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
     
    12291285                       label (format nil "(~a)" label)))
    12301286               (values value label (if cellp :normal :static) #'prin1-colon-line)))
    1231             ((eql (decf n nclosed) 0)
    1232              (values 0 "Disassembly" :comment #'prin1-comment))
    1233             (t (disassembly-line-n f (- n 1)))))))
     1287            (t (disassembly-line-n f (- n nclosed)))))))
    12341288
    12351289(defmethod (setf line-n) (new-value (f function-inspector) n)
    1236   (let ((o (inspector-object f)))
    1237     (case n
    1238       (0 (replace-object f new-value))
    1239       (1 (ccl::lfun-name o new-value) (resample-it))
    1240       (2 (setf (arglist o) new-value))
    1241       (t
    1242        (let ((line (- n (header-count f))))
    1243          (if (>= line 0)
    1244            (set-disassembly-line-n f line new-value)
    1245            (setf-line-n-out-of-range f n))))))
     1290  (let ((o (inspector-object f))
     1291        (standard-header-count (standard-header-count f)))
     1292    (if (< n standard-header-count)
     1293      (case n
     1294        (0 (replace-object f new-value))
     1295        (1 (ccl::lfun-name o new-value) (resample-it))
     1296        (t (setf-line-n-out-of-range f n)))
     1297      (set-disassembly-line-n f (- n standard-header-count) new-value)))
    12461298  new-value)
    12471299
     
    12491301  (let ((o (inspector-object f))
    12501302        (nclosed (closure-n-closed f)))
    1251     (if (< (decf n (header-count f)) 0)
     1303    (if (< (decf n (standard-header-count f)) 0)
    12521304      (call-next-method)
    12531305      (cond ((< (decf n 2) 0)          ; inner-lfun or "Closed over values"
     
    12581310               (unless cellp (setf-line-n-out-of-range f en))
    12591311               (ccl::set-closed-over-value value new-value)))
    1260             ((eql (decf n nclosed) 0)   ; "Disassembly"
    1261              (setf-line-n-out-of-range f en))
    1262             (t (set-disassembly-line-n f (- n 1) new-value))))))
     1312            (t (set-disassembly-line-n f (- n nclosed) new-value))))))
    12631313
    12641314(defun compute-disassembly-lines (f &optional (function (inspector-object f)))
    1265   (if (functionp function)
    1266     (let* ((info (and (disasm-p f)  (coerce (ccl::disassemble-list function) 'vector)))
    1267            (length (length info))
    1268            (last-pc (if info (car (svref info (1- length))) 0)))
    1269       (if (listp last-pc) (setq last-pc (cadr last-pc)))
    1270       (setf (pc-width f) (length (format nil "~d" last-pc)))
    1271       (setf (disasm-info f) info)
    1272       length)
     1315  (if (and (functionp function) (disasm-p f))
     1316    (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr)
     1317           (length (length lines))
     1318           (last-label (loop for n from (1- length) downto 0 as line = (aref lines n)
     1319                             thereis (and (consp line) (cadr line))))
     1320           (max-pc (if (consp last-label) (cadr last-label) last-label)))
     1321      (setf (pc-width f) (length (format nil "~d" max-pc)))
     1322      (setf (disasm-info f) lines)
     1323      (1+ length))
    12731324    0))
    12741325
    12751326(defun disassembly-line-n (f n)
    1276   (let* ((line (svref (disasm-info f) n))
    1277          (value (disasm-line-immediate line)))
    1278     (values value line (if value :static :comment))))
     1327  (if (< (decf n) 0)
     1328    (values nil "Disassembly:" :comment)
     1329    (let ((line (svref (disasm-info f) n)))
     1330      (if (consp line)
     1331        (destructuring-bind (object label instr) line
     1332          (values object (cons label instr) :static))
     1333        (values nil (cons nil line) :static)))))
     1334
     1335(defun disassembly-line-n-inspector (f n)
     1336  (unless (< (decf n) 0)
     1337    (let ((line (svref (disasm-info f) n)))
     1338      (and (consp line)
     1339           (car line)
     1340           (make-inspector (car line))))))
     1341
     1342(defun disassembly-line-n-strings (f n)
     1343  (if (< (decf n) 0)
     1344    (values "Disassembly:" nil)
     1345    (let ((line (svref (disasm-info f) n)))
     1346      (if (consp line)
     1347        (destructuring-bind (object label instr) line
     1348          (declare (ignore object))
     1349          (unless (stringp label)
     1350            (setq label (with-output-to-string (stream)
     1351                          (prin1-disassembly-label f stream label))))
     1352          (values label instr))
     1353        (values nil line)))))
    12791354
    12801355(defun set-disassembly-line-n (f n new-value &optional
     
    12831358  (setf-line-n-out-of-range f n))
    12841359
    1285 (defun disasm-line-immediate (line &optional (lookup-functions t))
    1286   (pop line)                        ; remove address
    1287   (when (eq (car line) 'ccl::jsr_subprim)
    1288     (return-from disasm-line-immediate (find-symbol (cadr line) :ccl)))
    1289   (let ((res nil))
    1290     (labels ((inner-last (l)
    1291                (cond ((atom l) l)
    1292                      ((null (cdr l)) (car l))
    1293                      (t (inner-last (last l))))))
    1294       (dolist (e line)
    1295         (cond ((numberp e) (when (null res) (setq res e)))
    1296               ((consp e)
    1297                (cond ((eq (car e) 'function)
    1298                       (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
    1299                      ((eq (car e) 17)   ; locative
    1300                       (setq e (cadr e))
    1301                       (unless (atom e)
    1302                         (cond ((eq (car e) 'special)
    1303                                (setq res (cadr e)))
    1304                               ((eq (car e) 'function)
    1305                                (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
    1306                               (t (setq res (inner-last e))))))
    1307                      ((or (null res) (numberp res))
    1308                       (setq res (inner-last e))))))))
    1309     res))
    1310 
    1311 (defmethod inspector-print-function ((i function-inspector) type)
    1312   (declare (ignore type))
    1313   'prin1-normal-line)
    1314 
    1315 (defmethod prin1-label ((f function-inspector) stream value &optional label type)
     1360(defmethod prin1-label ((f function-inspector) stream value &optional data type)
    13161361  (declare (ignore value type))
    1317   (if (atom label)                      ; not a disassembly line
     1362  (if (atom data)                      ; not a disassembly line
    13181363    (call-next-method)
    1319     (let* ((pc (car label))
    1320            (label-p (and (listp pc) (setq pc (cadr pc))))
    1321            (pc-mark (pc f)))
    1322       (if (eq pc pc-mark)
    1323         (format stream "*~vd" (pc-width f) pc)
    1324         (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc))
    1325       (write-char (if label-p #\= #\ ) stream))))
     1364    (prin1-disassembly-label f stream (car data))))
     1365
     1366(defun prin1-disassembly-label (f stream label)
     1367  (let* ((pc label)
     1368         (label-p (and (consp pc) (setq pc (cadr pc))))
     1369         (pc-mark (pc f))
     1370         (pc-width (pc-width f)))
     1371    (when pc
     1372      (write-char (if (eql pc pc-mark) #\* #\Space) stream)
     1373      (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc))))
     1374
     1375(defmethod prin1-value ((f function-inspector) stream value &optional data type)
     1376  (declare (ignore value type))
     1377  (if (atom data) ;; not a disassembly line
     1378    (call-next-method)
     1379    (princ (cdr data) stream)))
     1380
    13261381
    13271382#+ppc-target
     
    13421397;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
    13431398(defclass gf-inspector (function-inspector)
    1344   ((method-count :accessor method-count)
    1345    (slot-count :accessor slot-count :initform 0)))
     1399  ((method-count :accessor method-count)))
    13461400
    13471401(defmethod inspector-class ((f standard-generic-function))
     
    13501404    'standard-object-inspector))
    13511405
    1352 (defmethod compute-line-count ((f gf-inspector))
     1406(defmethod compute-line-count :before ((f gf-inspector))
    13531407  (let* ((gf (inspector-object f))
    1354          (count (length (generic-function-methods gf)))
    1355          (res (+ 1 (setf (method-count f) count) 
    1356                  (call-next-method))))
    1357     (if (disasm-p f) (1+ res) res)))
     1408         (count (length (generic-function-methods gf))))
     1409    (setf (method-count f) count)))
     1410
     1411(defmethod header-count ((f gf-inspector))
     1412  (+ (standard-header-count f) 1 (method-count f)))
    13581413
    13591414(defmethod line-n ((f gf-inspector) n)
    13601415  (let* ((count (method-count f))
    1361          (header-count (header-count f))
    1362          (slot-count (slot-count f))
    1363          (lines (1+ count)))
    1364     (if (<= header-count n (+ lines slot-count header-count))
    1365       (let ((methods (generic-function-methods (inspector-object f))))
    1366         (cond ((eql (decf n header-count) 0) (values methods "Methods: " :static))
    1367               ((<= n count)
    1368                (values (nth (- n 1) methods) nil :static))
    1369               ((< (decf n (1+ count)) slot-count)
    1370                (standard-object-line-n f n))
    1371               (t
    1372                (values 0 "Disassembly" :comment #'prin1-comment))))
    1373       (call-next-method f (if (< n header-count) n (- n lines slot-count 1))))))
     1416         (methods (generic-function-methods (inspector-object f))))
     1417    (cond ((< (decf n  (standard-header-count f)) 0)
     1418           (call-next-method))
     1419          ((< (decf n) 0)
     1420           (values methods "Methods: " :comment))
     1421          ((< n count)
     1422           (values (nth n methods) nil :static))
     1423          (t (disassembly-line-n f (- n count))))))
    13741424
    13751425(defmethod (setf line-n) (new-value (f gf-inspector) n)
    13761426  (let* ((count (method-count f))
    1377          (header-count (header-count f))
    1378          (slot-count (slot-count f))
    1379          (lines (1+ count)))
    1380     (if (<= header-count n (+ lines slot-count header-count))
    1381       (let ((en n))
    1382         (cond ((<= (decf en header-count) count)
    1383                (setf-line-n-out-of-range f n))
    1384               ((< (decf en (1+ count)) slot-count)
    1385                (standard-object-setf-line-n new-value f en))
    1386               (t (setf-line-n-out-of-range f n))))
    1387       (call-next-method new-value f (if (< n header-count) n (- n lines slot-count 1))))))
     1427         (en n))
     1428    (cond ((< (decf n (standard-header-count f)) 0)
     1429           (call-next-method))
     1430          ((< (decf n) count)
     1431           (setf-line-n-out-of-range f en))
     1432          (t (set-disassembly-line-n f (- n count) new-value)))))
    13881433
    13891434#|
     
    14001445      (call-next-method))))
    14011446|#
    1402 
    1403 (defclass method-inspector (standard-object-inspector function-inspector)
    1404   ((standard-object-lines :accessor standard-object-lines)))
    1405 
    1406 (defmethod inspector-class ((object standard-method))
    1407   'method-inspector)
    1408 
    1409 (defmethod compute-line-count ((i method-inspector))
    1410   (+ (setf (standard-object-lines i) (call-next-method))
    1411      (if (disasm-p i) 1 0)              ; "Disassembly"
    1412      (compute-disassembly-lines i (method-function (inspector-object i)))))
    1413 
    1414 (defmethod line-n ((i method-inspector) n)
    1415   (let ((sol (standard-object-lines i)))
    1416     (cond ((< n sol) (call-next-method))
    1417           ((eql n sol) (values nil "Disassembly" :comment))
    1418           (t (disassembly-line-n i (- n sol 1))))))
    1419 
    1420 (defmethod (setf line-n) (new-value (i method-inspector) n)
    1421   (let ((sol (standard-object-lines i)))
    1422     (cond ((< n sol) (call-next-method))
    1423           ((eql n sol) (setf-line-n-out-of-range i n))
    1424           (t (set-disassembly-line-n
    1425               i n new-value (method-function (inspector-object i)))))))
    1426 
    1427 ;;; funtion-inspector never does prin1-comment.
    1428 (defmethod prin1-normal-line ((i method-inspector) stream value &optional
    1429                               label type colon-p)
    1430   (declare (ignore colon-p))
    1431   (if (eq type :comment)
    1432     (prin1-comment i stream value label type)
    1433     (call-next-method)))
    1434 
    14351447
    14361448;;;;;;;
     
    18031815(defmethod ui-present ((ui inspector-tty-ui))
    18041816  (let* ((inspector (inspector-ui-inspector ui)))
    1805     (when (null (inspector-line-count inspector))
    1806       (update-line-count inspector))
    18071817    (with-errorfree-printing
    18081818        (let* ((stream *debug-io*)
     
    18121822               (n (compute-line-count inspector))
    18131823               (end (min page-end n))
    1814                (tag origin)
     1824               (tag -1)
    18151825               (*print-pretty* (or *print-pretty* *describe-pretty*))
    18161826               (*print-length* 5)
    18171827               (*print-level* 5)
    1818                (func #'(lambda (i value &rest rest)
    1819                          (declare (dynamic-extent rest))
    1820                          (let* ((type (cadr rest)))
    1821                            (unless (or (eq type :comment)
    1822                                    (and (consp type)
    1823                                         (eq (car type) :comment)))
    1824                              (format stream "[~d] " tag))
    1825                            (incf tag))
    1826                          (format stream "~8t")
    1827                          (apply #'prin1-line i stream value rest)
    1828                          (terpri stream))))
     1828               (func #'(lambda (i index child &optional label-string value-string)
     1829                         (declare (ignore i))
     1830                         (when child (incf tag))
     1831                         (unless (< index origin)
     1832                           (format stream "~@[[~d]~]~8t" (and child tag))
     1833                           (format-line-for-tty stream label-string value-string)
     1834                           (terpri stream)))))
    18291835          (declare (dynamic-extent func))
    1830           (map-lines inspector func origin end)))
     1836          (map-lines inspector func 0 end)))
    18311837    (values)))
    18321838
     
    19101916
    19111917(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
    1912   (let* ((inspector (inspector-ui-inspector ui)))
    1913     (multiple-value-bind (value label type)
    1914         (line-n inspector n)
    1915       (unless (or (eq type :comment)
    1916                   (and (consp type) (eq (car type) :comment)))
    1917         (let* ((new-inspector (line-n-inspector inspector n value label type))
    1918                (ccl::@ value))
    1919           (inspector-ui-inspect
    1920            (make-instance 'inspector-tty-ui
    1921                           :level (1+ (inspector-ui-level ui))
    1922                           :inspector new-inspector)))))))
    1923      
     1918  (let* ((inspector (inspector-ui-inspector ui))
     1919         (new-inspector (block nil
     1920                          (let* ((tag -1)
     1921                                 (func #'(lambda (i index child &rest strings)
     1922                                           (declare (ignore i index strings))
     1923                                           (when (and child (eql (incf tag) n)) (return child)))))
     1924                            (declare (dynamic-extent func))
     1925                            (map-lines inspector func))))
     1926         (ccl::@ (inspector-object new-inspector)))
     1927    (inspector-ui-inspect
     1928     (make-instance 'inspector-tty-ui
     1929       :level (1+ (inspector-ui-level ui))
     1930       :inspector new-inspector))))
     1931
    19241932(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
    19251933
Note: See TracChangeset for help on using the changeset viewer.