Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 12948) +++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 12949) @@ -2671,46 +2671,63 @@ - +(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,4 +2739,22 @@ `(* ,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,9 +2784,9 @@ (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,20 +2804,24 @@ (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,9 +2829,11 @@ (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,46 +2844,11 @@ (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,37 +2861,13 @@ (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,15 +2895,69 @@ (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) + "#"))) + (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))) Index: /branches/working-0711/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 12948) +++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 12949) @@ -10131,5 +10131,5 @@ (when disassemble (format t "~%~%") - (apply #'x8664-disassemble-xfunction + (apply #'x86-disassemble-xfunction xlfun (unless symbolic-names (list nil)))) @@ -10153,5 +10153,5 @@ (let ((*target-backend* backend)) (format t "~%~%") - (apply #'x8632-disassemble-xfunction + (apply #'x86-disassemble-xfunction xlfun (unless symbolic-names (list nil))))) Index: /branches/working-0711/ccl/lib/describe.lisp =================================================================== --- /branches/working-0711/ccl/lib/describe.lisp (revision 12948) +++ /branches/working-0711/ccl/lib/describe.lisp (revision 12949) @@ -20,4 +20,6 @@ "COMPUTE-LINE-COUNT" "LINE-N" + "INSPECTOR-OBJECT" + "INSPECTOR-LINE-COUNT" "*INSPECTOR-DISASSEMBLY*")) @@ -35,5 +37,10 @@ (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,4 +52,20 @@ (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,16 +112,29 @@ (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,5 +147,6 @@ (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,9 +163,4 @@ (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,4 +171,6 @@ (start 0) end) + (when (null (inspector-line-count i)) + (update-line-count i)) (unless end (setq end (inspector-line-count i))) @@ -144,6 +178,5 @@ (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,4 +246,15 @@ (*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,12 +270,10 @@ (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,8 +299,6 @@ (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,10 +307,9 @@ (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,4 +392,9 @@ (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,9 +1025,8 @@ (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,6 +1040,6 @@ (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,7 +1050,6 @@ (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,8 +1060,8 @@ (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,8 +1069,8 @@ *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,11 +1079,10 @@ (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,5 +1146,5 @@ (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,59 +1184,77 @@ ;; (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,18 +1266,15 @@ 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,40 +1282,55 @@ (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,45 +1339,26 @@ (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,6 +1379,5 @@ ;; (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,38 +1386,31 @@ '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,37 +1427,4 @@ (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,5 +1576,5 @@ (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,6 +1797,4 @@ (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,21 +1804,17 @@ (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,16 +1898,18 @@ (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) Index: /branches/working-0711/ccl/lib/misc.lisp =================================================================== --- /branches/working-0711/ccl/lib/misc.lisp (revision 12948) +++ /branches/working-0711/ccl/lib/misc.lisp (revision 12949) @@ -774,6 +774,5 @@ 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)))