Changeset 16520


Ignore:
Timestamp:
Aug 31, 2015, 9:36:51 AM (4 years ago)
Author:
gb
Message:

changes to assembler/LAP/disassembler to better support assembling disssembler output.
new function (DISASSEMBLE-TO-FILE thing filespec) writes output generated by disassembling
the function designated by "thing" to a file denoted by "filespec", wrapping that output
im a DEFX86[32]LAPFUNCTION form so the output can be LOADed or compiled.

disassembler output suppresses printing of NOPs (can be enabled by
setting ccl:*x86-disassemble-print-nop* true) generates macro calls to
help enforce runtime/GC alignment constraints in many cases (though I
suspect that other cases may need similar treatment) and the relative
PC (shown in []) accounts for the function tag.

Location:
trunk/source/compiler/X86
Files:
4 edited

Legend:

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

    r16259 r16520  
    359359  rex-prefix             ; initial REX value
    360360  modrm-byte             ; initial modrm vale, may be nil if no modrm byte
     361  lap-options                           ; alist or plist
    361362  )
    362363
     
    912913     #xe8 nil nil)
    913914
     915   (def-x86-opcode (callq :cpu64) ((:label :insert-label))
     916     #xe8 nil nil)
     917   
    914918   (def-x86-opcode (call :cpu64) ((:reg64 :insert-modrm-rm))
     919     #xff #o320 #x0)
     920   (def-x86-opcode (callq :cpu64) ((:reg64 :insert-modrm-rm))
    915921     #xff #o320 #x0)
    916922   (def-x86-opcode (call :cpuno64) ((:reg32 :insert-modrm-rm))
     
    920926     #xff #o020 #x0)
    921927
     928   (def-x86-opcode (callq :cpu64) ((:anymem :insert-memory))
     929     #xff #o020 #x0)
    922930   ;; cbtw
    923931   (def-x86-opcode cbtw ()
     
    17311739   (def-x86-opcode leave ()
    17321740     #xc9 nil nil)
    1733 
     1741   (def-x86-opcode (leaveq :cpu64) ()
     1742     #xc9 nil nil)
     1743   (def-x86-opcode (leavel :cpu32) ()
     1744     #xc9 nil nil)
    17341745   ;; lock
    17351746   (def-x86-opcode lock ()
     
    22152226
    22162227   (def-x86-opcode ret ((:imm16 :insert-imm16))
     2228     #xc2 nil nil)
     2229
     2230   (def-x86-opcode (retq :cpu64) ()
     2231     #xc3 nil nil)
     2232
     2233   (def-x86-opcode (retq :cpu64) ((:imm16 :insert-imm16))
     2234     #xc2 nil nil)
     2235
     2236   (def-x86-opcode (retl :cpu32) ()
     2237     #xc3 nil nil)
     2238
     2239   (def-x86-opcode (retl :cpu32) ((:imm16 :insert-imm16))
    22172240     #xc2 nil nil)
    22182241
  • trunk/source/compiler/X86/x86-disassemble.lisp

    r15959 r16520  
    3434  start                                 ;start of instruction in code-vector
    3535  end                                   ;and its end
     36  flags
    3637  )
    3738
     
    10561057   (make-x86-dis "popU" 'op-e +v-mode+)
    10571058   ;; #x90
    1058    (make-x86-dis "nop" 'nop-fixup 0)
     1059   (make-x86-dis '("nop" . :nop) 'nop-fixup 0)
    10591060   (make-x86-dis "xchgS" 'op-reg +ecx-reg+ 'op-imreg +eax-reg+)
    10601061   (make-x86-dis "xchgS" 'op-reg +edx-reg+ 'op-imreg +eax-reg+)
     
    21132114
    21142115
    2115 (defun x86-putop (ds template sizeflag instruction)
     2116(defun x86-putop (ds template sizeflag instruction flags)
    21162117  (let* ((ok t))
    21172118    (when (consp template)
     
    21222123          (unless (lower-case-p (schar template i))
    21232124            (return nil)))
    2124       (setf (x86-di-mnemonic instruction) template)
     2125      (setf (x86-di-mnemonic instruction) template
     2126            (x86-di-flags instruction) flags)
    21252127      (let* ((string-buffer (x86-ds-string-buffer ds))
    21262128             (mod (x86-ds-mod ds))
     
    22512253  ok))
    22522254
    2253 (defparameter *x86-dissassemble-always-print-suffix* t)
     2255(defparameter *x86-disassemble-print-nop* nil)
     2256(defparameter *x86-disassemble-always-print-suffix* t)
    22542257
    22552258(defun x86-dis-do-float (ds instruction floatop sizeflag)
     
    24032406             (if (and (typep thing 'x86::x86-register-operand)
    24042407                      (x86-ds-mode-64 ds))
    2405                (let* ((entry (x86::x86-register-operand-entry thing)))
     2408              (let* ((entry (x86::x86-register-operand-entry thing)))
    24062409                 (eq entry (svref x86::*x8664-register-entries* 102)))))
    24072410           (is-ra0 (thing)
     
    24152418                  (null (x86::x86-memory-operand-base thing))
    24162419                  (null (x86::x86-memory-operand-index thing))
     2420                  (x86::x86-memory-operand-disp thing)))
     2421           (is-disp-and-base (thing)
     2422             (and (typep thing 'x86::x86-memory-operand)
     2423                  (x86::x86-memory-operand-base thing)
     2424                  (null (x86::x86-memory-operand-index thing))
    24172425                  (x86::x86-memory-operand-disp thing))))
     2426             
    24182427      (flet ((is-fn-ea (thing)
    24192428               (and (typep thing 'x86::x86-memory-operand)
     
    24852494                   
    24862495               (if (and (setq disp (is-rip-ea op0)) (< disp 0) (is-fn op1))
    2487                  (progn
    2488                    (setf (x86::x86-memory-operand-disp op0)
    2489                          (parse-x86-lap-expression `(:^ ,entry-ea)))
    2490                    (push entry-ea (x86-ds-pending-labels ds)))))))
     2496                 (setf (x86-di-mnemonic instruction) "recover-fn-from-rip"
     2497                       (x86-di-op0 instruction) nil
     2498                         (x86-di-op0 instruction) nil)))))
    24912499          ((:jump :call)
    24922500           (let* ((disp (is-disp-only op0)))
    2493              (when disp
     2501             (cond ( disp
    24942502               (let* ((info (find (early-x86-lap-expression-value disp)
    24952503                                  (if (x86-ds-mode-64 ds)
     
    24982506                                  :key #'subprimitive-info-offset)))
    24992507                 (when info (setf (x86::x86-memory-operand-disp op0)
    2500                                   (subprimitive-info-name info)))))))
     2508                                  (subprimitive-info-name info)
     2509                                 
     2510                                  (x86-di-mnemonic instruction)
     2511                                  (case flag
     2512                                    (:jump "lisp-jump")
     2513                                    (:call "lisp-call ")
     2514                                  )))))
     2515 
     2516               (t
     2517                (when (eq flag :call)
     2518                  (setf (x86-di-mnemonic instruction)
     2519                        "lisp-call")
     2520                  )))))
    25012521          (t
    2502            (let* ((jtab (is-jump-table-ref op0)))
     2522           (Let* ((jtab (is-jump-table-ref op0)))
    25032523             (if (and jtab (> jtab 0))
    25042524               (let* ((count (x86-ds-u32-ref ds (- jtab 4)))
     
    25422562  (let* ((addr (x86-ds-code-pointer ds))
    25432563         (sizeflag (logior +aflag+ +dflag+
    2544                            (if *x86-dissassemble-always-print-suffix*
     2564                           (if *x86-disassemble-always-print-suffix*
    25452565                             +suffix-always+
    25462566                             0)))
     
    26462666                                       (if (x86-ds-mode-64 ds) 1 0))))
    26472667                    (t (error "Disassembly error")))))
    2648           (when (x86-putop ds (x86-dis-mnemonic dp) sizeflag instruction)
     2668          (when (x86-putop ds (x86-dis-mnemonic dp) sizeflag instruction (x86-dis-flags dp))
    26492669            (let* ((operands ())
    26502670                   (op1 (x86-dis-op1 dp))
     
    28552875
    28562876(defun x86-print-di-lap (ds instruction tab-stop pc)
    2857   (dolist (p (x86-di-prefixes instruction))
    2858     (when tab-stop
    2859       (format t "~vt" tab-stop))
    2860     (format t "(~a)~%" p))
    2861   (when tab-stop
    2862     (format t "~vt" tab-stop))
    2863   (format t "(~a" (x86-di-mnemonic instruction))
    2864   (let* ((op0 (x86-di-op0 instruction))
    2865          (op1 (x86-di-op1 instruction))
    2866          (op2 (x86-di-op2 instruction)))
    2867     (when op0
    2868       (write-x86-lap-operand t op0 ds)
    2869       (when op1
    2870         (write-x86-lap-operand t op1 ds)
    2871         (when op2
    2872           (write-x86-lap-operand t op2 ds)))))
    28732877  (let ((comment-start-offset 40))
    2874     (format t ")~vt;~8<[~D]~>" (+ comment-start-offset tab-stop) pc)
     2878
     2879    (unless (and (eq :nop (x86-di-flags instruction)) (not *x86-disassemble-print-nop*))
     2880      (dolist (p (x86-di-prefixes instruction))
     2881        (when tab-stop
     2882          (format t "~vt" tab-stop))
     2883        (format t "(~a)~%" p))
     2884      (when tab-stop
     2885        (format t "~vt" tab-stop))
     2886      (format t "(~a" (x86-di-mnemonic instruction))
     2887      (let* ((op0 (x86-di-op0 instruction))
     2888             (op1 (x86-di-op1 instruction))
     2889             (op2 (x86-di-op2 instruction)))
     2890        (when op0
     2891          (write-x86-lap-operand t op0 ds)
     2892          (when op1
     2893            (write-x86-lap-operand t op1 ds)
     2894            (when op2
     2895              (write-x86-lap-operand t op2 ds)))))
     2896      (format t ")~vt;~8<[~D]~>" (+ comment-start-offset tab-stop) (+ pc #+x8664-target 15 #-x8664-target 7)))
    28752897    (when *disassemble-verbose*
    28762898      (let* ((istart (x86-di-start instruction))
     
    28802902             (byteidx istart))
    28812903        (dotimes (i (min nbytes 4))
     2904          (format t ";")
    28822905          (format t " ~(~2,'0x~)" (aref code-vector byteidx))
    28832906          (incf byteidx))
     
    30863109       nil))
    30873110    (coerce lines 'simple-vector)))
     3111
     3112(defun disassemble-to-file (function path)
     3113  (let* ((name (if (typep function 'symbol) function (function-name function)))
     3114         (header (if name (format nil "(~s ~s ()" (target-arch-case (:x8664 'defx86lapfunction)(:x8632 'defx86lapfunction))name) (error "Not yet: anonymous function"))))
     3115    (with-open-file (*standard-output* path :direction :output :if-exists :supersede)
     3116      (write-line header)
     3117      (disassemble function)
     3118      (write-line ")"))
     3119    path))
     3120
     3121
     3122
     3123
     3124
     3125
     3126
     3127(export  '(disassemble-to-file  *x86-disassemble-print-nop*))
     3128
     3129(provide "X86-DISASSEMBLE")
  • trunk/source/compiler/X86/x86-lap.lisp

    r16240 r16520  
    571571            (let* ((constant-label (ensure-x86-lap-constant-label val )))
    572572              (setq form `(:^ ,(x86-lap-label-name constant-label)))))))
     573     
    573574      (if (null form)
    574575        (setq form (arch::target-nil-value (backend-target-arch *target-backend*)))
     
    577578                (+ (arch::target-nil-value (backend-target-arch *target-backend*))
    578579                   (arch::target-t-offset  (backend-target-arch *target-backend*))))))
    579      
     580
     581      (progn
     582        (when (symbolp form)
     583          (multiple-value-bind (offset condition)
     584              (ignore-errors (subprim-name->offset form))
     585            (unless condition  (setq form offset)))))
    580586      (if (label-address-expression-p form)
    581587        (make-label-x86-lap-expression :label (find-or-create-x86-lap-label (cadr form)))
     
    587593                                                 :operand1 (parse-x86-lap-expression (cadr args))))
    588594              (t (make-n-ary-x86-lap-expression :operator op :operands (mapcar #'parse-x86-lap-expression args)))))
     595
     596         
    589597          (multiple-value-bind (value condition)
    590598              (ignore-errors
     
    592600                        form
    593601                        (cons (car form)
    594                             (mapcar #'(lambda (x)
    595                                         (if (typep x 'constant-x86-lap-expression)
    596                                           (constant-x86-lap-expression-value
    597                                            x)
    598                                           x))
    599                                     (cdr form))))))
     602                              (mapcar #'(lambda (x)
     603                                          (if (typep x 'constant-x86-lap-expression)
     604                                            (constant-x86-lap-expression-value
     605                                             x)
     606                                            x))
     607                                      (cdr form))))))
    600608            (if condition
    601609              (error "~a signaled during assembly-time evaluation of form ~s" condition form)
     
    15391547    (emit-x86-lap-label frag-list entry-code-tag)
    15401548
    1541     (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list)
     1549    (let* ((first (car forms)))
     1550      (when (eq (car first) 'let)
     1551        (let* ((form0 (caddr first)))
     1552          (when (and (consp form0) (symbolp (car form0)))
     1553       
     1554            (unless (equalp (string (car form0)) "recover-fn-from-rip")
     1555              (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list))))))
    15421556    (dolist (f forms)
    15431557      (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))
  • trunk/source/compiler/X86/x86-lapmacros.lisp

    r14956 r16520  
    478478  `(movl ($ :self) (% fn)))
    479479
     480
     481(defx86lapmacro lisp-call (arg)
     482  (target-arch-case
     483   (:x8632
     484    `(progn
     485       (:talign x8632::fulltag-tra)
     486       (call ,arg)))
     487   (:x8664
     488    `(progn
     489       (:talign 4)
     490       (call ,arg)))))
     491
     492(defx86lapmacro lisp-jump (arg)
     493  (target-arch-case
     494   (:x8632
     495    `(progn
     496       (:talign x8632::fulltag-tra)
     497       (jmp ,arg)))
     498   (:x8664
     499    `(progn
     500       (:talign 4)
     501       (jmp ,arg)))))
     502
    480503(defx86lapmacro call-subprim (name)
    481504  (target-arch-case
    482505   (:x8632
    483506    `(progn
    484        (:talign x8632::fulltag-tra)
    485        (call (@ ,(x86-subprim-offset name)))
     507       (lisp-call (@ ,(x86-subprim-offset name)))
    486508       (recover-fn)))
    487509   (:x8664
    488510    `(progn
    489        (:talign 4)
    490        (call (@ ,(x86-subprim-offset name)))
     511       (lisp-call (@ ,(x86-subprim-offset name)))
    491512       (recover-fn-from-rip)))))
     513
     514(defx86lapmacro jump-subprim (name)
     515  (target-arch-case
     516   (:x8632
     517    `(progn
     518       (lisp-jump (@ ,(x86-subprim-offset name)))
     519       (recover-fn)))
     520   (:x8664
     521    `(progn
     522       (lisp-jump (@ ,(x86-subprim-offset name)))
     523       (recover-fn-from-rip)))))
     524
    492525
    493526 (defx86lapmacro %car (src dest)
     
    542575   (:x8632
    543576    `(progn
    544        (load-constant ,name fname)
    545        (set-nargs ,nargs)
    546        (:talign 5)
    547        (call (@ x8632::symbol.fcell (% fname)))
    548        (recover-fn)))
    549    (:x8664
    550     `(progn
    551        (load-constant ,name fname)
    552        (set-nargs ,nargs)
    553        (:talign 4)
    554        (call (@ x8664::symbol.fcell (% fname)))
    555        (recover-fn-from-rip)))))
     577      (load-constant ,name fname)
     578      (set-nargs ,nargs)
     579      (lisp-call (@ x8632::symbol.fcell (% fname)))
     580       
     581      (recover-fn)))
     582   (:x8664
     583    `(progn
     584      (load-constant ,name fname)
     585      (set-nargs ,nargs)
     586      (lisp-call (@ x8664::symbol.fcell (% fname)))
     587      (recover-fn-from-rip)))))
    556588
    557589
Note: See TracChangeset for help on using the changeset viewer.