Changeset 16641


Ignore:
Timestamp:
Nov 21, 2015, 1:57:32 AM (6 years ago)
Author:
gb
Message:

x86-disassemble.lisp: tagged return addresses don't have anything to do with label alignment as
such, Try to otherwise recognize when labels are aligned, even if the NOPs that enforce alignment
are not shown because they are in unreachable code. un-botch the printing of the aligned PC when
*disassemble-verbose* is true. Try to show NOPs when *disassemble-verbose* is true (and we can find
the block that contains them.) If disassembling to a file, turn off *disassemble-verbose* and hide
NOPs.

There will likely be more disassembler changes soon.

nx0.lisp: if bailing out of the linear-scan backend (*FORCE-LEGACY-BACKEND* is true), don't turn
it back on again in DEFNXDECL OPTIMIZE.

vinsn.lisp: most of the infrastructure to remove trivial register-to-register copy instructions
is present but disabled. enabling it still causes some test failures.

x862.lisp: when emitting LAP, try to force labels used as branch targets to be aligned on 16 byte
boundaries. (some things may still invoke vinsns which try to do that) Try to ensure that
X862-COPY-REGISTER is used consistently instead of ! copy-gpr. Try to ensure that boxing fixnums
happens via shifts rather than imul, and recall that shifts modify their source operand. Some code
that tests a value in an FPR by comparing it to NIL can't have ever worked but now does something to
explicitlly clear the Z bit, which is a little better than what had been happening.

x8664-vinsns.lisp: support for the above

