source: trunk/source/compiler/PPC/ppc-disassemble.lisp @ 12846

Last change on this file since 12846 was 12846, checked in by gz, 10 years ago

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.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(eval-when (:compile-toplevel :load-toplevel :execute)
18  (require "NXENV")
19  (require "DLL-NODE")
20  (require "PPC-ASM")
21  (require "PPC-LAP"))
22
23(defparameter *ppc-disassembly-backend* *host-backend*)
24(defparameter *ppc-disassemble-raw-instructions* nil)
25
26(eval-when (:compile-toplevel :execute)
27  (require "PPCENV"))
28
29(defun ppc-gpr (r)
30  (or
31   (case (backend-target-arch-name *ppc-disassembly-backend*)
32     (:ppc32 (and (eql r ppc32::rcontext) 'ppc32::rcontext))
33     (:ppc64 (and (eql r ppc64::rcontext) 'ppc64::rcontext)))
34   (svref ppc::*gpr-register-names* r)))
35
36(defun ppc-fpr (r)
37  (svref ppc::*fpr-register-names* r))
38
39(defun ppc-vr (r)
40    (svref ppc::*vector-register-names* r))
41
42;;; To "unmacroexpand" something is to undo the effects of
43;;; some sort of macroexpansion, returning some presumably
44;;; more meaningful equivalent form.  Some cases of this
45;;; are trivial (e.g., turning (stwu rX -4 vsp) into (vpush rX);
46;;; some would depend on surrounding context and are still
47;;; heuristic.  A few cases can probably benefit from state
48;;; maintained by preceding instructions, e.g., (twnei rX 1)
49;;; is presumably looking at the low 2 or three bits of rX; we
50;;; have to know what set rX to know which.
51
52;;; For now, just try to handle a few simple cases.
53;;; Return a new form (new-opcode-name &rest new-operands) or NIL.
54;;;
55
56(defparameter *ppc-unmacroexpanders* (make-hash-table :test #'equalp))
57
58(defun ppc-unmacroexpand-function (name)
59  (let* ((pname (string name))
60         (opnum (gethash pname ppc::*ppc-opcode-numbers*)))
61    (unless opnum (error "Unknown ppc opcode name ~s." name))
62    (values (gethash pname *ppc-unmacroexpanders*))))
63
64(defun (setf ppc-unmacroexpand-function) (def name)
65  (let* ((pname (string name))
66         (opnum (gethash pname ppc::*ppc-opcode-numbers*)))
67    (unless opnum (error "Unknown ppc opcode name ~s." name))
68    (setf (gethash pname *ppc-unmacroexpanders*) def)))
69
70(defmacro def-ppc-unmacroexpand (name insn-var lambda-list &body body)
71  `(setf (ppc-unmacroexpand-function ',name)
72         #'(lambda (,insn-var)
73             (destructuring-bind ,lambda-list (lap-instruction-parsed-operands ,insn-var)
74               ,@body))))
75
76(def-ppc-unmacroexpand stwu insn (rs d ra)
77  (case (backend-target-arch-name *ppc-disassembly-backend*)
78    (:ppc32
79     (if (and (= ra ppc::vsp) (= d -4))
80       `(vpush ,(ppc-gpr rs))))))
81
82(def-ppc-unmacroexpand stdu insn (rs d ra)
83  (case (backend-target-arch-name *ppc-disassembly-backend*)
84    (:ppc64
85     (if (and (= ra ppc::vsp) (= d -8))
86       `(vpush ,(ppc-gpr rs))))))
87
88(def-ppc-unmacroexpand rlwinm insn (rt ra b mb &optional (me mb me-p))
89  (if (not me-p)
90    (setq mb 0))                        ; That's what's happening now to fake operands.
91  (if (and (= me 31) (= (+ b mb) 32))
92    `(srwi ,(ppc-gpr rt) ,(ppc-gpr ra) ,mb)
93    (if (and (= mb 0) (= (+ b me) 31))
94      (if (and (case (backend-target-arch-name *ppc-disassembly-backend*)
95                 (:ppc32 t))
96             (logbitp rt ppc-node-regs)
97             (not (logbitp ra ppc-node-regs))
98             (= b (arch::target-fixnum-shift (backend-target-arch
99                                               *ppc-disassembly-backend*))))
100        `(box-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra))
101        `(slwi ,(ppc-gpr rt) ,(ppc-gpr ra) ,b)))))
102
103(def-ppc-unmacroexpand rldicr insn (rt ra sh me)
104  (if (= (+ sh me) 63)
105    (if (and (case (backend-target-arch-name *ppc-disassembly-backend*)
106               (:ppc64 t))
107             (logbitp rt ppc-node-regs)
108             (not (logbitp ra ppc-node-regs))
109             (= sh (arch::target-fixnum-shift (backend-target-arch
110                                               *ppc-disassembly-backend*))))
111      `(box-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra))
112      `(sldi ,(ppc-gpr rt) ,(ppc-gpr ra) ,sh))))
113
114(def-ppc-unmacroexpand rldicl insn (rt ra sh mb)
115  (if (= (+ sh mb) 64)
116    `(srdi ,(ppc-gpr rt) ,(ppc-gpr ra) ,mb)))
117
118(def-ppc-unmacroexpand srawi insn (rt ra sh)
119  (if (and (case (backend-target-arch-name *ppc-disassembly-backend*)
120             (:ppc32 t))
121           (not (logbitp rt ppc-node-regs))
122           (logbitp ra ppc-node-regs)
123           (= sh (arch::target-fixnum-shift (backend-target-arch
124                                             *ppc-disassembly-backend*))))
125    `(unbox-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra))))
126
127(def-ppc-unmacroexpand sradi insn (rt ra sh)
128  (if (and (case (backend-target-arch-name *ppc-disassembly-backend*)
129             (:ppc64 t))
130           (not (logbitp rt ppc-node-regs))
131           (logbitp ra ppc-node-regs)
132           (= sh (arch::target-fixnum-shift (backend-target-arch
133                                             *ppc-disassembly-backend*))))
134    `(unbox-fixnum ,(ppc-gpr rt) ,(ppc-gpr ra))))
135
136(def-ppc-unmacroexpand li insn (rt imm)
137  (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*))))
138    (if (not (logtest (1- (ash 1 fixnumshift)) imm))
139      (if (logbitp rt ppc-node-regs)
140        `(li ,(ppc-gpr rt) ',(ash imm (- fixnumshift)))
141        (if (eql rt ppc::nargs)
142          `(set-nargs ,(ash imm (- fixnumshift))))))))
143
144
145
146(def-ppc-unmacroexpand cmpwi insn (crf ra simm)
147  (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*))))
148    (if (and (not (logtest (1- (ash 1 fixnumshift)) simm))
149             (logbitp ra ppc-node-regs))
150      `(cmpwi ,@(unless (eql 0 crf) `(,(aref *ppc-cr-names* (ash crf -2))))
151        ,(ppc-gpr ra)
152        ',(ash simm (- fixnumshift))))))
153
154(def-ppc-unmacroexpand cmpdi insn (crf ra simm)
155  (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*))))
156    (if (and (not (logtest (1- (ash 1 fixnumshift)) simm))
157             (logbitp ra ppc-node-regs))
158      `(cmpdi ,@(unless (eql 0 crf) `(,(aref *ppc-cr-names* (ash crf -2))))
159        ,(ppc-gpr ra)
160        ',(ash simm (- fixnumshift))))))
161
162(def-ppc-unmacroexpand addi insn (rd ra simm)
163  (let* ((fixnumshift (arch::target-fixnum-shift (backend-target-arch *ppc-disassembly-backend*)))
164         (disp-d (ppc-gpr rd))
165         (disp-a (ppc-gpr ra)))
166    (if (or (eql ra ppc::sp)
167            (eql ra ppc::tsp)
168            (eql ra ppc::vsp))
169        `(la ,disp-d ,simm ,disp-a)
170        (let* ((opcode 'addi)
171               (val (abs simm)))
172          (if (< simm 0)
173              (setq opcode 'subi))
174          (if (and (not (logtest (1- (ash 1 fixnumshift)) simm))
175                   (logbitp rd ppc-node-regs)
176                   (logbitp ra ppc-node-regs))
177            `(,opcode ,disp-d ,disp-a ',(ash val (- fixnumshift)))
178            `(,opcode ,disp-d ,disp-a ,(if (eq val
179                                               (arch::target-nil-value (backend-target-arch *ppc-disassembly-backend*))) nil val)))))))
180
181(defun ppc-unmacroexpand (insn)
182  (unless *ppc-disassemble-raw-instructions*
183    (let* ((expander (ppc-unmacroexpand-function (opcode-name (lap-instruction-opcode insn))))
184           (expansion (if expander (funcall expander insn))))
185      (when expansion
186        (setf (lap-instruction-opcode insn) (car expansion)
187              (lap-instruction-parsed-operands insn) (cdr expansion))
188        expansion))))
189
190
191(defun find-ppc-opcode (i)
192  (let* ((op (ldb (byte 6 26) i))
193         (k (svref ppc::*ppc-opcode-indices* op)))
194    (declare (type (unsigned-byte 12) k)
195             (type (unsigned-byte 6) op))
196    (unless (= k -1)
197      (dotimes (j (svref ppc::*ppc-opcode-counts* op))
198        (declare (type (unsigned-byte 10) j))
199        (let* ((code (svref ppc::*ppc-opcodes* (+ k j))))
200          (if (= (logand (opcode-mask code) i)
201                 (opcode-opcode code))
202            (if (dolist (op (opcode-operands code) t)
203                  (let* ((xfun (operand-extract-function op)))
204                    (unless (or (null xfun)
205                                (funcall xfun i))
206                      (return nil))))
207              (return code))))))))
208
209(defun ppc-disasm-1 (i pc header)
210  (let* ((opcode (find-ppc-opcode i)))
211    (if (null opcode)
212      (error "Unknown PPC instruction : #x~8,'0x" i)    ; should handle somehow
213      (let* ((vals ()))
214        (dolist (operand (opcode-operands opcode))
215          (unless (logbitp operand-fake (operand-flags operand))
216            (let* ((extract-fn (operand-extract-function operand)))
217              (push (if extract-fn
218                      (funcall extract-fn i)
219                      (ppc::extract-default operand i))
220                    vals))))
221        (let* ((insn (%make-lap-instruction opcode)))
222          (setf (lap-instruction-parsed-operands insn)
223                (nreverse vals))
224          (setf (lap-instruction-address insn)
225                pc)
226          (append-dll-node insn header))))))
227               
228
229(defvar *disassembled-ppc-instructions* ())
230(defvar *disassembled-ppc-labels* ())
231
232
233
234(defun ppc-label-at-address (address)
235  (dolist (l *disassembled-ppc-labels* 
236             (let* ((label (%make-lap-label (intern (format nil "L~d" address)))))
237               (setf (lap-label-address label) address)
238               (push label *disassembled-ppc-labels*)
239               label))
240    (when (= address (lap-label-address l))
241      (return l))))
242
243(defun insert-ppc-label (l instructions)
244  (let* ((labaddr (lap-label-address l)))
245   (do-dll-nodes (insn instructions (append-dll-node l instructions))
246     (when (>= (lap-instruction-address insn) labaddr)
247       (return (insert-dll-node-after l (lap-instruction-pred insn)))))))
248
249(defun ppc-disassemble-cr (val operand-spec)
250  (declare (type (mod 32) val))
251  (let* ((width (operand-width operand-spec))
252         (crnum (ash val -2))
253         (ccnum (logand val 3)))
254    (declare (fixnum width crnum ccnum))
255    (if (= width 3)
256      (unless (= crnum 0) (aref *ppc-cr-names* crnum))
257      (if (= ccnum 0)
258        (unless (= crnum 0) (aref *ppc-cr-names* crnum))
259        (list (aref *ppc-cr-field-names* crnum) (aref *ppc-cc-bit-names* ccnum))))))
260
261(defun ppc-analyze-operands (instructions constants)
262  (let* ((pc 0)
263         (regsave-pseudo nil)
264         (arch (backend-target-arch *ppc-disassembly-backend*))
265         (nil-value (arch::target-nil-value arch))
266         (misc-data-offset (arch::target-misc-data-offset arch))
267         (word-shift (arch::target-word-shift arch))
268         (align-mask (1- (ash 1 word-shift))))
269    (declare (fixnum pc))
270    (let* ((last (dll-header-last instructions)))
271      (when (eq (lap-instruction-opcode last) *ppc-lwz-instruction*)
272        (remove-dll-node last)
273        (setq regsave-pseudo last)))
274    (do-dll-nodes (insn instructions)
275      (unless (ppc-unmacroexpand insn)
276        (let* ((opcode (lap-instruction-opcode insn))
277               (opvalues (lap-instruction-parsed-operands insn)))
278          (do* ((operands (opcode-operands opcode) (cdr operands))
279                (operand (car operands) (car operands))
280                (header (cons nil opvalues))
281                (tail header))
282               ((null operands) (setf (lap-instruction-parsed-operands insn) (cdr header)))
283            (declare (dynamic-extent header))
284            (let* ((flags (operand-flags operand))
285                   (opidx (operand-index operand))
286                   (val (cadr tail)))
287              (declare (fixnum flags))
288              (if (and (logbitp operand-optional flags)
289                       (eql 0 val))
290                (rplacd tail (cddr tail))
291                (progn
292                  (if (and (or (eq opidx ppc::$si)
293                               (eq opidx ppc::$nsi)
294                               (eq opidx ppc::$ui))
295                           (eql val nil-value))
296                    (setf (cadr tail) nil)
297                    (if (logbitp ppc::$ppc-operand-relative flags)
298                      (let* ((label (ppc-label-at-address (+ pc val))))
299                        (setf (cadr tail) (lap-label-name label)))
300                      (if (logbitp ppc::$ppc-operand-cr flags)
301                        (let* ((cr (ppc-disassemble-cr val operand)))
302                          (when cr (setf (cadr tail) cr)))
303                        (if (logbitp ppc::$ppc-operand-absolute flags)
304                          (let* ((info (find val ppc::*ppc-subprims* :key #'subprimitive-info-offset)))
305                            (when info (setf (cadr tail) (subprimitive-info-name info))))
306                          (if (logbitp ppc::$ppc-operand-fpr flags)
307                            (setf (cadr tail) (ppc-fpr val))
308                            (if (logbitp ppc::$ppc-operand-vr flags) ; SVS
309                              (setf (cadr tail) (ppc-vr val))
310                              (when (logbitp ppc::$ppc-operand-gpr flags)
311                                (setf (cadr tail) (ppc-gpr val))
312                                (when (eq val ppc::fn)
313                                  (let* ((disp (car tail)))
314                                    (when (and disp (typep disp 'fixnum))
315                                      (let* ((unscaled (+ (- misc-data-offset) disp)))
316                                        (unless (logtest align-mask unscaled)
317                                          (let* ((idx (ash unscaled (- word-shift))))
318                                            (if (< idx (uvsize constants))
319                                              (rplaca tail (list 'quote (uvref constants idx)))))))))))))))))
320                  (setq tail (cdr tail))))))))
321      (incf pc 4))
322    (dolist (l *disassembled-ppc-labels*) (insert-ppc-label l instructions))
323    (when regsave-pseudo
324      (destructuring-bind (reg offset pc) (lap-instruction-parsed-operands regsave-pseudo)
325        (declare (fixnum reg offset pc))
326        (let* ((nregs (- 32 reg)))
327          (declare (fixnum nregs))
328          (setq pc (ash (the fixnum (dpb (ldb (byte 2 0) offset) (byte 2 5) pc)) 2)
329                offset (- (logand (lognot 3) (- offset)) (ash nregs target::word-shift))))
330        (setf (lap-instruction-opcode regsave-pseudo) :regsave
331              (lap-instruction-parsed-operands regsave-pseudo)
332              (list (ppc-gpr reg) offset)
333              (lap-instruction-address regsave-pseudo) pc)
334        (do-dll-nodes (node instructions)
335          (when (>= (lap-instruction-address node) pc)
336            (insert-dll-node-after regsave-pseudo (dll-node-pred node))
337            (return)))))))
338             
339     
340; This returns a doubly-linked list of INSTRUCTION-ELEMENTs; the caller (disassemble, INSPECT)
341; can format the contents however it wants.
342(defun disassemble-ppc-function (code-vector constants-vector &optional (start-word 0))
343  (let* ((*disassembled-ppc-labels* nil)
344         (header (make-dll-header)))
345    (let* ((n (uvsize code-vector)))
346      (declare (fixnum n))
347      (do* ((i start-word (1+ i))
348            (pc 0 (+ pc 4)))
349           ((= i n))
350        (declare (fixnum i))
351        (let* ((opcode (uvref code-vector i)))
352          (declare (integer opcode))
353          (if (= opcode 0)
354            (return)
355            (ppc-disasm-1 opcode pc header))))
356      (ppc-analyze-operands header constants-vector))
357    header))
358
359(defun print-ppc-instruction (stream tabcount opcode parsed-operands)
360  (let* ((name (if (symbolp opcode) opcode (opcode-name opcode))))
361    (if (keywordp name)
362      (format stream "~&~V,t(~s" tabcount name)
363      (format stream "~&~V,t(~a" tabcount name))
364    (dolist (op parsed-operands (format stream ")"))
365      (format stream (if (and (consp op) (eq (car op) 'quote)) " ~s" " ~a") op))))
366
367(defun print-ppc-instructions (stream function instructions &optional for-lap backend)
368  (declare (ignorable backend))
369  (let* ((tab (if for-lap 6 2))
370         (previous-source-note nil))
371
372    (let ((source-note (function-source-note function)))
373      (when source-note
374        (format t ";; Source: ~S:~D-~D"
375                (source-note-filename source-note)
376                (source-note-start-pos source-note)
377                (source-note-end-pos source-note))
378        ;; Fetch text from file if don't already have it
379        (ensure-source-note-text source-note)))
380
381    (when for-lap 
382      (let* ((lap-function-name (car for-lap)))
383        (format stream "~&(~S ~S ~&  (~S (~s) ~&    (~s ~s ()" 
384                'nfunction lap-function-name 'lambda '&lap 'ppc-lap-function lap-function-name)))
385
386    (do-dll-nodes (i instructions)
387      (let ((source-note (find-source-note-at-pc function (instruction-element-address i))))
388        (unless (eql (source-note-file-range source-note)
389                     (source-note-file-range previous-source-note))
390          (setf previous-source-note source-note)
391          (let* ((source-text (source-note-text source-note))
392                 (text (if source-text
393                         (string-sans-most-whitespace source-text 100)
394                         "#<no source text>")))
395            (format stream "~&~%;;; ~A" text))))
396      (etypecase i
397        (lap-label (format stream "~&~a " (lap-label-name i)))
398        (lap-instruction 
399         (print-ppc-instruction stream tab (lap-instruction-opcode i) (lap-instruction-parsed-operands i)))))
400    (when for-lap (format stream ")))~&"))))
401
402
403(defun ppc-Xdisassemble (fn-vector &key (for-lap nil) (stream *standard-output*) target ((:raw *ppc-disassemble-raw-instructions*) nil))
404  (let* ((backend (if target (find-backend target) *host-backend*))
405         (prefix-length (length (arch::target-code-vector-prefix (backend-target-arch backend))))
406         (*ppc-disassembly-backend* backend))
407    (print-ppc-instructions stream fn-vector
408                            (function-to-dll-header fn-vector prefix-length)
409                            (if for-lap (list (uvref fn-vector (- (uvsize fn-vector) 2)))))
410    (values)))
411
412(defun function-to-dll-header (fn-vector &optional (prefix #+ppc32-target 0 #+ppc64-target 1))
413  (let* ((codev (uvref fn-vector 0)))
414    (disassemble-ppc-function codev fn-vector prefix)))
415
416
417(defun disassemble-list (thing)
418  (let ((dll (function-to-dll-header (function-for-disassembly thing)))
419        (address 0)
420        (label-p nil)
421        (res nil))
422    (do-dll-nodes (i dll)
423      (setq address (instruction-element-address i))
424      (etypecase i
425        (lap-label
426         (setq label-p (lap-label-name i)))
427        (lap-instruction
428         (let ((opcode (lap-instruction-opcode i))
429               (operands (lap-instruction-parsed-operands i)))
430           (push (list* (if label-p `(label ,address) address)
431                        (if (symbolp opcode) opcode (opcode-name opcode))
432                        operands)
433                 res)
434           (setq label-p nil)))))
435    (nreverse res)))
436
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
468#+ppc-target
469(defun disasm-prin1 (thing stream)
470  (if (and (consp thing) (consp (cdr thing)) (null (cddr thing)))
471    (cond ((eq (%car thing) 'quote)
472           (prin1 thing stream))
473          ((eq (%car thing) 'function)
474           (format stream "#'~S" (cadr thing)))
475          ((eq (%car thing) 16)
476             (format stream "#x~X" (cadr thing)))
477          ((eq (%car thing) 'label)
478           (let ((*print-radix* nil))
479             (princ (cadr thing) stream)))
480          (t (princ thing stream)))
481    (princ thing stream)))
482
483
Note: See TracBrowser for help on using the repository browser.