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

Last change on this file since 16685 was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • 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 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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 (>= (instruction-element-address insn) labaddr)
247       (return (insert-dll-node-after l (instruction-element-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.