Location:
trunk/source/compiler
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/X8664/x8664-vinsns.lisp

    r16618 r16641  
    631631    (()
    632632     ())
    633   (leave))
     633  (movq (:%q x8664::rbp) (:%q x8664::rsp))
     634  (popq (:%q x8664::rbp))
     635  )
    634636
    635637(define-x8664-vinsn compare-to-nil (()
    636638                                    ((arg0 t)))
    637   (cmpb (:$b x8664::fulltag-nil) (:%b arg0)))
     639  (cmpq (:$l (target-nil-value)) (:%q arg0)))
    638640
    639641(define-x8664-vinsn compare-to-t (()
     
    15321534  (movq (:%q x8664::imm2) (:@ x8664::misc-data-offset (:%q bignum))))
    15331535 
     1536
    15341537                                                       
    15351538(define-x8664-vinsn box-fixnum (((dest :imm))
     
    15371540  (imulq (:$b x8664::fixnumone) (:%q src)(:%q dest)))
    15381541
     1542;;; don't modify src
     1543(define-x8664-vinsn box-fixnum-carefully (((dest :imm))
     1544                                          ((src :s8))
     1545                                          ((temp :s8)))
     1546  (movq (:%q src) (:%q temp))
     1547  (shlq (:$ub x8664::fixnumshift) (:%q temp))
     1548  (movq (:%q temp) (:%q dest)))
     1549
     1550(define-x8664-vinsn box-fixnum* (((dest :imm)
     1551                                  (src :s8))
     1552                                 
     1553                                 ((src :s8))
     1554                                         )
     1555  (shlq (:$ub x8664::fixnumshift) (:%q src))
     1556  (movq (:%q src) (:%q dest)))
    15391557
    15401558(define-x8664-vinsn (return-or-fix-overflow :jumpLR)(()
     
    20782096  (:long (:^ label)))
    20792097
     2098(define-x8664-vinsn (align-referenced-label :align) (()
     2099                                                 ((label :label)))
     2100  #+later
     2101  ((:pred plusp (:apply length (:apply vinsn-label-refs label)))
     2102   (:align 4)))
     2103 
     2104
     2105
    20802106;;; %ra0 is pointing into %fn, so no need to copy %fn here.
    20812107(define-x8664-vinsn (xpass-multiple-values-symbol :call  :extended-call :jumplr)
     
    20842110     ())                                                               
    20852111  (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::ret1valaddr))))
     2112  (:talign 4)
    20862113  (jmp (:@ x8664::symbol.fcell (:% x8664::fname)))
    20872114
     
    49014928  (testb (:%b x8664::arg_z) (:%b x8664::arg_z)))
    49024929
     4930(define-x8664-vinsn clr-eq-bit (()
     4931                                ()
     4932                                ((temp :u32)))
     4933  (xorl (:%l temp) (:%l temp))
     4934  (incl (:%l temp)))
     4935
    49034936(define-x8664-vinsn %schar8 (((char :imm))
    49044937                            ((str :lisp)
     
    51425175(define-x8664-vinsn align-loop-head (()
    51435176                                     ()
    5144                                      ()))
     5177                                     ())
     5178  (:align 4))
    51455179
    51465180(define-x8664-vinsn double-float-negate (((reg :double-float))
  • trunk/source/compiler/X86/x86-disassemble.lisp

    r16634 r16641  
    2323  (require "X86-LAP"))
    2424
    25 (defparameter *tra-tag* (target-arch-case (:x8664 4) (:x8632 5)))
     25(defparameter *tra-tag* (target-arch-case (:x8664 -4) (:x8632 -5)))
    2626
    2727(defstruct (x86-disassembled-instruction (:include dll-node)
     
    203203  end-address
    204204  (instructions (make-dll-header))
     205  (align nil)
    205206)
    206207
     
    684685    (x86::make-x86-immediate-operand :value (parse-x86-lap-expression op))))
    685686
     687
     688(defun x86-dis-align-address (ds address)
     689  (let* ((apc (+ address  (if (x86-ds-mode-64 ds) x8664::node-size  x8632::node-size))))
     690    (cond ((not (logtest 15 apc))
     691           4)
     692          ((not (logtest 7 apc))
     693           3)
     694          ((not (logtest 3 apc))
     695           2)
     696          ((not (logtest 1 apc))
     697           1))))
     698
    686699(defun op-j (ds bytemode sizeflag)
    687700  (let* ((mask -1)
     
    697710         (label-address (logand (+ (x86-ds-code-pointer ds) disp)
    698711                                mask)))
    699     (push label-address (x86-ds-pending-labels ds))
     712    (let* ((align (x86-dis-align-address ds label-address)))
     713      (if align
     714        (push (cons label-address align) (x86-ds-pending-labels ds))
     715       
     716        (push label-address (x86-ds-pending-labels ds))))
    700717    (x86::make-x86-label-operand :label label-address)))
    701718
     
    24732490                            `(- (:^ ,label-ea))
    24742491                            `(:^ ,label-ea))))
    2475                    (push (cons label-ea (if (eq flag :lea) *tra-tag*)) (x86-ds-pending-labels ds))
     2492                   (push label-ea (x86-ds-pending-labels ds))
    24762493                   (when (or (eq flag :single) (eq flag :double))
    24772494                     (let* ((block (make-x86-dis-block :start-address label-ea
     
    25192536 
    25202537               (t
    2521                 (when (eq flag :call)
     2538                (if (eq flag :call)
    25222539                  (setf (x86-di-mnemonic instruction)
    25232540                        "lisp-call")
     2541                 
    25242542                  )))))
    25252543          (t
     
    25462564                     (append-dll-node instruction instructions)
    25472565                     (setq labeled nil)
    2548                      (push (cons target *tra-tag*) (x86-ds-pending-labels ds))
     2566                     (push target (x86-ds-pending-labels ds))
    25492567                     (incf jtab 4)))
    25502568                 (insert-x86-block block (x86-ds-blocks ds)))
     
    27072725                  (when (> (x86-dis-block-start-address b) addr)
    27082726                    (return (x86-dis-block-start-address b)))))
    2709          (block (make-x86-dis-block :start-address addr))
     2727         (block (make-x86-dis-block  :start-address addr ))
    27102728         (instructions (x86-dis-block-instructions block))
    27112729         (labeled (not (eql addr (x86-ds-entry-point ds)))))
     
    28822900        (apc (+ pc  (if (x86-ds-mode-64 ds) x8664::fulltag-function x8632::fulltag-misc))))
    28832901
    2884     (unless (and (eq :nop (x86-di-flags instruction)) (not *x86-disassemble-print-nop*))
     2902    (unless (and (eq :nop (x86-di-flags instruction))
     2903                 (not *x86-disassemble-print-nop*)
     2904                 (not *disassemble-verbose*))
     2905     
    28852906      (dolist (p (x86-di-prefixes instruction))
    28862907        (when tab-stop
     
    29122933         (nbytes (- iend istart))
    29132934         (code-vector (x86-ds-code-vector ds))
    2914          (byteidx istart)
    2915          (apc (+ pc  (if (x86-ds-mode-64 ds) x8664::fulltag-function x8632::fulltag-misc))))
    2916     (format t "~5@d/~d: " pc apc)
     2935         (byteidx istart))
     2936    (format t "~5@d: " pc)
    29172937    (dotimes (i (min nbytes 4))
    29182938      (format t "~(~2,'0x~) " (aref code-vector byteidx))
     
    29492969                       "#<no source text>")))
    29502970          (format t "~&~%;;; ~A" text))))
    2951     (when labeled
    2952       (when align (format t "~&~%~4t(:align ~d)" align))
     2971    (when labeled
     2972      (when (and align (> align 0))
     2973          (format t "~&~%~vt(:align ~d)" (if *disassemble-verbose* 20 4) align))
    29532974      (format t "~&L~d~%" pc)
    29542975      (setq seq 0))
     
    29742995            (when source-text
    29752996              (format t ";;; ~A" (string-sans-most-whitespace source-text 100))))))))
     2997
     2998;;; find blocks of code that are unreferenced but which may affect alignment of successors,
     2999(defun x86-disassemble-find-alignment-blocks (ds)
     3000  (declare (ignorable ds))
     3001  #+later
     3002  (let* ((blocks (x86-ds-blocks ds)))
     3003    (do-dll-nodes (b blocks)
     3004      (format t "~&~d ~d"(x86-dis-block-start-address b) (x86-dis-block-end-address b)))
     3005   
     3006    (break())))
    29763007
    29773008(defun x86-disassemble-xfunction (function xfunction
     
    30163047           (*previous-source-note* nil))
    30173048      (declare (special *previous-source-note*))
     3049      (when *disassemble-verbose*
     3050        (x86-disassemble-find-alignment-blocks ds))
    30183051      (do-dll-nodes (block blocks)
    30193052        (do-dll-nodes (instruction (x86-dis-block-instructions block))
     
    31413174(defun disassemble-to-file (function path)
    31423175  (let* ((name (if (typep function 'symbol) function (function-name function)))
     3176         (*disassemble-verbose* nil)
     3177         (*x86-disassemble-print-nop* nil)
    31433178         (header (if name (format nil "(~s ~s ()" (target-arch-case (:x8664 'defx86lapfunction)(:x8632 'defx86lapfunction))name) (error "Not yet: anonymous function"))))
    31443179    (with-open-file (*standard-output* path :direction :output :if-exists :supersede)
  • trunk/source/compiler/X86/x862.lisp

    r16638 r16641  
    753753           (*x862-emitted-source-notes* '())
    754754           (*x862-gpr-locations-valid-mask* 0)
    755            ;; OK to use regmap when not using new allocator
    756755           (*x862-track-gpr-locations* (not *backend-use-linear-scan*))
    757756           (*x862-gpr-locations* (make-array 16 :initial-element nil))
     
    13181317                   (reg (?)))
    13191318              (cond ((= nargs 3)
    1320                      (! copy-gpr reg ($ x8664::arg_x)))
     1319                     (x862-copy-register seg reg ($ x8664::arg_x)))
    13211320                   
    13221321                    ((= nargs 2)
    1323                      (! copy-gpr reg  ($ x8664::arg_y)))
     1322                     (x862-copy-register seg reg  ($ x8664::arg_y)))
    13241323               
    13251324   
    13261325                    ((= nargs 1)
    1327                      (! copy-gpr reg ($ x8664::arg_z))))
     1326                     (x862-copy-register seg reg ($ x8664::arg_z))))
    13281327              (setf (var-lreg var) reg)))
    13291328          ;(x862-seq-bind seg (car auxen) (cadr auxen))
     
    13581357             (! reserve-spill-area)
    13591358             (! save-nfp)
    1360              (@ (setq *x862-fixed-self-tail-call-label* (backend-get-next-label)))
     1359             (setq *x862-fixed-self-tail-call-label* (backend-get-next-label))
     1360             (! align-referenced-label (aref *backend-labels* *x862-fixed-self-tail-call-label*))
     1361             (@ *x862-fixed-self-tail-call-label*)
    13611362             
    13621363             (do* ((nargs (length args) (1- nargs)))
     
    13681369             
    13691370                 (cond ((= nargs 4)               
    1370                         (! copy-gpr reg ($ x8664::arg_w)))
     1371                        (x862-copy-register seg reg ($ x8664::arg_w)))
    13711372                         
    13721373                       ((= nargs 3)
    1373                         (! copy-gpr reg ($ x8664::arg_x)))
     1374                        (x862-copy-register seg reg ($ x8664::arg_x)))
    13741375
    13751376                       ((= nargs 2)
    1376                         (! copy-gpr reg  ($ x8664::arg_y)))
     1377                        (x862-copy-register seg reg  ($ x8664::arg_y)))
    13771378
    13781379                       ((= nargs 1)
    1379                         (! copy-gpr reg ($ x8664::arg_z))))
     1380                        (x862-copy-register seg reg ($ x8664::arg_z))))
    13801381                 (push var *x862-tail-arg-vars*)
    13811382                 (setf (var-lreg var) reg)
     
    16821683      (unless (and regno (eql regno other))
    16831684        (cond (other
    1684                (let* ((vinsn (! copy-gpr reg other)))
     1685               (let* ((vinsn (x862-copy-register seg reg other)))
    16851686                 (unless *backend-use-linear-scan*
    16861687                   (setq *x862-gpr-locations-valid-mask*
     
    18421843              )))))
    18431844
     1845(defun x862-box-fixnum (seg node-dest imm-src)
     1846  (with-x86-local-vinsn-macros (seg)
     1847    (target-arch-case
     1848     (:x8632 (! box-fixnum node-dest imm-src))
     1849     (:x8664 (if (and *backend-use-linear-scan* (typep imm-src 'lreg) (cdr (lreg-refs imm-src)))
     1850                (! box-fixnum-carefully node-dest imm-src)
     1851                (! box-fixnum* node-dest imm-src ))))))
     1852                   
     1853 
    18441854(defun x862-box-s32 (seg node-dest s32-src)
    18451855  (with-x86-local-vinsn-macros (seg)
     
    18521862        (x862-copy-register seg node-dest arg_z)))
    18531863     (:x8664
    1854       (! box-fixnum node-dest s32-src)))))
     1864      (x862-box-fixnum seg node-dest s32-src)))))
    18551865
    18561866(defun x862-box-s64 (seg node-dest s64-src)
     
    18581868    (if (target-arch-case
    18591869         (:x8632 (error "bug"))
    1860          (:x8664 *x862-open-code-inline*))
     1870         (:x8664 (or *backend-use-linear-scan* *x862-open-code-inline*)))
    18611871      (let* ((no-overflow (backend-get-next-label)))
    18621872        (! %set-z-flag-if-s64-fits-in-fixnum node-dest s64-src)
     
    18651875        (! %allocate-uvector node-dest)
    18661876        (! set-bigits-after-fixnum-overflow node-dest)
    1867         (@ no-overflow))
     1877        (@ no-overflow)))
    18681878      (let* ((arg_z ($ *x862-arg-z*))
    18691879             (imm0 (make-wired-lreg *x862-imm0* :mode (get-regspec-mode s64-src))))
    18701880        (x862-copy-register seg imm0 s64-src)
    18711881        (! call-subprim (subprim-name->offset '.SPmakes64))
    1872         (x862-copy-register seg node-dest arg_z)))))
     1882        (x862-copy-register seg node-dest arg_z))))
    18731883
    18741884(defun x862-box-u32 (seg node-dest u32-src)
     
    18821892        (x862-copy-register seg node-dest arg_z)))
    18831893     (:x8664
    1884       (! box-fixnum node-dest u32-src)))))
     1894      (x862-box-fixnum seg node-dest u32-src)))))
    18851895
    18861896(defun x862-box-u64 (seg node-dest u64-src)
     
    20662076                 (x862-copy-register seg vreg temp)
    20672077                 (ensuring-node-target (target vreg)
    2068                    (! box-fixnum target temp))))))
     2078                   (x862-box-fixnum seg target temp))))))
    20692079          (is-16-bit
    20702080           (with-imm-target () temp
     
    20822092                     (! misc-ref-s16 temp src idx-reg)
    20832093                     (! misc-ref-u16 temp src idx-reg))))
    2084                (! box-fixnum target temp))))
     2094               (x862-box-fixnum seg target temp))))
    20852095          ;; Down to the dregs.
    20862096          (is-64-bit
     
    21232133                      (! misc-ref-s64 s64-reg src unscaled-idx)))
    21242134                  (if (eq type-keyword :fixnum-vector)
    2125                     (! box-fixnum target s64-reg)
     2135                    (x862-box-fixnum seg target s64-reg)
    21262136                    (x862-box-s64 seg target s64-reg)))))
    21272137             (t
     
    38373847
    38383848(defun x862-one-untargeted-lreg-form (seg form reg)
    3839   (cond (*backend-use-linear-scan*
    3840          (let* ((var (nx2-lexical-reference-p form))
    3841                 (lreg (if var (var-lreg var))))
    3842            (or
    3843                (and lreg
    3844                     (eql (hard-regspec-class lreg) (hard-regspec-class reg))
    3845                     (eql (get-regspec-mode lreg) (get-regspec-mode reg))
    3846                     lreg))
    3847            (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg)))))
    3848         (t
    3849          (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))))
     3849  (if *backend-use-linear-scan*
     3850 (x862-one-lreg-form seg form (if (and (typep reg 'lreg) (not (lreg-wired reg))) reg (make-unwired-lreg-like reg)))
     3851    (x862-one-lreg-form seg form reg)))
    38503852
    38513853;;; If REG is a node reg, add it to the bitmask.
     
    39994001                                    hard-reg-class-fpr)
    40004002                              (x862-copy-fpr seg popped-reg pushed-reg)
    4001                               (! copy-gpr popped-reg pushed-reg))))
     4003                              (x862-copy-register seg popped-reg pushed-reg))))
    40024004                 (remove-dll-node copy)
    40034005                 (if pushed-reg-is-set
     
    40684070                                   (vinsn-in-sequence-p pushed-reg-is-set popped-reg-is-reffed pop-vinsn)))
    40694071                          (unless same-reg
    4070                             (let* ((copy (! copy-gpr popped-reg pushed-reg)))
     4072                            (let* ((copy (x862-copy-register seg popped-reg pushed-reg)))
    40714073                              (remove-dll-node copy)
    40724074                              (if (not pushed-reg-is-set)
     
    49274929               (src-gpr (if src (if (eql (hard-regspec-class src) hard-reg-class-gpr) src)))
    49284930               (dest-fpr (if (eql (hard-regspec-class dest) hard-reg-class-fpr) dest))
    4929                (src-fpr (if src (if (eql (hard-regspec-class src) hard-reg-class-fpr) dest)))
     4931               (src-fpr (if src (if (eql (hard-regspec-class src) hard-reg-class-fpr) src)))
    49304932               (src-mode (if src (get-regspec-mode src)))
    49314933               (dest-mode (get-regspec-mode dest))
     
    49364938              (if dest-crf
    49374939                (! set-eq-bit)))
    4938             (if (and dest-crf src-gpr)
     4940            (if (and dest-crf )
     4941              (if src-gpr
    49394942              ;; "Copying" a GPR to a CR field means comparing it to rnil
    4940               (! compare-to-nil src)
     4943                (! compare-to-nil src)
     4944                (! clr-eq-bit)) 
    49414945              (if (and dest-gpr src-gpr)
    49424946                (if (eq src-mode dest-mode)
     
    49594963                          (x862-box-s32 seg dest src))
    49604964                         (#.hard-reg-class-gpr-mode-u16
    4961                           (! box-fixnum dest src))
     4965                          (x862-box-fixnum seg dest src))
    49624966                         (#.hard-reg-class-gpr-mode-s16
    4963                           (! box-fixnum dest src))
     4967                          (x862-box-fixnum seg dest src))
    49644968                         (#.hard-reg-class-gpr-mode-u8
    4965                           (! box-fixnum dest src))
     4969                          (x862-box-fixnum seg dest src))
    49664970                         (#.hard-reg-class-gpr-mode-s8
    4967                           (! box-fixnum dest src))
     4971                          (x862-box-fixnum seg dest src))
    49684972                         (#.hard-reg-class-gpr-mode-address
    49694973                          (x862-macptr->heap seg dest src))))
     
    49774981                              (#.hard-reg-class-gpr-mode-u32
    49784982                               (! unbox-u32 dest src))
    4979                               (#.hard-reg-class-gpr-mode-address
     4983                              (#.hard-reg-class-gpr-mode-address 
    49804984                               (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
    49814985                                           *x862-reckless*)
     
    50655069                          (x862-box-s32 seg dest src))
    50665070                         (#.hard-reg-class-gpr-mode-u16
    5067                           (! box-fixnum dest src))
     5071                          (x862-box-fixnum seg dest src))
    50685072                         (#.hard-reg-class-gpr-mode-s16
    5069                           (! box-fixnum dest src))
     5073                          (x862-box-fixnum seg dest src))
    50705074                         (#.hard-reg-class-gpr-mode-u8
    5071                           (! box-fixnum dest src))
     5075                          (x862-box-fixnum seg dest src))
    50725076                         (#.hard-reg-class-gpr-mode-s8
    5073                           (! box-fixnum dest src))
     5077                          (x862-box-fixnum seg dest src))
    50745078                         (#.hard-reg-class-gpr-mode-address
    50755079                          (x862-macptr->heap seg dest src))))
     
    52435247                                (! copy-single-to-double dest src)))))))))))))))))
    52445248
    5245 #||
    5246 (defun x862-copy-register (seg dest src)
    5247   (with-x86-local-vinsn-macros (seg)
    5248     (when dest
    5249       (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
    5250              (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
    5251              (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
    5252              (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
    5253              (src-mode (if src (get-regspec-mode src)))
    5254              (dest-mode (get-regspec-mode dest))
    5255              (src-class (if src (hard-regspec-class src)))
    5256              (dest-class (hard-regspec-class dest))
    5257              (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
    5258         (if (null src)
    5259           (if dest-gpr
    5260             (! load-nil dest-gpr)
    5261             (if dest-crf
    5262               (! set-eq-bit)))
    5263           (if (and dest-crf src-gpr)
    5264             ;; "Copying" a GPR to a CR field means comparing it to rnil
    5265             (! compare-to-nil src)
    5266             (if (and (eql src-class dest-class)
    5267                      (eql src-mode dest-mode))
    5268               (if (eql src-class hard-reg-class-gpr)
    5269                 (unless (eq src dest)
    5270                   (! copy-gpr dest src))
    5271                 ;; This is the "GPR <- GPR" case.  There are
    5272                 ;; word-size dependencies, but there's also
    5273                 ;; lots of redundancy here.
    5274                 (target-arch-case
    5275                  (:x8632
    5276                   (ecase dest-mode
    5277                     (#.hard-reg-class-gpr-mode-node ; boxed result.
    5278                      (case src-mode
    5279                        (#.hard-reg-class-gpr-mode-node
    5280                         (unless (eql  dest-gpr src-gpr)
    5281                           (! copy-gpr dest src)))
    5282                        (#.hard-reg-class-gpr-mode-u32
    5283                         (x862-box-u32 seg dest src))
    5284                        (#.hard-reg-class-gpr-mode-s32
    5285                         (x862-box-s32 seg dest src))
    5286                        (#.hard-reg-class-gpr-mode-u16
    5287                         (! box-fixnum dest src))
    5288                        (#.hard-reg-class-gpr-mode-s16
    5289                         (! box-fixnum dest src))
    5290                        (#.hard-reg-class-gpr-mode-u8
    5291                         (! box-fixnum dest src))
    5292                        (#.hard-reg-class-gpr-mode-s8
    5293                         (! box-fixnum dest src))
    5294                        (#.hard-reg-class-gpr-mode-address
    5295                         (x862-macptr->heap seg dest src))))
    5296                     ((#.hard-reg-class-gpr-mode-u32
    5297                       #.hard-reg-class-gpr-mode-address)
    5298                      (case src-mode
    5299                        (#.hard-reg-class-gpr-mode-node
    5300                         (let* ((src-type (get-node-regspec-type-modes src)))
    5301                           (declare (fixnum src-type))
    5302                           (case dest-mode
    5303                             (#.hard-reg-class-gpr-mode-u32
    5304                              (! unbox-u32 dest src))
    5305                             (#.hard-reg-class-gpr-mode-address
    5306                              (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
    5307                                          *x862-reckless*)
    5308                                (! trap-unless-macptr src))
    5309                              (! deref-macptr dest src)))))
    5310                        ((#.hard-reg-class-gpr-mode-u32
    5311                          #.hard-reg-class-gpr-mode-s32
    5312                          #.hard-reg-class-gpr-mode-address)
    5313                         (unless (eql  dest-gpr src-gpr)
    5314                           (! copy-gpr dest src)))
    5315                        (#.hard-reg-class-gpr-mode-u16
    5316                         (! u16->u32 dest src))                 
    5317                        (#.hard-reg-class-gpr-mode-s16
    5318                         (! s16->s32 dest src))
    5319                        (#.hard-reg-class-gpr-mode-u8
    5320                         (! u8->u32 dest src))
    5321                        (#.hard-reg-class-gpr-mode-s8
    5322                         (! s8->s32 dest src))))
    5323                     (#.hard-reg-class-gpr-mode-s32
    5324                      (case src-mode
    5325                        (#.hard-reg-class-gpr-mode-node
    5326                         (! unbox-s32 dest src))
    5327                        ((#.hard-reg-class-gpr-mode-u32
    5328                          #.hard-reg-class-gpr-mode-s32
    5329                          #.hard-reg-class-gpr-mode-address)
    5330                         (unless (eql  dest-gpr src-gpr)
    5331                           (! copy-gpr dest src)))
    5332                        (#.hard-reg-class-gpr-mode-u16
    5333                         (! u16->u32 dest src))                 
    5334                        (#.hard-reg-class-gpr-mode-s16
    5335                         (! s16->s32 dest src))
    5336                        (#.hard-reg-class-gpr-mode-u8
    5337                         (! u8->u32 dest src))
    5338                        (#.hard-reg-class-gpr-mode-s8
    5339                         (! s8->s32 dest src))))
    5340                     (#.hard-reg-class-gpr-mode-u16
    5341                      (case src-mode
    5342                        (#.hard-reg-class-gpr-mode-node
    5343                         (! unbox-u16 dest src))
    5344                        ((#.hard-reg-class-gpr-mode-u8
    5345                          #.hard-reg-class-gpr-mode-s8)
    5346                         (! u8->u32 dest src))
    5347                        (t
    5348                         (unless (eql dest-gpr src-gpr)
    5349                           (! copy-gpr dest src)))))
    5350                     (#.hard-reg-class-gpr-mode-s16
    5351                      (case src-mode
    5352                        (#.hard-reg-class-gpr-mode-node
    5353                         (! unbox-s16 dest src))
    5354                        (#.hard-reg-class-gpr-mode-s8
    5355                         (! s8->s32 dest src))
    5356                        (#.hard-reg-class-gpr-mode-u8
    5357                         (! u8->u32 dest src))
    5358                        (t
    5359                         (unless (eql dest-gpr src-gpr)
    5360                           (! copy-gpr dest src)))))
    5361                     (#.hard-reg-class-gpr-mode-u8
    5362                      (case src-mode
    5363                        (#.hard-reg-class-gpr-mode-node
    5364                         (if *x862-reckless*
    5365                           (! %unbox-u8 dest src)
    5366                           (! unbox-u8 dest src)))
    5367                        (t
    5368                         (unless (eql dest-gpr src-gpr)
    5369                           (! copy-gpr dest src)))))
    5370                     (#.hard-reg-class-gpr-mode-s8
    5371                      (case src-mode
    5372                        (#.hard-reg-class-gpr-mode-node
    5373                         (! unbox-s8 dest src))
    5374                        (t
    5375                         (unless (eql dest-gpr src-gpr)
    5376                           (! copy-gpr dest src)))))))
    5377                  (:x8664
    5378                   (ecase dest-mode
    5379                     (#.hard-reg-class-gpr-mode-node ; boxed result.
    5380                      (case src-mode
    5381                        (#.hard-reg-class-gpr-mode-node
    5382                         (unless (eql  dest-gpr src-gpr)
    5383                           (! copy-gpr dest src)))
    5384                        (#.hard-reg-class-gpr-mode-u64
    5385                         (x862-box-u64 seg dest src))
    5386                        (#.hard-reg-class-gpr-mode-s64
    5387                         (x862-box-s64 seg dest src))
    5388                        (#.hard-reg-class-gpr-mode-u32
    5389                         (x862-box-u32 seg dest src))
    5390                        (#.hard-reg-class-gpr-mode-s32
    5391                         (x862-box-s32 seg dest src))
    5392                        (#.hard-reg-class-gpr-mode-u16
    5393                         (! box-fixnum dest src))
    5394                        (#.hard-reg-class-gpr-mode-s16
    5395                         (! box-fixnum dest src))
    5396                        (#.hard-reg-class-gpr-mode-u8
    5397                         (! box-fixnum dest src))
    5398                        (#.hard-reg-class-gpr-mode-s8
    5399                         (! box-fixnum dest src))
    5400                        (#.hard-reg-class-gpr-mode-address
    5401                         (x862-macptr->heap seg dest src))))
    5402                     ((#.hard-reg-class-gpr-mode-u64
    5403                       #.hard-reg-class-gpr-mode-address)
    5404                      (case src-mode
    5405                        (#.hard-reg-class-gpr-mode-node
    5406                         (let* ((src-type (get-node-regspec-type-modes src)))
    5407                           (declare (fixnum src-type))
    5408                           (case dest-mode
    5409                             (#.hard-reg-class-gpr-mode-u64
    5410                              (! unbox-u64 dest src))
    5411                             (#.hard-reg-class-gpr-mode-address
    5412                              (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
    5413                                          *x862-reckless*)
    5414                                (! trap-unless-macptr src))
    5415                              (! deref-macptr dest src)))))
    5416                        ((#.hard-reg-class-gpr-mode-u64
    5417                          #.hard-reg-class-gpr-mode-s64
    5418                          #.hard-reg-class-gpr-mode-address)
    5419                         (unless (eql  dest-gpr src-gpr)
    5420                           (! copy-gpr dest src)))
    5421                        ((#.hard-reg-class-gpr-mode-u16
    5422                          #.hard-reg-class-gpr-mode-s16)
    5423                         (! u16->u32 dest src))
    5424                        ((#.hard-reg-class-gpr-mode-u8
    5425                          #.hard-reg-class-gpr-mode-s8)
    5426                         (! u8->u32 dest src))))
    5427                     (#.hard-reg-class-gpr-mode-s64
    5428                      (case src-mode
    5429                        (#.hard-reg-class-gpr-mode-node
    5430                         (! unbox-s64 dest src))
    5431                        ((#.hard-reg-class-gpr-mode-u64
    5432                          #.hard-reg-class-gpr-mode-s64
    5433                          #.hard-reg-class-gpr-mode-address)
    5434                         (unless (eql  dest-gpr src-gpr)
    5435                           (! copy-gpr dest src)))
    5436                        ((#.hard-reg-class-gpr-mode-u16
    5437                          #.hard-reg-class-gpr-mode-s16)
    5438                         (! s16->s32 dest src))
    5439                        ((#.hard-reg-class-gpr-mode-u8
    5440                          #.hard-reg-class-gpr-mode-s8)
    5441                         (! s8->s32 dest src))))
    5442                     (#.hard-reg-class-gpr-mode-s32
    5443                      (case src-mode
    5444                        (#.hard-reg-class-gpr-mode-node
    5445                         (! unbox-s32 dest src))
    5446                        ((#.hard-reg-class-gpr-mode-u32
    5447                          #.hard-reg-class-gpr-mode-s32
    5448                          #.hard-reg-class-gpr-mode-address)
    5449                         (unless (eql  dest-gpr src-gpr)
    5450                           (! copy-gpr dest src)))
    5451                        (#.hard-reg-class-gpr-mode-u16
    5452                         (! u16->u32 dest src))                 
    5453                        (#.hard-reg-class-gpr-mode-s16
    5454                         (! s16->s32 dest src))
    5455                        (#.hard-reg-class-gpr-mode-u8
    5456                         (! u8->u32 dest src))
    5457                        (#.hard-reg-class-gpr-mode-s8
    5458                         (! s8->s32 dest src))))
    5459                     (#.hard-reg-class-gpr-mode-u32
    5460                      (case src-mode
    5461                        (#.hard-reg-class-gpr-mode-node
    5462                         (if *x862-reckless*
    5463                           (! %unbox-u32 dest src)
    5464                           (! unbox-u32 dest src)))
    5465                        ((#.hard-reg-class-gpr-mode-u32
    5466                          #.hard-reg-class-gpr-mode-s32)
    5467                         (unless (eql  dest-gpr src-gpr)
    5468                           (! copy-gpr dest src)))
    5469                        (#.hard-reg-class-gpr-mode-u16
    5470                         (! u16->u32 dest src))                 
    5471                        (#.hard-reg-class-gpr-mode-s16
    5472                         (! s16->s32 dest src))
    5473                        (#.hard-reg-class-gpr-mode-u8
    5474                         (! u8->u32 dest src))
    5475                        (#.hard-reg-class-gpr-mode-s8
    5476                         (! s8->s32 dest src))))
    5477                     (#.hard-reg-class-gpr-mode-u16
    5478                      (case src-mode
    5479                        (#.hard-reg-class-gpr-mode-node
    5480                         (if *x862-reckless*
    5481                           (! %unbox-u16 dest src)
    5482                           (! unbox-u16 dest src)))
    5483                        ((#.hard-reg-class-gpr-mode-u8
    5484                          #.hard-reg-class-gpr-mode-s8)
    5485                         (! u8->u32 dest src))
    5486                        (t
    5487                         (unless (eql dest-gpr src-gpr)
    5488                           (! copy-gpr dest src)))))
    5489                     (#.hard-reg-class-gpr-mode-s16
    5490                      (case src-mode
    5491                        (#.hard-reg-class-gpr-mode-node
    5492                         (! unbox-s16 dest src))
    5493                        (#.hard-reg-class-gpr-mode-s8
    5494                         (! s8->s32 dest src))
    5495                        (#.hard-reg-class-gpr-mode-u8
    5496                         (! u8->u32 dest src))
    5497                        (t
    5498                         (unless (eql dest-gpr src-gpr)
    5499                           (! copy-gpr dest src)))))
    5500                     (#.hard-reg-class-gpr-mode-u8
    5501                      (case src-mode
    5502                        (#.hard-reg-class-gpr-mode-node
    5503                         (if *x862-reckless*
    5504                           (! %unbox-u8 dest src)
    5505                           (! unbox-u8 dest src)))
    5506                        (t
    5507                         (unless (eql dest-gpr src-gpr)
    5508                           (! copy-gpr dest src)))))
    5509                     (#.hard-reg-class-gpr-mode-s8
    5510                      (case src-mode
    5511                        (#.hard-reg-class-gpr-mode-node
    5512                         (! unbox-s8 dest src))
    5513                        (t
    5514                         (unless (eql dest-gpr src-gpr)
    5515                           (! copy-gpr dest src)))))))))
    5516               (if src-gpr
    5517                 (if dest-fpr
    5518                   (progn
    5519                     (case src-mode
    5520                       (#.hard-reg-class-gpr-mode-node
    5521                        (case dest-mode
    5522                          (#.hard-reg-class-fpr-mode-double
    5523                           (unless (or (logbitp hard-reg-class-fpr-type-double
    5524                                            (get-node-regspec-type-modes src))
    5525                                       *x862-reckless*)
    5526                             (! trap-unless-double-float src))
    5527                           (! get-double dest src))
    5528                          (#.hard-reg-class-fpr-mode-single
    5529                           (unless *x862-reckless* (! trap-unless-single-float src))
    5530                           (! get-single dest src))
    5531                          (#.hard-reg-class-fpr-mode-complex-single-float
    5532                           (unless *x862-reckless* (! trap-unless-complex-single-float src))
    5533                           (! get-complex-single-float dest src))
    5534                          (#.hard-reg-class-fpr-mode-complex-double-float
    5535                           (unless *x862-reckless* (! trap-unless-complex-double-float src))
    5536                           (! get-complex-double-float dest src)))))))
    5537                 (if dest-gpr
    5538                   (case dest-mode
    5539                     (#.hard-reg-class-gpr-mode-node
    5540                      (case src-mode
    5541                        (#.hard-reg-class-fpr-mode-double
    5542                         (x862-double->heap seg dest src))
    5543                        (#.hard-reg-class-fpr-mode-complex-double-float
    5544                         (x862-complex-double-float->heap seg dest src))
    5545                        (#.hard-reg-class-fpr-mode-complex-single-float
    5546                         (x862-complex-single-float->heap seg dest src))
    5547                        (#.hard-reg-class-fpr-mode-single
    5548                         (target-arch-case
    5549                          (:x8632
    5550                           (x862-single->heap seg dest src))
    5551                          (:x8664
    5552                           (! single->node dest src)))))))
    5553                   (if (and src-fpr dest-fpr)
    5554                     (unless (and (eql src-mode dest-mode)
    5555                                  (eql (hard-regspec-value src)
    5556                                       (hard-regspec-value dest)))
    5557                       (if (eql src-mode dest-mode)
    5558                         (case (fpr-mode-value-name src-mode)
    5559                           (:single-float (! copy-single-float dest src))
    5560                           (:double-float (! copy-double-float dest src))
    5561                           (:complex-single-float
    5562                            (! copy-complex-single-float dest src))
    5563                           (:complex-double-float
    5564                            (! copy-complex-double-float dest src)))
    5565                         (if (and (eql src-mode hard-reg-class-fpr-mode-double)
    5566                                  (eql dest-mode hard-reg-class-fpr-mode-single))
    5567                           (! copy-double-to-single dest src)
    5568                           (if (and (eql dest-mode hard-reg-class-fpr-mode-double)
    5569                                    (eql src-mode hard-reg-class-fpr-mode-single))
    5570                             (! copy-single-to-double dest src)))))))))))))))
    5571 
    5572 ||#
     5249
    55735250 
    55745251(defun x862-unreachable-store (&optional vreg)
     
    72086885    (do-dll-nodes (v header)
    72096886      (if (%vinsn-label-p v)
    7210         (let* ((id (vinsn-label-id v)))
    7211           (if (or (typep id 'fixnum) (null id))
    7212             (when (or t (vinsn-label-refs v) (null id))
    7213               (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))))
     6887        (progn
     6888          (let* ((align (dolist (ref (vinsn-label-refs v))
     6889                          (when (and *backend-use-linear-scan* (vinsn-attribute-p ref :jump :branch))
     6890                           
     6891                            (return 4)))))
     6892
     6893            (when align
     6894
     6895              (x86-lap-directive  frag-list :align align)
     6896
     6897              ))
     6898                         
     6899          (let* ((id (vinsn-label-id v)))
     6900            (if (or (typep id 'fixnum) (null id))
     6901              (when (or t (vinsn-label-refs v) (null id))
     6902                (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v))))))
    72146903        (x862-expand-vinsn v frag-list instruction immediate-operand uuo-frag-list)))
    72156904    (when uuo-frag-list
     
    82257914              (progn
    82267915                (! %ilsl src count src)
    8227                 (! copy-gpr target src))
     7916                (x862-copy-register seg target src))
    82287917              (! %ilsl target count src))))))
    82297918      (^))))
     
    96359324              (progn
    96369325                (! %iasr src cnt src)
    9637                 (! copy-gpr target src))
     9326                (x862-copy-register seg target src))
    96389327              (! %iasr target cnt src))))))
    96399328      (^))))
     
    96579346              (progn
    96589347                (! %ilsr src cnt src)
    9659                 (! copy-gpr target src))
     9348                (x862-copy-register seg target src))
    96609349              (! %ilsr target cnt src)))))
    96619350      (^))))
     
    100849773                          (:x8664 (! mem-ref-doubleword dest src-reg offset-reg))))))))
    100859774                (if (node-reg-p vreg)
    10086                   (! box-fixnum vreg dest)
     9775                  (x862-box-fixnum seg vreg dest)
    100879776                  (<- dest))))
    100889777             (signed
     
    101249813                (if (node-reg-p vreg)
    101259814                  (case size
    10126                     ((1 2) (! box-fixnum vreg dest))
     9815                    ((1 2) (x862-box-fixnum seg vreg dest))
    101279816                    (4 (target-arch-case
    101289817                        (:x8632 (<- dest))
    10129                         (:x8664 (! box-fixnum vreg dest))))
     9818                        (:x8664 (x862-box-fixnum seg vreg dest))))
    101309819                    (8 (<- dest)))
    101319820                  (<- dest))))
     
    1178911478                (if (and (typep constant *nx-target-fixnum-type*)
    1179011479                         (node-reg-p vreg))
    11791                   (! box-fixnum vreg other-reg)
     11480                  (x862-box-fixnum seg vreg other-reg)
    1179211481                  (<- other-reg)))))
    1179311482          (^))))))
  • trunk/source/compiler/nx0.lisp

    r16628 r16641  
    12911291          (push (cons q v) mdecls)
    12921292          (if (eq q 'stack-access)
    1293             (when *nx-parsing-lambda-decls* (target-arch-case (:x8664 (setq *backend-use-linear-scan* (not (eql v 0))))))
     1293            (when (and *nx-parsing-lambda-decls* (not *force-legacy-backend*)) (target-arch-case (:x8664 (setq *backend-use-linear-scan* (not (eql v 0))))))
    12941294            (nx-bad-decls spec)))))))
    12951295
  • trunk/source/compiler/vinsn.lisp

    r16623 r16641  
    2323
    2424(defparameter *linear-scan-verbose* nil)
     25
    2526
    2627(defun ls-format (&rest args )
     
    110111  refs                                  ; vinsns in which this label appears as an operand
    111112  info                                  ; code-generation stuff
    112 )
     113) 
    113114)
    114115(defstruct (vinsn-list (:include dll-header)
     
    10601061  (regtype 0)
    10611062  (preg nll)
    1062   (avail 0)                             ; available regs before we assigned preg
     1063  (avail 0 :type fixnum)                             ; available regs before we assigned preg
    10631064  idx
    10641065  parent
     
    10681069  (flags 0 :type fixnum)
    10691070  (use-positions () :type list) ; sequence numbers of lreg-refs and defs
    1070  
     1071  (active-before () :type list)
     1072  (active-after () :type list)
     1073  (trivial-def nil)
     1074  (non-trivial-conflicts () :type list)
     1075  (alt-preg 0 :type (unsigned-byte 4))
     1076  (conflicts-with () :type list)
    10711077)
    10721078
     
    10741080(defmethod print-object ((i interval) stream)
    10751081  (print-unreadable-object (i stream :type t)
    1076     (format stream "~d:(~d) ~s ~s/~s ~s (~s)" (interval-idx i) (interval-flags i) (interval-lreg i) (interval-begin i) (interval-end i) (interval-regtype i) (interval-preg i))))
     1082    (format stream "~c ~d:(~d) ~s ~s/~s ~s (~s)" (if (interval-trivial-def i) #\? #\space )(interval-idx i) (interval-flags i) (interval-lreg i) (interval-begin i) (interval-end i) (interval-regtype i) (interval-preg i))))
    10771083
    10781084
     
    15031509            (setf (svref v i) new)))))))
    15041510
     1511
    15051512(defun expire-interval (seg interval)
    15061513  (let* ((avail (vinsn-list-available-physical-registers seg))
     
    15281535          (end (interval-end interval)))
    15291536    (declare (ignorable start end))
     1537    (when lreg
     1538      (let* ((defs (lreg-defs lreg)))
     1539        (when (and defs (null (cdr defs)) (vinsn-attribute-p (car defs) :trivial-copy))
     1540          (setf (interval-trivial-def interval) (car defs)))))
    15301541    (when (and lreg preg)
    15311542      (if (eql 0 (interval-flags interval))
     
    15521563       
    15531564
    1554 
     1565(defun pregs-used-in-intervals (intervals)
     1566  (let* ((mask 0))
     1567    (declare (fixnum mask))
     1568    (dolist (interval intervals mask)
     1569      (let* ((preg (interval-preg interval)))
     1570        (declare (type (mod 16) preg))
     1571        (setq mask (logior mask (ash 1 preg)))))))
    15551572
    15561573
     
    15791596        (declare (type (vector t) intervals))
    15801597        (let* ((active (make-dll-header))
    1581                (unhandled (make-dll-header)
    1582 )              ;;(expired (make-dll-header))
     1598               (unhandled (make-dll-header))
     1599               ;;(expired (make-dll-header))
    15831600               (limit (vinsn-list-max-seq seg)))
    15841601          (assign-interval-indices intervals)
     
    15891606                (begin (if i (interval-begin I) limit) (if i (interval-begin I) limit)))
    15901607               ((= begin limit) (progn (do-dll-nodes (a active ) (expire-interval seg a )) t   ))
    1591             ;;(ls-format  "~&i=~s" i)
     1608            (ls-format  "~&i=~s" i)
    15921609
    15931610
     
    15981615                  (expire-interval seg other ))))
    15991616
     1617           
    16001618            (if (null (interval-lreg i))
    16011619              (let* ((caller-save ())
     
    16121630                         
    16131631                )
    1614            
     1632              (progn
     1633                (do-dll-nodes (live active)
     1634                  (when (eql (interval-regtype i) (interval-regtype live))
     1635                    (push live (interval-active-before i))
     1636                    (push i (interval-active-after live))))
    16151637              (let* ((regtype (interval-regtype i))
    16161638                     (mask (svref avail regtype))
     
    17081730                    (use-reg preg regtype i)
    17091731                    (setf (interval-preg i) preg)
    1710                     (append-dll-node i active)))))))))))
     1732                    (append-dll-node i active))))))))))))
    17111733
    17121734;;; we don't need to do nearly as much of this as we have been doing.
     
    18121834(defstatic *linear-scan-won* 0)
    18131835(defstatic *linear-scan-lost* 0)
     1836(defparameter *report-linear-scan-success* nil)
    18141837
    18151838
    18161839(defun linear-scan-bailout (&optional (reason "generic failure" reason-p))
    18171840  (when *backend-use-linear-scan*
    1818     (when (and reason-p *linear-scan-verbose*)
     1841    (when (and reason-p *report-linear-scan-success*)
    18191842      (format *error-output* "~%~%bailing-out of linear-scan for ~a :~&~&~a" *current-function-name* reason ))
    18201843    (incf *linear-scan-lost*)
     
    18561879            (return)))))))
    18571880
    1858 (defparameter *report-linear-scan-success* t)
    1859 
    1860 ;; see postprocess-interal; this assumes that all trivial-copy operands
     1881
     1882
     1883;;; Intervals X and Y overlap if X begins before Y ends
     1884;;; and X ends after Y begins.  If two intervals overlap,
     1885;;; they can't use the same physical register.
     1886;;; "intervals" is a vector ordered by start address. and we
     1887;;; might be able to avoid linear search here by doing
     1888;;; two binary searches of two ordered vectors.
     1889(defun find-conflicting-intervals (interval preg)
     1890  (declare (type (unsigned-byte 4) preg))
     1891  (let* ((conflicts ()))
     1892    (dolist (after (interval-active-after interval) conflicts)
     1893      (when (eql preg (interval-preg after))
     1894        (push after conflicts)))))
     1895
     1896(defun other-pregs-for-conflicting-interval (i other-mask)
     1897  (declare (fixnum other-mask))
     1898  (let* ((mask (interval-avail i)))
     1899    (declare (fixnum mask))
     1900    (dolist (after (interval-active-after i) (logandc2 mask other-mask))
     1901      (setq mask (logand mask (interval-avail after))))))
     1902
     1903
     1904(defun pregs-used-before (interval)
     1905  (let* ((mask 0))
     1906    (declare (fixnum mask))
     1907    (dolist (before (interval-active-before interval) mask)
     1908      (let* ((preg (interval-preg before)))
     1909        (setq mask (logior (ash 1 preg) mask))))))
     1910
     1911 
     1912     
     1913
     1914
     1915(defun rebuild-avail-before (seg)
     1916  (let* ((intervals (vinsn-list-intervals seg)))
     1917    (declare (type (vector t) intervals))
     1918    (dovector (i intervals)
     1919      (when (interval-lreg i)
     1920         
     1921        (let* ((avail (svref (vinsn-list-available-physical-registers seg) (interval-regtype i)))
     1922               (used (pregs-used-before i)))
     1923          (declare (fixnum avail used))
     1924          (setf (interval-avail i) (logandc2 avail used)))))))
     1925
     1926
     1927;;; Choose another physical register for interval
     1928               
     1929(defun resolve-interval-conflict (interval)
     1930  (let* ((mask 0))
     1931    (declare (fixnum mask))
     1932    (dolist (other (interval-conflicts-with interval))
     1933      (setq mask (logior mask (ash 1 (interval-preg other)))))
     1934    (block resolve
     1935      (let* ((avail (logandc2 (interval-avail interval) mask)))
     1936        (declare (fixnum avail))
     1937        (do* (( i 16 (1- i)))
     1938             ((< i 0))
     1939          (declare (fixnum i))
     1940          (let* ((preg (1- i)))
     1941            (declare (type (integer 0 15) preg))
     1942            (when (and (logbitp preg avail)
     1943                       (not (find-conflicting-intervals interval preg)))
     1944              (let* ((lreg (interval-lreg interval)))
     1945                (setf (lreg-value lreg) preg
     1946                      (interval-preg interval) preg))
     1947            (return-from resolve preg))))))))
     1948
     1949
     1950
     1951                                           
     1952(defun nullify-trivial-copy (vinsn resolve)
     1953  (when (vinsn-attribute-p vinsn :trivial-copy)
     1954    (let* ((vp (vinsn-variable-parts vinsn))
     1955           (dest (svref vp 0))
     1956           (src (svref vp 1)))
     1957      ;; if both src and dest are lregs, dest
     1958      ;; is not fixed, and doing so would not
     1959      ;; introduce any conflicts throughout
     1960      ;; the lifetime of dest, make the copy
     1961      ;; a nop and change uses of dest to use
     1962      ;; src directly
     1963      ;; we are considering changing uses
     1964      ;; of "dest" to use the same preg
     1965      ;; as "src" does.  some other interval(s)
     1966      ;; which did not conflict with "dest"
     1967      ;; during register allocation may do
     1968      ;; so now (if we back out of the copy)
     1969      ;; if we find any such conflicting
     1970      ;; intervals (which try to use the preg
     1971      ;; from the src interval. change the
     1972      ;; conflicting interval to use another
     1973      ;; preg if we can.
     1974      (when (and (typep src 'lreg)
     1975                 (typep dest 'lreg))
     1976        (let* ((src-interval (lreg-interval src))
     1977               (dest-interval (lreg-interval dest))
     1978               (src-preg (interval-preg src-interval))
     1979               (dest-preg (interval-preg dest-interval)))
     1980          (declare (type (unsigned-byte 4) src-preg dest-preg))
     1981          (when (and resolve (interval-non-trivial-conflicts dest-interval))
     1982            (dolist (conflict (interval-non-trivial-conflicts dest-interval) )
     1983              (resolve-interval-conflict conflict)
     1984              (setf (interval-conflicts-with conflict) nil)))
     1985          (unless (or (eql src-preg dest-preg)
     1986                      (lreg-local-p dest)
     1987                      (lreg-wired dest))
     1988
     1989            (when (not resolve)
     1990              (dolist (i (find-conflicting-intervals dest-interval src-preg))
     1991                (unless (or (eq i src-interval) (interval-trivial-def i))
     1992                  (push dest-interval (interval-conflicts-with i))
     1993                  (push i (interval-non-trivial-conflicts  dest-interval)))))
     1994            (setf (interval-preg dest-interval)src-preg
     1995                  (lreg-value dest) src-preg
     1996                  (svref vp 0) src)
     1997            t))))))
     1998
     1999(defparameter *remove-trivial-copies* nil)
     2000
     2001;; see postprocess-interval; this assumes that all trivial-copy operands
    18612002;; are lregs.
    18622003(defun remove-trivial-copies (seg)
    18632004  (declare (ignorable seg))
    1864   #+notyet
    1865   (let* ((regs (vinsn-list-lregs seg))
    1866          (nregs (length regs)))
    1867     (declare (type (vector t) regs) (fixnum nregs))
    1868    
    1869     (dolist (n (vinsn-list-flow-graph seg))
    1870       (let* ((kill (fgn-live-kill n))
    1871              (live-out(fgn-live-out n))
    1872              (triv ()))
    1873         (declare (simple-bit-vector kill live-out))
    1874         (dotimes (i nregs)
    1875           (when (and (eql 1 (sbit kill i))
    1876                      (eql 0 (sbit live-out i)))
    1877             (let* ((reg (aref regs i)))
    1878               (let* ((defs (lreg-defs reg)))
    1879                 (unless (cdr defs)
    1880                   (let ((def (car defs)))
    1881                     (when (vinsn-attribute-p def :trivial-copy)
    1882                       (push reg triv))))))))
    1883         (setq triv (sort triv #'< :key (lambda (r) (vinsn-sequence (car (lreg-defs r))))))
    1884         (dolist (r triv)
    1885           (let* ((def (car (lreg-defs r)))
    1886                  (vp (vinsn-variable-parts def) )
    1887                  (src (svref vp 1))
    1888                  (dest (svref vp 0)))
    1889             (when (and (typep src 'lreg)
    1890                        (typep dest 'lreg))
    1891               (unless (and (lreg-wired src)
    1892                            (lreg-wired dest))
    1893                 (break)))))))))
     2005  (when *remove-trivial-copies*
     2006    (let* ((intervals (vinsn-list-intervals seg)))
     2007      (declare (type (vector t) intervals))
     2008      (dovector (i intervals)
     2009        (when (interval-lreg i)
     2010          (setf (interval-alt-preg i) (interval-preg i))
     2011          (unless (and (logbitp (interval-preg i) (interval-avail i))
     2012                       (dolist (after (interval-active-after i) t)
     2013                         (when (logbitp (interval-preg i) (interval-avail after))
     2014                           
     2015                           (return nil)))))))
     2016     
     2017                                                                 
     2018
     2019    (rebuild-avail-before seg)
     2020    (dolist (block (vinsn-list-flow-graph seg))
     2021      (do-tail-dll-nodes (v block)
     2022        (when (vinsn-attribute-p v :trivial-copy)
     2023
     2024          (nullify-trivial-copy v nil))))
     2025    (rebuild-avail-before seg)
     2026    (dolist (block (vinsn-list-flow-graph seg))
     2027      (do-tail-dll-nodes (v block)
     2028        (when (vinsn-attribute-p v :trivial-copy)
     2029          (nullify-trivial-copy v t))))
     2030 
     2031    )))
    18942032
    18952033
     
    19432081             (remove-trivial-copies header)
    19442082             (when *report-linear-scan-success*
    1945                (ls-format  "~&;; Won on ~a" *current-function-name*))
     2083               (format *debug-io*  "~&;; Won on ~a" *current-function-name*))
    19462084             (incf *linear-scan-won*)
    19472085             (resolve-split-intervals header)
Note: See TracChangeset for help on using the changeset viewer.