Changeset 11392
- Timestamp:
- Nov 18, 2008, 8:24:19 PM (12 years ago)
- File:
-
- 1 edited
-
trunk/source/compiler/PPC/ppc2.lisp (modified) (21 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/compiler/PPC/ppc2.lisp
r11383 r11392 177 177 178 178 (defvar *ppc2-result-reg* ppc::arg_z) 179 180 (defvar *ppc2-nvrs* `(,ppc::save0 ,ppc::save1 ,ppc::save2 ,ppc::save3 181 ,ppc::save4 ,ppc::save5 ,ppc::save6 ,ppc::save7)) 179 182 180 183 … … 657 660 658 661 659 (defun %ppc2-bigger-cdr-than (x y) 660 (declare (cons x y)) 661 (> (the fixnum (cdr x)) (the fixnum (cdr y)))) 662 663 ;;; Return an unordered list of "varsets": each var in a varset can be 664 ;;; assigned a register and all vars in a varset can be assigned the 665 ;;; same register (e.g., no scope conflicts.) 666 667 (defun ppc2-partition-vars (vars) 668 (labels ((var-weight (var) 669 (let* ((bits (nx-var-bits var))) 670 (declare (fixnum bits)) 671 (if (eql 0 (logand bits (logior 672 (ash 1 $vbitpuntable) 673 (ash -1 $vbitspecial) 674 (ash 1 $vbitnoreg)))) 675 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq)) 676 (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq)))) 677 0 678 (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits)))) 679 0))) 680 (sum-weights (varlist) 681 (let ((sum 0)) 682 (dolist (v varlist sum) (incf sum (var-weight v))))) 683 (vars-disjoint-p (v1 v2) 684 (if (eq v1 v2) 685 nil 686 (if (memq v1 (var-binding-info v2)) 687 nil 688 (if (memq v2 (var-binding-info v1)) 689 nil 690 t))))) 691 (setq vars (%sort-list-no-key 692 ;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars) 693 (do* ((handle (cons nil vars)) 694 (splice handle)) 695 ((null (cdr splice)) (cdr handle)) 696 (declare (dynamic-extent handle) (type cons handle splice)) 697 (if (eql 0 (var-weight (%car (cdr splice)))) 698 (rplacd splice (%cdr (cdr splice))) 699 (setq splice (cdr splice)))) 700 #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2))))) 701 ; This isn't optimal. It partitions all register-allocatable variables into sets such that 702 ; 1) no variable is a member of more than one set and 703 ; 2) all variables in a given set are disjoint from each other 704 ; A set might have exactly one member. 705 ; If a register is allocated for any member of a set, it's allocated for all members of that 706 ; set. 707 (let* ((varsets nil)) 708 (do* ((all vars (cdr all))) 709 ((null all)) 710 (let* ((var (car all))) 711 (when (dolist (already varsets t) 712 (when (memq var (car already)) (return))) 713 (let* ((varset (cons var nil))) 714 (dolist (v (cdr all)) 715 (when (dolist (already varsets t) 716 (when (memq v (car already)) (return))) 717 (when (dolist (d varset t) 718 (unless (vars-disjoint-p v d) (return))) 719 (push v varset)))) 720 (let* ((weight (sum-weights varset))) 721 (declare (fixnum weight)) 722 (if (>= weight 3) 723 (push (cons (nreverse varset) weight) varsets))))))) 724 varsets))) 725 726 ;;; Maybe globally allocate registers to symbols naming functions & variables, 727 ;;; and to simple lexical variables. 728 (defun ppc2-allocate-global-registers (fcells vcells all-vars no-regs) 729 (if no-regs 730 (progn 731 (dolist (c fcells) (%rplacd c nil)) 732 (dolist (c vcells) (%rplacd c nil)) 733 (values 0 nil)) 734 (let* ((maybe (ppc2-partition-vars all-vars))) 735 (dolist (c fcells) 736 (if (>= (the fixnum (cdr c)) 3) (push c maybe))) 737 (dolist (c vcells) 738 (if (>= (the fixnum (cdr c)) 3) (push c maybe))) 739 (do* ((things (%sort-list-no-key maybe #'%ppc2-bigger-cdr-than) (cdr things)) 740 (n 0 (1+ n)) 741 (regno ppc::save0 (1- regno)) 742 (constant-alist ())) 743 ((or (null things) (= n $numppcsaveregs)) 744 (dolist (cell fcells) (%rplacd cell nil)) 745 (dolist (cell vcells) (%rplacd cell nil)) 746 (values n constant-alist)) 747 (declare (list things) 748 (fixnum n regno)) 749 (let* ((thing (car things))) 750 (if (or (memq thing fcells) 751 (memq thing vcells)) 752 (push (cons thing regno) constant-alist) 753 (dolist (var (car thing)) 754 (nx-set-var-bits var 755 (%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var)) 756 regno 757 (%ilsl $vbitreg 1)))))))))) 662 663 664 758 665 759 666 … … 805 712 (ppc2-set-var-ea seg arg (var-ea arg)) 806 713 (let* ((lcell (pop lcells))) 807 (if (setq reg (ppc2-assign-register-var arg)) 808 (ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc)) 714 (if (setq reg (nx2-assign-register-var arg)) 715 (progn 716 (break "Inherited var in NVR: ~s/~s" arg (var-name arg)) 717 (ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc))) 809 718 (ppc2-bind-var seg arg vloc lcell)) 810 719 (setq vloc (%i+ vloc *ppc2-target-node-size*))))) … … 813 722 (ppc2-set-var-ea seg arg (var-ea arg)) 814 723 (let* ((lcell (pop lcells))) 815 (if (setq reg ( ppc2-assign-register-var arg))724 (if (setq reg (nx2-assign-register-var arg)) 816 725 (ppc2-init-regvar seg arg reg (ppc2-vloc-ea vloc)) 817 726 (ppc2-bind-var seg arg vloc lcell)) … … 826 735 (ppc2-set-var-ea seg var (var-ea var)) 827 736 (let* ((lcell (pop lcells))) 828 (if (setq reg ( ppc2-assign-register-var var))737 (if (setq reg (nx2-assign-register-var var)) 829 738 (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) 830 739 (ppc2-bind-var seg var vloc lcell)) … … 833 742 (if lexpr 834 743 (progn 835 (if (setq reg ( ppc2-assign-register-var rest))744 (if (setq reg (nx2-assign-register-var rest)) 836 745 (progn 837 746 (ppc2-load-lexpr-address seg reg) … … 844 753 (ppc2-bind-var seg rest loc *ppc2-top-vstack-lcell*))))) 845 754 (let* ((rvloc (+ vloc (* 2 *ppc2-target-node-size* nkeys)))) 846 (if (setq reg ( ppc2-assign-register-var rest))755 (if (setq reg (nx2-assign-register-var rest)) 847 756 (ppc2-init-regvar seg rest reg (ppc2-vloc-ea rvloc)) 848 757 (ppc2-bind-var seg rest rvloc (pop lcells)))))) … … 858 767 (lcell (pop lcells)) 859 768 (splcell (pop splcells)) 860 (reg ( ppc2-assign-register-var var))769 (reg (nx2-assign-register-var var)) 861 770 (sp-reg ($ ppc::arg_z)) 862 771 (regloadedlabel (if reg (backend-get-next-label)))) … … 876 785 (ppc2-bind-var seg var vloc lcell)) 877 786 (when spvar 878 (if (setq reg ( ppc2-assign-register-var spvar))787 (if (setq reg (nx2-assign-register-var spvar)) 879 788 (ppc2-init-regvar seg spvar reg (ppc2-vloc-ea spvloc)) 880 789 (ppc2-bind-var seg spvar spvloc splcell)))) … … 888 797 (let* ((spvar (pop keysupp)) 889 798 (initform (pop keyinits)) 890 (reg ( ppc2-assign-register-var var))799 (reg (nx2-assign-register-var var)) 891 800 (regloadedlabel (if reg (backend-get-next-label))) 892 801 (var-lcell (pop lcells)) … … 909 818 (ppc2-bind-var seg var vloc var-lcell)) 910 819 (when spvar 911 (if (setq reg ( ppc2-assign-register-var spvar))820 (if (setq reg (nx2-assign-register-var spvar)) 912 821 (ppc2-init-regvar seg spvar reg (ppc2-vloc-ea sploc)) 913 822 (ppc2-bind-var seg spvar sploc sp-lcell)))) … … 918 827 (defun ppc2-vpush-arg-register (seg reg var) 919 828 (when var 920 (let* ((bits (nx-var-bits var))) 921 (declare (fixnum bits)) 922 (if (logbitp $vbitreg bits) 923 var 924 (progn 925 (ppc2-vpush-register seg reg :reserved) 926 nil))))) 829 (if (var-nvr var) 830 var 831 (progn 832 (ppc2-vpush-register seg reg :reserved) 833 nil)))) 927 834 928 835 … … 1248 1155 (with-ppc-local-vinsn-macros (seg) 1249 1156 (! set-nargs n)))) 1250 1251 (defun ppc2-assign-register-var (v)1252 (let ((bits (nx-var-bits v)))1253 (when (%ilogbitp $vbitreg bits)1254 (%ilogand bits $vrefmask))))1255 1157 1256 1158 (defun ppc2-single-float-bits (the-sf) … … 2271 2173 value result-reg)) 2272 2174 (t 2273 ( setq result-reg (ppc2-target-reg-for-aset vreg type-keyword))2274 (ppc2-three-targeted-reg-forms seg2175 (multiple-value-setq (src unscaled-idx result-reg) 2176 (ppc2-three-untargeted-reg-forms seg 2275 2177 vector src 2276 2178 index unscaled-idx 2277 value result-reg)))2179 value (ppc2-target-reg-for-aset vreg type-keyword))))) 2278 2180 (when safe 2279 2181 (let* ((*available-backend-imm-temps* *available-backend-imm-temps*) … … 2856 2758 (defun ppc2-acc-reg-for (reg) 2857 2759 (with-ppc-local-vinsn-macros (seg) 2858 (let* ((class (hard-regspec-class reg)) 2859 (mode (get-regspec-mode reg))) 2860 (declare (fixnum class mode)) 2861 (cond ((= class hard-reg-class-fpr) 2862 (make-wired-lreg ppc::fp1 :class class :mode mode)) 2863 ((= class hard-reg-class-gpr) 2864 (if (= mode hard-reg-class-gpr-mode-node) 2865 ($ ppc::arg_z) 2866 (make-wired-lreg ppc::imm0 :mode mode))) 2867 (t (compiler-bug "Unknown register class for reg ~s" reg)))))) 2760 (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr) 2761 (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node)) 2762 ($ ppc::arg_z) 2763 reg))) 2868 2764 2869 2765 ;;; The compiler often generates superfluous pushes & pops. Try to … … 3859 3755 (progn 3860 3756 (let* ((vloc *ppc2-vstack*) 3861 (reg (let* ((r ( ppc2-assign-register-var var)))3757 (reg (let* ((r (nx2-assign-register-var var))) 3862 3758 (if r ($ r))))) 3863 3759 (if (ppc2-load-ea-p val) … … 4958 4854 (defun ppc2-bind-structured-var (seg var vloc lcell &optional context) 4959 4855 (if (not (ppc2-structured-var-p var)) 4960 (let* ((reg ( ppc2-assign-register-var var)))4856 (let* ((reg (nx2-assign-register-var var))) 4961 4857 (if reg 4962 4858 (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) … … 5366 5262 (setq no-regs (%ilogbitp $fbitnoregs fbits))) 5367 5263 (multiple-value-setq (pregs reglocatives) 5368 ( ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs))5264 (nx2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) inherited-vars (unless no-regs *ppc2-nvrs*))) 5369 5265 (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 5370 5266 (when keys ;; Ensure keyvect is the first immediate … … 5507 5403 (let* ((var (car vars))) 5508 5404 (when var 5509 (let* ((reg ( ppc2-assign-register-var var)))5405 (let* ((reg (nx2-assign-register-var var))) 5510 5406 (ppc2-copy-register seg reg arg-reg-num) 5511 5407 (setf (var-ea var) reg)))))) … … 6911 6807 (dolist (var vars) 6912 6808 (let* ((lcell (pop lcells)) 6913 (reg ( ppc2-assign-register-var var)))6809 (reg (nx2-assign-register-var var))) 6914 6810 (if reg 6915 6811 (ppc2-init-regvar seg var reg (ppc2-vloc-ea vloc)) … … 7452 7348 (setq val (%car valcopy)) 7453 7349 (cond ((or (%ilogbitp $vbitspecial (setq bits (nx-var-bits var))) 7454 (and ( %ilogbitp $vbitreg bits)7350 (and (var-nvr var) 7455 7351 (dolist (val (%cdr valcopy)) 7456 7352 (unless (ppc2-trivial-p val) (return t)))))
Note: See TracChangeset
for help on using the changeset viewer.
