Changeset 12838


Ignore:
Timestamp:
Sep 15, 2009, 3:43:59 PM (10 years ago)
Author:
gz
Message:

Arrange to prin1 (rather than princ) quoted constant references in disassembly.

Split off some code to fetch operand constants.

merge x8632-disassemble/x8664-disassemble et. al. into x86-disassemble.

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x86-disassemble.lisp

    r11385 r12838  
    26712671
    26722672
    2673    
     2673(defmethod x86-lap-operand-constant-offset (op ds)
     2674  (declare (ignore op ds))
     2675  nil)
     2676
     2677(defmethod x86-lap-operand-constant-offset ((op x86::x86-memory-operand) ds)
     2678  (let* ((disp (x86::x86-memory-operand-disp op))
     2679         (base (x86::x86-memory-operand-base op))
     2680         (index (x86::x86-memory-operand-index op))
     2681         (scale (x86::x86-memory-operand-scale op))
     2682         (code-limit (x86-ds-code-limit ds))
     2683         (val (and base
     2684                   (eq (x86::x86-register-operand-entry base)
     2685                       (if (x86-ds-mode-64 ds)
     2686                         (x86::x86-reg64 13)
     2687                         (x86::x86-reg32 x8632::fn)))
     2688                   (null index)
     2689                   (or (eql scale 0) (null scale))
     2690                   (typecase disp
     2691                     (constant-x86-lap-expression
     2692                      (+ (x86-ds-entry-point ds)
     2693                         (constant-x86-lap-expression-value disp)))
     2694                     (integer
     2695                      (+ (x86-ds-entry-point ds) disp))
     2696                     (t nil)))))
     2697    (when (and val (>= val code-limit))
     2698      (- val code-limit))))
     2699
     2700(defun x86-lap-operand-constant (op ds)
     2701  (let ((diff (x86-lap-operand-constant-offset op ds)))
     2702    (when diff
     2703      (values (uvref (x86-ds-constants-vector ds)
     2704                     (1+ (ash diff (if (x86-ds-mode-64 ds)
     2705                                     (- x8664::word-shift)
     2706                                     (- x8632::word-shift)))))
     2707              t))))
     2708
     2709
    26742710(defmethod unparse-x86-lap-operand ((x x86::x86-memory-operand) ds)
    2675   (let* ((seg (x86::x86-memory-operand-seg x))
    2676          (disp (x86::x86-memory-operand-disp x))
    2677          (base (x86::x86-memory-operand-base x))
    2678          (index (x86::x86-memory-operand-index x))
    2679          (scale (x86::x86-memory-operand-scale x))
    2680          (val nil))
    2681     (if (and base
    2682              (eq (x86::x86-register-operand-entry base)
    2683                  (if (x86-ds-mode-64 ds)
    2684                    (x86::x86-reg64 13)
    2685                    (x86::x86-reg32 x8632::fn)))
    2686              (null index)
    2687              (or (eql scale 0) (null scale))
    2688              (and (if (typep disp 'constant-x86-lap-expression)
    2689                     (+ (x86-ds-entry-point ds)
    2690                                   (constant-x86-lap-expression-value disp))
    2691                     (unless (typep disp 'x86-lap-expression)
    2692                       (setq val (if disp
    2693                                   (+ (x86-ds-entry-point ds)
    2694                                      disp)))))
    2695                   (>= val (x86-ds-code-limit ds))))
    2696       (let* ((diff (- val (x86-ds-code-limit ds)))
    2697              (constant (uvref (x86-ds-constants-vector ds)
    2698                               (1+ (ash diff (if (x86-ds-mode-64 ds)
    2699                                               (- x8664::word-shift)
    2700                                               (- x8632::word-shift)))))))
    2701         `(@ ',constant ,(unparse-x86-lap-operand base ds)))
    2702       (collect ((subforms))
    2703         (subforms '@)
    2704         (if seg
    2705           (subforms (unparse-x86-lap-operand seg ds)))
    2706         (if disp
    2707           (subforms (unparse-x86-lap-expression disp ds)))
    2708         (if base
    2709           (subforms (unparse-x86-lap-operand base ds)))
    2710         (if index
    2711           (subforms (unparse-x86-lap-operand index ds)))
    2712         (if (and scale (not (eql scale 0)))
    2713           (subforms (ash 1 scale)))
    2714         (subforms)))))
     2711  (multiple-value-bind (constant foundp) (x86-lap-operand-constant x ds)
     2712    (if foundp
     2713      `(@ ',constant ,(unparse-x86-lap-operand (x86::x86-memory-operand-base x) ds))
     2714      (let* ((seg (x86::x86-memory-operand-seg x))
     2715             (disp (x86::x86-memory-operand-disp x))
     2716             (base (x86::x86-memory-operand-base x))
     2717             (index (x86::x86-memory-operand-index x))
     2718             (scale (x86::x86-memory-operand-scale x)))
     2719        (collect ((subforms))
     2720          (subforms '@)
     2721          (if seg
     2722            (subforms (unparse-x86-lap-operand seg ds)))
     2723          (if disp
     2724            (subforms (unparse-x86-lap-expression disp ds)))
     2725          (if base
     2726            (subforms (unparse-x86-lap-operand base ds)))
     2727          (if index
     2728            (subforms (unparse-x86-lap-operand index ds)))
     2729          (if (and scale (not (eql scale 0)))
     2730            (subforms (ash 1 scale)))
     2731          (subforms))))))
    27152732   
    27162733(defmethod unparse-x86-lap-operand :around ((op x86::x86-operand)
     
    27222739      `(* ,usual)
    27232740      usual)))
     2741
     2742(defun write-x86-lap-operand (stream op ds)
     2743  ;; Basically, have to princ because some parts are already stringified,
     2744  ;; plus don't want package prefixes on assembler syntax.  But want to
     2745  ;; prin1 immediates.
     2746  (let ((expr (unparse-x86-lap-operand op ds)))
     2747    (format stream " ")
     2748    (labels ((out (stream expr)
     2749               (cond ((atom expr)
     2750                      (format stream "~a" expr))
     2751                     ((quoted-form-p expr)
     2752                      (format stream "'~s" (cadr expr)))
     2753                     (t
     2754                      (loop for item in expr as pre = "(" then " "
     2755                        do (format stream pre)
     2756                        do (out stream item))
     2757                      (format stream ")")))))
     2758      (out stream expr))))
    27242759
    27252760(defvar *previous-source-note*)
     
    27492784           (op2 (x86-di-op2 instruction)))
    27502785      (when op0
    2751         (format t " ~a" (unparse-x86-lap-operand op0 ds))
     2786        (write-x86-lap-operand t op0 ds)
    27522787        (when op1
    2753           (format t " ~a" (unparse-x86-lap-operand op1 ds))
     2788        (write-x86-lap-operand t op1 ds)
    27542789          (when op2
    2755             (format t " ~a" (unparse-x86-lap-operand op2 ds))))))
     2790            (write-x86-lap-operand t op2 ds)))))
    27562791    (format t ")")
    27572792    (format t "~%")
     
    27692804      (ensure-source-note-text source-note))))
    27702805
    2771 (defun x8664-disassemble-xfunction (function xfunction
    2772                                     &key (symbolic-names x8664::*x8664-symbolic-register-names*)
    2773                                          (collect-function #'x86-print-disassembled-instruction)
    2774                                          (header-function #'x86-print-disassembled-function-header))
     2806(defun x86-disassemble-xfunction (function xfunction
     2807                                  &key (symbolic-names #+x8664-target target::*x8664-symbolic-register-names*
     2808                                                       #+x8632-target target::*x8632-symbolic-register-names*)
     2809                                       (collect-function #'x86-print-disassembled-instruction)
     2810                                       (header-function #'x86-print-disassembled-function-header))
    27752811  (check-type xfunction xfunction)
    27762812  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
    2777   (let* ((ds (make-x86-disassembly-state
     2813  (let* ((entry-point  #+x8664-target 7  #+x8632-target 2)
     2814         (ds (make-x86-disassembly-state
     2815              :mode-64 #+x8664-target t #+x8632-target nil
    27782816              :code-vector (uvref xfunction 0)
    27792817              :constants-vector xfunction
    2780               :entry-point 7
    2781               :code-pointer 0           ; for next-u32 below
     2818              :entry-point entry-point
     2819              :code-pointer 0           ; for next-u32/next-u16 below
    27822820              :symbolic-names symbolic-names
    2783               :pending-labels (list 7)))
     2821              :pending-labels (list entry-point)))
    27842822         (blocks (x86-ds-blocks ds)))
    27852823    (setf (x86-ds-code-limit ds)
    2786           (ash (x86-ds-next-u32 ds) 3))
     2824          #+x8664-target (ash (x86-ds-next-u32 ds) 3)
     2825          #+x8632-target (ash (x86-ds-next-u16 ds) 2))
    27872826    (do* ()
    27882827         ((null (x86-ds-pending-labels ds)))
     
    27902829        (or (x86-dis-find-label lab blocks)
    27912830            (x86-disassemble-new-block ds lab))))
    2792     (when (and blocks (let ((something-to-disassemble nil))
    2793                         (do-dll-nodes (block blocks)
    2794                           (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2795                             (setf something-to-disassemble t)))
    2796                         something-to-disassemble))
     2831    (when (and header-function
     2832               blocks
     2833               (let ((something-to-disassemble nil))
     2834                 (do-dll-nodes (block blocks)
     2835                   (do-dll-nodes (instruction (x86-dis-block-instructions block))
     2836                     (setf something-to-disassemble t)))
     2837                 something-to-disassemble))
    27972838      (funcall header-function function xfunction))
    27982839    (let* ((seq 0)
     
    28032844          (setq seq (funcall collect-function ds instruction seq function)))))))
    28042845
    2805 (defun x8632-disassemble-xfunction (function xfunction
    2806                                     &key (symbolic-names x8632::*x8632-symbolic-register-names*)
    2807                                          (collect-function #'x86-print-disassembled-instruction)
    2808                                          (header-function #'x86-print-disassembled-function-header))
    2809   (check-type xfunction xfunction)
    2810   (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
    2811   (let* ((ds (make-x86-disassembly-state
    2812               :mode-64 nil
    2813               :code-vector (uvref xfunction 0)
    2814               :constants-vector xfunction
    2815               :entry-point 2
    2816               :code-pointer 0           ; for next-u16 below
    2817               :symbolic-names symbolic-names
    2818               :pending-labels (list 2)))
    2819          (blocks (x86-ds-blocks ds)))
    2820     (setf (x86-ds-code-limit ds) (ash (x86-ds-next-u16 ds) 2))
    2821     (do* ()
    2822          ((null (x86-ds-pending-labels ds)))
    2823       (let* ((lab (pop (x86-ds-pending-labels ds))))
    2824         (or (x86-dis-find-label lab blocks)
    2825             (x86-disassemble-new-block ds lab))))
    2826     (when (and blocks (let ((something-to-disassemble nil))
    2827                         (do-dll-nodes (block blocks)
    2828                           (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2829                             (setf something-to-disassemble t)))
    2830                         something-to-disassemble))
    2831       (funcall header-function function xfunction))
    2832     (let* ((seq 0)
    2833            (*previous-source-note* nil))
    2834       (declare (special *previous-source-note*))
    2835       (do-dll-nodes (block blocks)
    2836         (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2837           (setq seq (funcall collect-function ds instruction seq function)))))))
    2838 
    2839 #+x8664-target
    2840 (defun x8664-xdisassemble (function
    2841                            &optional (collect-function #'x86-print-disassembled-instruction)
    2842                                      (header-function #'x86-print-disassembled-function-header))
    2843   (let* ((fv (%function-to-function-vector function))
     2846(defun x86-xdisassemble (function
     2847                         &optional (collect-function #'x86-print-disassembled-instruction)
     2848                                   (header-function #'x86-print-disassembled-function-header))
     2849  (let* ((fv (function-to-function-vector function))
    28442850         (function-size-in-words (uvsize fv))
    28452851         (code-words (%function-code-words function))
    2846          (ncode-bytes (ash function-size-in-words x8664::word-shift))
     2852         (ncode-bytes (ash function-size-in-words target::word-shift))
    28472853         (code-bytes (make-array ncode-bytes
    28482854                                 :element-type '(unsigned-byte 8)))
     
    28552861          (j 1 (1+ j)))
    28562862         ((= k function-size-in-words)
    2857           (x8664-disassemble-xfunction function xfunction
    2858                                        :collect-function collect-function
    2859                                        :header-function header-function))
     2863          (x86-disassemble-xfunction function xfunction
     2864                                     :collect-function collect-function
     2865                                     :header-function header-function))
    28602866      (declare (fixnum j k))
    28612867      (setf (uvref xfunction j) (uvref fv k)))))
    28622868
    2863 #+x8632-target
    2864 (defun x8632-xdisassemble (function
    2865                            &optional (collect-function #'x86-print-disassembled-instruction)
    2866                                      (header-function #'x86-print-disassembled-function-header))
    2867   (let* ((fv (function-to-function-vector function))
    2868          (function-size-in-words (uvsize fv))
    2869          (code-words (%function-code-words function))
    2870          (ncode-bytes (ash function-size-in-words x8632::word-shift))
    2871          (code-bytes (make-array ncode-bytes
    2872                                  :element-type '(unsigned-byte 8)))
    2873          (numimms (- function-size-in-words code-words))
    2874          (xfunction (%alloc-misc (the fixnum (1+ numimms)) target::subtag-xfunction)))
    2875     (declare (fixnum code-words ncode-bytes numimms))
    2876     (%copy-ivector-to-ivector fv 0 code-bytes 0 ncode-bytes)
    2877     (setf (uvref xfunction 0) code-bytes)
    2878     (do* ((k code-words (1+ k))
    2879           (j 1 (1+ j)))
    2880          ((= k function-size-in-words)
    2881           (x8632-disassemble-xfunction function xfunction
    2882                                        :collect-function collect-function
    2883                                        :header-function header-function))
    2884       (declare (fixnum j k))
    2885       (setf (uvref xfunction j) (uvref fv k)))))
    2886 
    28872869(defun disassemble-list (function)
    28882870  (collect ((instructions))
    2889     (#+x8632-target x8632-xdisassemble #+x8664-target x8664-xdisassemble
     2871    (x86-xdisassemble
    28902872     function
    28912873     #'(lambda (ds instruction seq function)
     
    29132895                     (insn (unparse-x86-lap-operand op2 ds))  ))))
    29142896             (instructions (insn))
    2915              (1+ seq)))))
     2897             (1+ seq))))
     2898     nil)
    29162899    (instructions)))
    2917                          
    2918              
    2919 
    2920            
    2921          
    2922 
    2923                                      
    2924            
    2925      
    2926            
    2927              
  • trunk/source/compiler/X86/x862.lisp

    r12594 r12838  
    1013110131      (when disassemble
    1013210132        (format t "~%~%")
    10133         (apply #'x8664-disassemble-xfunction
     10133        (apply #'x86-disassemble-xfunction
    1013410134               xlfun
    1013510135               (unless symbolic-names (list nil))))
     
    1015310153        (let ((*target-backend* backend))
    1015410154          (format t "~%~%")
    10155           (apply #'x8632-disassemble-xfunction
     10155          (apply #'x86-disassemble-xfunction
    1015610156                 xlfun
    1015710157                 (unless symbolic-names (list nil)))))
  • trunk/source/lib/misc.lisp

    r12837 r12838  
    774774  disassemble."
    775775  (#+ppc-target ppc-xdisassemble
    776    #+x8632-target x8632-xdisassemble
    777    #+x8664-target x8664-xdisassemble
     776   #+x86-target x86-xdisassemble
    778777   (require-type (function-for-disassembly thing) 'compiled-function)))
    779778
Note: See TracChangeset for help on using the changeset viewer.