Changeset 5501
- Timestamp:
- Nov 6, 2006, 9:04:38 PM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/compiler/PPC/ppc2.lisp (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/compiler/PPC/ppc2.lisp
r5477 r5501 1545 1545 1546 1546 1547 (defun ppc2-aset2 (seg target array i j new safe typename &optionaldim0 dim1)1548 (with-ppc-local-vinsn-macros (seg target)1547 (defun ppc2-aset2 (seg vreg xfer array i j new safe type-keyword dim0 dim1) 1548 (with-ppc-local-vinsn-macros (seg vreg xfer) 1549 1549 (let* ((i-known-fixnum (acode-fixnum-form-p i)) 1550 1550 (j-known-fixnum (acode-fixnum-form-p j)) 1551 1551 (arch (backend-target-arch *target-backend*)) 1552 (is-node (member type-keyword (arch::target-gvector-types arch))) 1553 (constval (ppc2-constant-value-ok-for-type-keyword type-keyword new)) 1554 (needs-memoization (and is-node (ppc2-acode-needs-memoization new))) 1552 1555 (src) 1553 1556 (unscaled-i) 1554 1557 (unscaled-j) 1555 ( need-scale t)1558 (val-reg (ppc2-target-reg-for-aset vreg type-keyword)) 1556 1559 (constidx 1557 1560 (and dim0 dim1 i-known-fixnum j-known-fixnum … … 1563 1566 (progn 1564 1567 (if constidx 1565 (multiple-value-setq (src target)1566 (ppc2-two-targeted-reg-forms seg array ($ ppc:: arg_z) new target))1567 (multiple-value-setq (src unscaled-i unscaled-j target)1568 (multiple-value-setq (src val-reg) 1569 (ppc2-two-targeted-reg-forms seg array ($ ppc::temp0) new val-reg)) 1570 (multiple-value-setq (src unscaled-i unscaled-j val-reg) 1568 1571 (ppc2-four-untargeted-reg-forms seg 1569 array ($ ppc:: arg_x)1570 i ($ ppc::arg_ y)1571 j ($ ppc::arg_ z)1572 new target)))1572 array ($ ppc::temp0) 1573 i ($ ppc::arg_x) 1574 j ($ ppc::arg_y) 1575 new val-reg))) 1573 1576 (when safe 1574 1577 (when (typep safe 'fixnum) 1575 (! trap-unless- array-header src)1576 (! check-arrayH-rank src 2)1577 (! check-arrayH-flags src1578 (dpb safe target::arrayh.flags-cell-subtag-byte1579 (ash 1 $arh_simple_bit))))1578 (! trap-unless-simple-array-2 1579 src 1580 (dpb safe target::arrayH.flags-cell-subtag-byte 1581 (ash 1 $arh_simple_bit)) 1582 (nx-error-for-simple-2d-array-type type-keyword))) 1580 1583 (unless i-known-fixnum 1581 1584 (! trap-unless-fixnum unscaled-i)) 1582 1585 (unless j-known-fixnum 1583 1586 (! trap-unless-fixnum unscaled-j))) 1584 (with-imm-t emps () (dim1 idx-reg)1585 ( unless constidx1586 ( if safe1587 ( ! check-2d-bound dim1 unscaled-i unscaled-j src)1588 (! 2d-dim1 dim1 src))1589 (! 2d-unscaled-index idx-reg src unscaled-i unscaled-j dim1))1590 (with-node-temps () (v)1591 (let* (( bias (arch::target-misc-data-offset arch)))1587 (with-imm-target () dim1 1588 (let* ((idx-reg ($ ppc::arg_y))) 1589 (unless constidx 1590 (if safe 1591 (! check-2d-bound dim1 unscaled-i unscaled-j src) 1592 (! 2d-dim1 dim1 src)) 1593 (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j)) 1594 (let* ((v ($ ppc::arg_x))) 1592 1595 (! array-data-vector-ref v src) 1593 (multiple-value-bind (shift limit) 1594 (case typename 1595 (:double-float-vector 1596 (setq bias (arch::target-misc-dfloat-offset arch)) 1597 (values 3 (arch::target-max-64-bit-constant-index arch))) 1598 (:single-float-vector 1599 (values 2 (arch::target-max-32-bit-constant-index arch)))) 1600 (when (and constidx (>= constidx limit)) 1601 (ppc2-absolute-natural seg idx-reg nil (+ bias 1602 (ash constidx shift))) 1603 (setq constidx nil need-scale nil))) 1604 (case typename 1605 (:double-float-vector 1606 (if constidx 1607 (! misc-set-c-double-float target v constidx) 1608 (progn 1609 (when need-scale (! scale-64bit-misc-index idx-reg idx-reg)) 1610 (! misc-set-double-float target v idx-reg)))) 1611 (:single-float-vector 1612 (if constidx 1613 (! misc-set-c-single-float target v constidx) 1614 (progn 1615 (when need-scale (! scale-32bit-misc-index idx-reg idx-reg)) 1616 (! misc-set-single-float target v idx-reg))))))))))) 1617 target) 1596 (ppc2-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (ppc2-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization)))))))) 1597 1618 1598 1619 1599 (defun ppc2-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1) … … 1661 1641 1662 1642 1663 (defun ppc2-natural-vset (seg vreg xfer vector index value safe)1664 (with-ppc-local-vinsn-macros (seg vreg xfer)1665 (let* ((index-known-fixnum (acode-fixnum-form-p index))1666 (arch (backend-target-arch *target-backend*))1667 (src nil)1668 (unscaled-idx nil))1669 (with-imm-target () (target :natural)1670 (if (or safe (not index-known-fixnum))1671 (multiple-value-setq (src unscaled-idx target)1672 (ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg target)))1673 (multiple-value-setq (src target)1674 (ppc2-two-untargeted-reg-forms seg vector ppc::arg_y value (or vreg target))))1675 (when safe1676 (with-imm-temps (target) () ; Don't use target in type/bounds check1677 (if (typep safe 'fixnum)1678 (! trap-unless-typecode= src safe))1679 (unless index-known-fixnum1680 (! trap-unless-fixnum unscaled-idx))1681 (! check-misc-bound unscaled-idx src)))1682 (target-arch-case1683 (:ppc321684 (if (and index-known-fixnum1685 (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))1686 (! misc-set-c-u32 target src index-known-fixnum)1687 (with-imm-temps (target) (idx-reg)1688 (if index-known-fixnum1689 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))1690 (! scale-32bit-misc-index idx-reg unscaled-idx))1691 (! misc-set-u32 target src idx-reg))))1692 (:ppc641693 (if (and index-known-fixnum1694 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))1695 (! misc-set-c-u64 target src index-known-fixnum)1696 (with-imm-temps (target) (idx-reg)1697 (if index-known-fixnum1698 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))1699 (! scale-64bit-misc-index idx-reg unscaled-idx))1700 (! misc-set-u64 target src idx-reg)))))1701 (<- target) ; should be a no-op in this case1702 (^)))))1703 1704 1643 1705 1644 (defun ppc2-constant-value-ok-for-type-keyword (type-keyword form) … … 1728 1667 (if typep val)))) 1729 1668 1730 (defun ppc2- vset (seg vreg xfer type-keyword vector index value safe)1669 (defun ppc2-target-reg-for-aset (vreg type-keyword) 1731 1670 (let* ((arch (backend-target-arch *target-backend*)) 1732 1671 (is-node (member type-keyword (arch::target-gvector-types arch))) … … 1735 1674 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1736 1675 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1737 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))) 1738 (if is-node 1739 (ppc2-misc-node-set seg vreg xfer vector index value safe) 1740 (let* ((vreg-class (if vreg (hard-regspec-class vreg))) 1741 (vreg-mode 1742 (if (and vreg-class (= vreg-class hard-reg-class-gpr)) 1743 (get-regspec-mode vreg) 1744 hard-reg-class-gpr-mode-invalid))) 1745 (declare (fixnum vreg-class vreg-mode)) 1746 (if (and (eq type-keyword :double-float-vector) 1747 (or (null vreg) (eql vreg-class hard-reg-class-fpr))) 1748 (ppc2-df-vset seg vreg xfer vector index value safe) 1749 (if (and (eq type-keyword :single-float-vector) 1750 (or (null vreg) (eql vreg-class hard-reg-class-fpr))) 1751 (ppc2-sf-vset seg vreg xfer vector index value safe) 1752 (if (target-arch-case 1753 (:ppc32 (and (eq type-keyword :unsigned-32-bit-vector) 1754 (or (null vreg) (eql vreg-mode hard-reg-class-gpr-mode-u32)))) 1755 (:ppc64 (and (eq type-keyword :unsigned-64-bit-vector) 1756 (or (null vreg) (eql vreg-mode hard-reg-class-gpr-mode-u64))))) 1757 (ppc2-natural-vset seg vreg xfer vector index value safe) 1758 (with-ppc-local-vinsn-macros (seg vreg xfer) 1759 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 1760 (constval (ppc2-constant-value-ok-for-type-keyword type-keyword value)) 1761 (need-val-reg (or vreg (not constval))) 1762 (unscaled-idx nil) 1763 (idx-reg nil) 1764 (val-reg) 1765 (src nil)) 1766 (if (or safe (not index-known-fixnum)) 1767 (if need-val-reg 1768 (multiple-value-setq (src unscaled-idx val-reg) 1769 (ppc2-three-untargeted-reg-forms seg vector ppc::arg_x index ppc::arg_y value ppc::arg_z)) 1770 (multiple-value-setq (src unscaled-idx) 1771 (ppc2-two-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z))) 1772 (if need-val-reg 1773 (multiple-value-setq (src val-reg) 1774 (ppc2-two-untargeted-reg-forms seg vector ppc::arg_y value ppc::arg_z)) 1775 (setq src (ppc2-one-untargeted-reg-form seg vector ppc::arg_z)))) 1776 (when safe 1777 (if (typep safe 'fixnum) 1778 (! trap-unless-typecode= src safe)) 1779 (unless index-known-fixnum 1780 (! trap-unless-fixnum unscaled-idx)) 1781 (! check-misc-bound unscaled-idx src)) 1782 (with-imm-temps () (temp) 1783 (cond (is-32-bit 1784 (if constval 1785 (ppc2-lri seg temp 1786 (if (typep constval 'single-float) 1787 (ppc2-single-float-bits constval) 1788 (if (characterp constval) 1789 (char-code constval) 1790 constval))) 1791 (cond ((eq type-keyword :single-float-vector) 1792 (when safe 1793 (! trap-unless-single-float val-reg)) 1794 (! single-float-bits temp val-reg)) 1795 ((eq type-keyword :signed-32-bit-vector) 1796 (! unbox-s32 temp val-reg)) 1797 ((eq type-keyword :fixnum-vector) 1798 (when safe 1799 (! trap-unless-fixnum val-reg)) 1800 (! fixnum->signed-natural temp val-reg)) 1801 ((eq type-keyword :simple-string) 1802 (! unbox-base-char temp val-reg)) 1803 (t 1804 (! unbox-u32 temp val-reg)))) 1805 (if (and index-known-fixnum 1806 (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) 1807 (! misc-set-c-u32 temp src index-known-fixnum) 1808 (progn 1809 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1810 (if index-known-fixnum 1811 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 1812 (! scale-32bit-misc-index idx-reg unscaled-idx)) 1813 (! misc-set-u32 temp src idx-reg)))) 1814 (is-8-bit 1815 (if constval 1816 (ppc2-lri seg temp (if (characterp constval) (char-code constval) constval)) 1817 (if safe 1818 (cond ((eq type-keyword :simple-string) 1819 (! unbox-base-char temp val-reg)) 1820 ((eq type-keyword :signed-8-bit-vector) 1821 (! unbox-s8 temp val-reg)) 1822 (t 1823 (! unbox-u8 temp val-reg))) 1824 (if (eq type-keyword :simple-string) 1825 (! character->code temp val-reg) 1826 (! fixnum->unsigned-natural temp val-reg)))) 1827 (if (and index-known-fixnum 1828 (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch))) 1829 (! misc-set-c-u8 temp src index-known-fixnum) 1830 (progn 1831 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1832 (if index-known-fixnum 1833 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 1834 (! scale-8bit-misc-index idx-reg unscaled-idx)) 1835 (! misc-set-u8 temp src idx-reg)))) 1836 (is-16-bit 1837 (if constval 1838 (ppc2-lri seg temp (if (characterp constval) (char-code constval) constval)) 1839 (if safe 1840 (cond ((eq type-keyword :signed-16-bit-vector) 1841 (! unbox-s16 temp val-reg)) 1842 (t 1843 (! unbox-u16 temp val-reg))) 1844 (! fixnum->unsigned-natural temp val-reg))) 1845 (if (and index-known-fixnum 1846 (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch))) 1847 (! misc-set-c-u16 temp src index-known-fixnum) 1848 (progn 1849 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1850 (if index-known-fixnum 1851 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 1852 (! scale-16bit-misc-index idx-reg unscaled-idx)) 1853 (! misc-set-u16 temp src idx-reg)))) 1854 (is-64-bit 1855 (ecase type-keyword 1856 (:double-float-vector 1857 (if safe 1858 (! get-double? 0 val-reg) 1859 (! get-double 0 val-reg)) 1860 (if (and index-known-fixnum 1861 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1862 (! misc-set-c-double-float 0 src index-known-fixnum) 1863 (progn 1864 (setq idx-reg temp) 1865 (if index-known-fixnum 1866 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) 1867 (! scale-64bit-misc-index idx-reg unscaled-idx)) 1868 (! misc-set-double-float 0 src idx-reg)))) 1869 ((:signed-64-bit-vector :fixnum-vector) 1870 (with-imm-target (temp) (s64 :s64) 1871 (if (eq type-keyword :fixnum-vector) 1872 (progn 1873 (when safe 1874 (! trap-unless-fixnum val-reg)) 1875 (! fixnum->signed-natural s64 val-reg)) 1876 (! unbox-s64 s64 val-reg)) 1877 (if (and index-known-fixnum 1878 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1879 (! misc-set-c-s64 s64 src index-known-fixnum) 1880 (progn 1881 (setq idx-reg temp) 1882 (if index-known-fixnum 1883 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) 1884 (! scale-64bit-misc-index idx-reg unscaled-idx)) 1885 (! misc-set-s64 s64 src idx-reg))))) 1886 (:unsigned-64-bit-vector 1887 (with-imm-target (temp) (u64 :u64) 1888 (! unbox-u64 u64 val-reg) 1889 (if (and index-known-fixnum 1890 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1891 (! misc-set-c-u64 u64 src index-known-fixnum) 1892 (progn 1893 (setq idx-reg temp) 1894 (if index-known-fixnum 1895 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) 1896 (! scale-64bit-misc-index idx-reg unscaled-idx)) 1897 (! misc-set-u64 u64 src idx-reg))))) 1898 )) 1899 (t 1900 (unless is-1-bit 1901 (nx-error "~& unsupported vector type: ~s" 1902 type-keyword)) 1903 ;; bit-vector case. 1904 ;; It's easiest to do this when the bitnumber is 1905 ;; known (and a little easier still 1906 ;; if the value's known.) 1907 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1908 (let* ((word-index (ash index-known-fixnum -5)) 1909 (bit-number (logand index-known-fixnum #x1f))) 1910 (! misc-ref-c-u32 temp src word-index) 1911 (if constval 1912 (if (zerop constval) 1913 (! set-constant-ppc-bit-to-0 temp temp bit-number) 1914 (! set-constant-ppc-bit-to-1 temp temp bit-number)) 1915 (with-imm-temps () (bitval) 1916 (! unbox-bit bitval val-reg) 1917 (! set-constant-ppc-bit-to-variable-value temp temp bitval bit-number))) 1918 (! misc-set-c-u32 temp src word-index)) 1919 ;; When the bit-number isn't known, we have to do one of the following: 1920 ;; A) If the value's known: 1921 ;; 1) generate a mask with a 1 in the "bitnum" bit and 0s elsewhere. 1922 ;; 2) Grab the word out of the vector. 1923 ;; 3) If the value's 0, do an ANDC with the mask and word, else an OR. 1924 ;; B) When the value's not known: 1925 ;; 1) Extract the value into PPC bit 0 of some register, trapping if value not a bit. 1926 ;; 2) Shift the value right "bitnum" bits. 1927 ;; 3) Generate a mask with a 1 in the "bitnum" bit and 0s elsewhere. 1928 ;; 4) Reference the word, ANDC it with the mask, OR the shifted value in. 1929 (with-imm-temps () (word-index bit-number) 1930 (! scale-1bit-misc-index word-index bit-number unscaled-idx) 1931 (if constval 1932 (progn 1933 (! lri temp #x80000000) 1934 (! shift-right-variable-word bit-number temp bit-number) ; (A1) 1935 (! misc-ref-u32 temp src word-index) ; (A2) 1936 (if (zerop constval) ; (A3) 1937 (! u32logandc2 temp temp bit-number) 1938 (! u32logior temp temp bit-number))) 1939 (with-imm-temps () (bitval) 1940 (! unbox-bit-bit0 bitval val-reg) ; (B1) 1941 (! shift-right-variable-word bitval bitval bit-number) ; (B2) 1942 (! lri temp #x80000000) 1943 (! shift-right-variable-word bit-number temp bit-number) ; (B3) 1944 (! misc-ref-u32 temp src word-index) 1945 (! u32logandc2 temp temp bit-number) ; clear bit-number'th bit 1946 (! u32logior temp temp bitval))) ; (B4) 1947 (! misc-set-u32 temp src word-index))))) 1948 (when vreg (<- val-reg)))) 1949 (^))))))))) 1950 1951 ;;; In this case, the destination (vreg) is either an FPR or null, so 1952 ;;; we can maybe avoid boxing the value. 1953 (defun ppc2-df-vset (seg vreg xfer vector index value safe) 1676 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1677 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :fixnum-vector))) 1678 (vreg-class (if vreg (hard-regspec-class vreg))) 1679 (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr) 1680 (eql vreg-class hard-reg-class-fpr)) 1681 (get-regspec-mode vreg))) 1682 (next-imm-target (available-imm-temp *available-backend-imm-temps*)) 1683 (next-fp-target (available-fp-temp *available-backend-fp-temps*)) 1684 (acc (make-wired-lreg ppc::arg_z))) 1685 (cond ((or is-node 1686 is-1-bit 1687 (eq type-keyword :simple-string) 1688 (eq type-keyword :fixnum-vector) 1689 (and (eql vreg-class hard-reg-class-gpr) 1690 (eql vreg-mode hard-reg-class-gpr-mode-node))) 1691 acc) 1692 ;; If there's no vreg - if we're setting for effect only, and 1693 ;; not for value - we can target an unboxed register directly. 1694 ;; Usually. 1695 ((null vreg) 1696 (cond (is-64-bit 1697 (if (eq type-keyword :double-float-vector) 1698 (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double) 1699 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64)))) 1700 (is-32-bit 1701 (if (eq type-keyword :single-float-vector) 1702 (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single) 1703 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32)))) 1704 (is-16-bit 1705 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16))) 1706 (is-8-bit 1707 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8))) 1708 (t "Bug: can't determine operand size for ~s" type-keyword))) 1709 ;; Vreg is non-null. We might be able to use it directly. 1710 (t 1711 (let* ((lreg (if vreg-mode 1712 (make-unwired-lreg (lreg-value vreg))))) 1713 (if 1714 (cond 1715 (is-64-bit 1716 (if (eq type-keyword :double-float-vector) 1717 (and (eql vreg-class hard-reg-class-fpr) 1718 (eql vreg-mode hard-reg-class-fpr-mode-double)) 1719 (if is-signed 1720 (and (eql vreg-class hard-reg-class-gpr) 1721 (eql vreg-mode hard-reg-class-gpr-mode-s64)) 1722 (and (eql vreg-class hard-reg-class-gpr) 1723 (eql vreg-mode hard-reg-class-gpr-mode-u64))))) 1724 (is-32-bit 1725 (if (eq type-keyword :single-float-vector) 1726 (and (eql vreg-class hard-reg-class-fpr) 1727 (eql vreg-mode hard-reg-class-fpr-mode-single)) 1728 (if is-signed 1729 (and (eql vreg-class hard-reg-class-gpr) 1730 (or (eql vreg-mode hard-reg-class-gpr-mode-s32) 1731 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1732 (and (eql vreg-class hard-reg-class-gpr) 1733 (or (eql vreg-mode hard-reg-class-gpr-mode-u32) 1734 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1735 (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) 1736 (is-16-bit 1737 (if is-signed 1738 (and (eql vreg-class hard-reg-class-gpr) 1739 (or (eql vreg-mode hard-reg-class-gpr-mode-s16) 1740 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1741 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1742 (and (eql vreg-class hard-reg-class-gpr) 1743 (or (eql vreg-mode hard-reg-class-gpr-mode-u16) 1744 (eql vreg-mode hard-reg-class-gpr-mode-u32) 1745 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1746 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1747 (eql vreg-mode hard-reg-class-gpr-mode-s64))))) 1748 (t 1749 (if is-signed 1750 (and (eql vreg-class hard-reg-class-gpr) 1751 (or (eql vreg-mode hard-reg-class-gpr-mode-s8) 1752 (eql vreg-mode hard-reg-class-gpr-mode-s16) 1753 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1754 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1755 (and (eql vreg-class hard-reg-class-gpr) 1756 (or (eql vreg-mode hard-reg-class-gpr-mode-u8) 1757 (eql vreg-mode hard-reg-class-gpr-mode-u16) 1758 (eql vreg-mode hard-reg-class-gpr-mode-u32) 1759 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1760 (eql vreg-mode hard-reg-class-gpr-mode-s16) 1761 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1762 (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) 1763 lreg 1764 acc)))))) 1765 1766 (defun ppc2-unboxed-reg-for-aset (seg type-keyword result-reg safe constval) 1767 (with-ppc-local-vinsn-macros (seg) 1768 (let* ((arch (backend-target-arch *target-backend*)) 1769 (is-node (member type-keyword (arch::target-gvector-types arch))) 1770 (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) 1771 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1772 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1773 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1774 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :fixnum-vector))) 1775 (result-is-node-gpr (and (eql (hard-regspec-class result-reg) 1776 hard-reg-class-gpr) 1777 (eql (get-regspec-mode result-reg) 1778 hard-reg-class-gpr-mode-node))) 1779 (next-imm-target (available-imm-temp *available-backend-imm-temps*)) 1780 (next-fp-target (available-fp-temp *available-backend-fp-temps*))) 1781 (if (or is-node (not result-is-node-gpr)) 1782 result-reg 1783 (cond (is-64-bit 1784 (if (eq type-keyword :double-float-vector) 1785 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double))) 1786 (if safe 1787 (! get-double? reg result-reg) 1788 (! get-double reg result-reg)) 1789 reg) 1790 (if is-signed 1791 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s64))) 1792 (if (eq type-keyword :fixnum-vector) 1793 (progn 1794 (when safe 1795 (! trap-unless-fixnum result-reg)) 1796 (! fixnum->signed-natural reg result-reg)) 1797 (! unbox-s64 reg result-reg)) 1798 reg) 1799 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u64))) 1800 (! unbox-u64 reg result-reg) 1801 reg)))) 1802 (is-32-bit 1803 ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR 1804 ;; case here. 1805 (if is-signed 1806 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32))) 1807 (if (eq type-keyword :fixnum-vector) 1808 (progn 1809 (when safe 1810 (! trap-unless-fixnum result-reg)) 1811 (! fixnum->signed-natural reg result-reg)) 1812 (! unbox-s32 reg result-reg)) 1813 reg) 1814 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32))) 1815 (cond ((eq type-keyword :simple-string) 1816 (if (characterp constval) 1817 (ppc2-lri seg reg (char-code constval)) 1818 (! unbox-base-char reg result-reg))) 1819 ((eq type-keyword :single-float-vector) 1820 (if (typep constval 'single-float) 1821 (ppc2-lri seg reg (single-float-bits constval)) 1822 (progn 1823 (when safe 1824 (! trap-unless-single-float result-reg)) 1825 (! single-float-bits reg result-reg)))) 1826 (t 1827 (if (typep constval '(unsigned-byte 32)) 1828 (ppc2-lri seg reg constval) 1829 (! unbox-u32 reg result-reg)))) 1830 reg))) 1831 (is-16-bit 1832 (if is-signed 1833 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16))) 1834 (if (typep constval '(signed-byte 16)) 1835 (ppc2-lri seg reg constval) 1836 (! unbox-s16 reg result-reg)) 1837 reg) 1838 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16))) 1839 (if (typep constval '(unsigned-byte 16)) 1840 (ppc2-lri seg reg constval) 1841 (! unbox-u16 reg result-reg)) 1842 reg))) 1843 (is-8-bit 1844 (if is-signed 1845 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8))) 1846 (if (typep constval '(signed-byte 8)) 1847 (ppc2-lri seg reg constval) 1848 (! unbox-s8 reg result-reg)) 1849 reg) 1850 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) 1851 (if (typep constval '(unsigned-byte 8)) 1852 (ppc2-lri seg reg constval) 1853 (! unbox-u8 reg result-reg)) 1854 reg))) 1855 (t 1856 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) 1857 (unless (typep constval 'bit) 1858 (! unbox-bit-bit0 reg result-reg)) 1859 reg))))))) 1860 1861 1862 ;;; "val-reg" might be boxed, if the vreg requires it to be. 1863 (defun ppc2-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval &optional (node-value-needs-memoization t)) 1954 1864 (with-ppc-local-vinsn-macros (seg vreg xfer) 1955 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 1956 (arch (backend-target-arch *target-backend*)) 1957 (src nil) 1958 (unscaled-idx nil)) 1959 (with-fp-target () fp-val 1960 (if (or safe (not index-known-fixnum)) 1961 (multiple-value-setq (src unscaled-idx fp-val) 1962 (ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg fp-val))) 1963 (multiple-value-setq (src fp-val) 1964 (ppc2-two-untargeted-reg-forms seg vector ppc::arg_z value (or vreg fp-val)))) 1965 (when safe 1966 (if (typep safe 'fixnum) 1967 (! trap-unless-typecode= src safe)) 1968 (unless index-known-fixnum 1969 (! trap-unless-fixnum unscaled-idx)) 1970 (! check-misc-bound unscaled-idx src)) 1971 (if (and index-known-fixnum 1972 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1973 (! misc-set-c-double-float fp-val src index-known-fixnum) 1974 (with-imm-temps () (idx-reg) 1975 (if index-known-fixnum 1976 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) 1977 (! scale-64bit-misc-index idx-reg unscaled-idx)) 1978 (! misc-set-double-float fp-val src idx-reg))) 1979 (<- fp-val) ; should be a no-op in this case 1980 (^))))) 1981 1982 (defun ppc2-sf-vset (seg vreg xfer vector index value safe) 1983 (with-ppc-local-vinsn-macros (seg vreg xfer) 1984 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 1985 (arch (backend-target-arch *target-backend*)) 1986 (src nil) 1987 (unscaled-idx nil)) 1988 (with-fp-target () (fp-val :single-float) 1989 (if (or safe (not index-known-fixnum)) 1990 (multiple-value-setq (src unscaled-idx fp-val) 1991 (ppc2-three-untargeted-reg-forms seg vector ppc::arg_y index ppc::arg_z value (or vreg fp-val))) 1992 (multiple-value-setq (src fp-val) 1993 (ppc2-two-untargeted-reg-forms seg vector ppc::arg_z value (or vreg fp-val)))) 1994 (when safe 1995 (if (typep safe 'fixnum) 1996 (! trap-unless-typecode= src safe)) 1997 (unless index-known-fixnum 1998 (! trap-unless-fixnum unscaled-idx)) 1999 (! check-misc-bound unscaled-idx src)) 2000 (if (and index-known-fixnum 2001 (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) 2002 (! misc-set-c-single-float fp-val src index-known-fixnum) 2003 (with-imm-temps () (idx-reg) 2004 (if index-known-fixnum 2005 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 2006 (! scale-32bit-misc-index idx-reg unscaled-idx)) 2007 (! misc-set-single-float fp-val src idx-reg))) 2008 (<- fp-val) ; should be a no-op in this case 2009 (^))))) 1865 (let* ((arch (backend-target-arch *target-backend*)) 1866 (is-node (member type-keyword (arch::target-gvector-types arch))) 1867 (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) 1868 (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) 1869 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1870 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1871 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1872 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :fixnum-vector)))) 1873 (cond ((and is-node node-value-needs-memoization) 1874 (unless (and (eql (hard-regspec-value src) ppc::arg_x) 1875 (eql (hard-regspec-value unscaled-idx) ppc::arg_y) 1876 (eql (hard-regspec-value val-reg) ppc::arg_z)) 1877 (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg))) 1878 (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg)) 1879 (is-node 1880 (if (and index-known-fixnum (<= index-known-fixnum 1881 (target-word-size-case 1882 (32 (arch::target-max-32-bit-constant-index arch)) 1883 (64 (arch::target-max-64-bit-constant-index arch))))) 1884 (! misc-set-c-node val-reg src index-known-fixnum) 1885 (with-imm-target () scaled-idx 1886 1887 (if index-known-fixnum 1888 (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *ppc2-target-node-shift*))) 1889 (! scale-node-misc-index scaled-idx unscaled-idx)) 1890 (! misc-set-node val-reg src scaled-idx)))) 1891 (t 1892 (with-imm-target (unboxed-val-reg) scaled-idx 1893 (cond 1894 (is-64-bit 1895 (if (and index-known-fixnum 1896 (<= index-known-fixnum 1897 (arch::target-max-64-bit-constant-index arch))) 1898 (if (eq type-keyword :double-float-vector) 1899 (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum) 1900 (if is-signed 1901 (! misc-set-c-s64 unboxed-val-reg src index-known-fixnum) 1902 (! misc-set-c-u64 unboxed-val-reg src index-known-fixnum))) 1903 (progn 1904 (if index-known-fixnum 1905 (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))) 1906 (! scale-64bit-misc-index scaled-idx unscaled-idx)) 1907 (if (eq type-keyword :double-float-vector) 1908 (! misc-set-double-float unboxed-val-reg src scaled-idx) 1909 (if is-signed 1910 (! misc-set-s64 unboxed-val-reg src scaled-idx) 1911 (! misc-set-u64 unboxed-val-reg src scaled-idx)))))) 1912 (is-32-bit 1913 (if (and index-known-fixnum 1914 (<= index-known-fixnum 1915 (arch::target-max-32-bit-constant-index arch))) 1916 (if (eq type-keyword :single-float-vector) 1917 (if (eq (hard-regspec-class unboxed-val-reg) 1918 hard-reg-class-fpr) 1919 (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum) 1920 (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)) 1921 (if is-signed 1922 (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum) 1923 (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))) 1924 (progn 1925 (if index-known-fixnum 1926 (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 1927 (! scale-32bit-misc-index scaled-idx unscaled-idx)) 1928 (if (and (eq type-keyword :single-float-vector) 1929 (eql (hard-regspec-class unboxed-val-reg) 1930 hard-reg-class-fpr)) 1931 (! misc-set-single-float unboxed-val-reg src scaled-idx) 1932 (if is-signed 1933 (! misc-set-s32 unboxed-val-reg src scaled-idx) 1934 (! misc-set-u32 unboxed-val-reg src scaled-idx)))))) 1935 (is-16-bit 1936 (if (and index-known-fixnum 1937 (<= index-known-fixnum 1938 (arch::target-max-16-bit-constant-index arch))) 1939 (if is-signed 1940 (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum) 1941 (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum)) 1942 (progn 1943 (if index-known-fixnum 1944 (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 1945 (! scale-16bit-misc-index scaled-idx unscaled-idx)) 1946 (if is-signed 1947 (! misc-set-s16 unboxed-val-reg src scaled-idx) 1948 (! misc-set-u16 unboxed-val-reg src scaled-idx))))) 1949 (is-8-bit 1950 (if (and index-known-fixnum 1951 (<= index-known-fixnum 1952 (arch::target-max-8-bit-constant-index arch))) 1953 (if is-signed 1954 (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum) 1955 (! misc-set-c-u8 unboxed-val-reg src index-known-fixnum)) 1956 (progn 1957 (if index-known-fixnum 1958 (ppc2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 1959 (! scale-8bit-misc-index scaled-idx unscaled-idx)) 1960 (if is-signed 1961 (! misc-set-s8 unboxed-val-reg src scaled-idx) 1962 (! misc-set-u8 unboxed-val-reg src scaled-idx))))) 1963 (t 1964 (unless is-1-bit 1965 (nx-error "~& unsupported vector type: ~s" 1966 type-keyword)) 1967 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) 1968 (with-imm-target (unboxed-val-reg) word 1969 (let* ((word-index (ash index-known-fixnum -5)) 1970 (bit-number (logand index-known-fixnum #x1f))) 1971 (! misc-ref-c-u32 word src word-index) 1972 (if constval 1973 (if (zerop constval) 1974 (! set-constant-ppc-bit-to-0 word word bit-number) 1975 (! set-constant-ppc-bit-to-1 word word bit-number)) 1976 (! set-constant-ppc-bit-to-variable-value word word unboxed-val-reg bit-number)) 1977 (! misc-set-c-u32 word src word-index))) 1978 (with-imm-temps (unboxed-val-reg) (word-index bit-number temp) 1979 (! scale-1bit-misc-index word-index bit-number unscaled-idx) 1980 (if constval 1981 (progn 1982 (! lri temp #x80000000) 1983 (! shift-right-variable-word bit-number temp bit-number) 1984 (! misc-ref-u32 temp src word-index) 1985 (if (zerop constval) 1986 (! u32logandc2 temp temp bit-number) 1987 (! u32logior temp temp bit-number))) 1988 (with-imm-temps () (bitval) 1989 (! shift-right-variable-word bitval unboxed-val-reg bit-number) 1990 (! lri temp #x80000000) 1991 (! shift-right-variable-word bit-number temp bit-number) 1992 (! misc-ref-u32 temp src word-index) 1993 (! u32logandc2 temp temp bit-number) 1994 (! u32logior temp temp bitval))) 1995 (! misc-set-u32 temp src word-index)))))))) 1996 (when (and vreg val-reg) (<- val-reg)) 1997 (^)))) 1998 1999 2000 (defun ppc2-vset (seg vreg xfer type-keyword vector index value safe) 2001 (with-ppc-local-vinsn-macros (seg) 2002 (let* ((arch (backend-target-arch *target-backend*)) 2003 (is-node (member type-keyword (arch::target-gvector-types arch))) 2004 (constval (ppc2-constant-value-ok-for-type-keyword type-keyword value)) 2005 (needs-memoization (and is-node (ppc2-acode-needs-memoization value))) 2006 (index-known-fixnum (acode-fixnum-form-p index))) 2007 (let* ((src ($ ppc::arg_x)) 2008 (unscaled-idx ($ ppc::arg_y)) 2009 (result-reg ($ ppc::arg_z))) 2010 (cond (needs-memoization 2011 (ppc2-three-targeted-reg-forms seg 2012 vector src 2013 index unscaled-idx 2014 value result-reg)) 2015 (t 2016 (setq result-reg (ppc2-target-reg-for-aset vreg type-keyword)) 2017 (ppc2-three-targeted-reg-forms seg 2018 vector src 2019 index unscaled-idx 2020 value result-reg))) 2021 (when safe 2022 (let* ((*available-backend-imm-temps* *available-backend-imm-temps*) 2023 (value (if (eql (hard-regspec-class result-reg) 2024 hard-reg-class-gpr) 2025 (hard-regspec-value result-reg)))) 2026 (when (and value (logbitp value *available-backend-imm-temps*)) 2027 (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*))) 2028 (if (typep safe 'fixnum) 2029 (! trap-unless-typecode= src safe)) 2030 (unless index-known-fixnum 2031 (! trap-unless-fixnum unscaled-idx)) 2032 (! check-misc-bound unscaled-idx src))) 2033 (ppc2-vset1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum result-reg (ppc2-unboxed-reg-for-aset seg type-keyword result-reg safe constval) constval needs-memoization))))) 2010 2034 2011 2035 … … 2663 2687 (values adest bdest)))) 2664 2688 2689 2690 (defun ppc2-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg) 2691 (unless (typep areg 'lreg) 2692 (warn "~s is not an lreg (1/4)" areg)) 2693 (unless (typep breg 'lreg) 2694 (warn "~s is not an lreg (2/4)" breg)) 2695 (unless (typep creg 'lreg) 2696 (warn "~s is not an lreg (3/4)" creg)) 2697 (unless (typep dreg 'lreg) 2698 (warn "~s is not an lreg (4/4)" dreg)) 2699 (let* ((atriv (or (null aform) 2700 (and (ppc2-trivial-p bform) 2701 (ppc2-trivial-p cform) 2702 (ppc2-trivial-p dform)))) 2703 (btriv (or (null bform) 2704 (and (ppc2-trivial-p cform) 2705 (ppc2-trivial-p dform)))) 2706 (ctriv (or (null cform) 2707 (ppc2-trivial-p dform))) 2708 2709 (aconst (and (not atriv) 2710 (or (ppc-side-effect-free-form-p aform) 2711 (let ((avar (ppc2-lexical-reference-p aform))) 2712 (and avar 2713 (ppc2-var-not-set-by-form-p avar bform) 2714 (ppc2-var-not-set-by-form-p avar cform) 2715 (ppc2-var-not-set-by-form-p avar dform)))))) 2716 (bconst (and (not btriv) 2717 (or (ppc-side-effect-free-form-p bform) 2718 (let ((bvar (ppc2-lexical-reference-p bform))) 2719 (and bvar 2720 (ppc2-var-not-set-by-form-p bvar cform) 2721 (ppc2-var-not-set-by-form-p bvar dform)))))) 2722 (cconst (and (not ctriv) 2723 (or (ppc-side-effect-free-form-p cform) 2724 (let ((cvar (ppc2-lexical-reference-p cform))) 2725 (and cvar 2726 (ppc2-var-not-set-by-form-p cvar dform)))))) 2727 (apushed nil) 2728 (bpushed nil) 2729 (cpushed nil)) 2730 (if (and aform (not aconst)) 2731 (if atriv 2732 (ppc2-one-targeted-reg-form seg aform areg) 2733 (setq apushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg aform (ppc2-acc-reg-for areg)))))) 2734 (if (and bform (not bconst)) 2735 (if btriv 2736 (ppc2-one-targeted-reg-form seg bform breg) 2737 (setq bpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg bform (ppc2-acc-reg-for breg)))))) 2738 (if (and cform (not cconst)) 2739 (if ctriv 2740 (ppc2-one-targeted-reg-form seg cform creg) 2741 (setq cpushed (ppc2-push-register seg (ppc2-one-untargeted-reg-form seg cform (ppc2-acc-reg-for creg)))))) 2742 (ppc2-one-targeted-reg-form seg dform dreg) 2743 (unless ctriv 2744 (if cconst 2745 (ppc2-one-targeted-reg-form seg cform creg) 2746 (ppc2-elide-pushes seg cpushed (ppc2-pop-register seg creg)))) 2747 (unless btriv 2748 (if bconst 2749 (ppc2-one-targeted-reg-form seg bform breg) 2750 (ppc2-elide-pushes seg bpushed (ppc2-pop-register seg breg)))) 2751 (unless atriv 2752 (if aconst 2753 (ppc2-one-targeted-reg-form seg aform areg) 2754 (ppc2-elide-pushes seg apushed (ppc2-pop-register seg areg)))) 2755 (values areg breg creg dreg))) 2665 2756 2666 2757 (defun ppc2-three-targeted-reg-forms (seg aform areg bform breg cform creg) … … 4149 4240 4150 4241 4151 (defun ppc2-misc-node-set (seg vreg xfer miscobj index value safe) 4152 (with-ppc-local-vinsn-macros (seg vreg xfer) 4153 (let* ((memoize (ppc2-acode-needs-memoization value))) 4154 (if memoize 4155 (multiple-value-bind (src unscaled-idx val-reg) 4156 (ppc2-three-targeted-reg-forms seg miscobj ($ ppc::arg_x) index ($ ppc::arg_y) value ($ ppc::arg_z)) 4157 (when safe 4158 (if (typep safe 'fixnum) 4159 (! trap-unless-typecode= src safe)) 4160 (! trap-unless-fixnum unscaled-idx) 4161 (! check-misc-bound unscaled-idx src)) 4162 (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg) 4163 (<- val-reg) 4164 (^)) 4165 ;; no memoization needed 4166 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 4167 (arch (backend-target-arch *target-backend*)) 4168 (src ) 4169 (unscaled-idx ) 4170 (val-reg )) 4171 (if (or safe (not index-known-fixnum)) 4172 (multiple-value-setq (src unscaled-idx val-reg) 4173 (ppc2-three-untargeted-reg-forms seg miscobj ppc::arg_x index ppc::arg_y value ppc::arg_z)) 4174 (multiple-value-setq (src val-reg) 4175 (ppc2-two-untargeted-reg-forms seg miscobj ppc::arg_y value ppc::arg_z))) 4176 (when safe 4177 (if (typep safe 'fixnum) 4178 (! trap-unless-typecode= src safe)) 4179 (unless index-known-fixnum 4180 (! trap-unless-fixnum unscaled-idx)) 4181 (! check-misc-bound unscaled-idx src)) 4182 (if (and index-known-fixnum (<= index-known-fixnum 4183 (target-word-size-case 4184 (32 (arch::target-max-32-bit-constant-index arch)) 4185 (64 (arch::target-max-64-bit-constant-index arch))))) 4186 (! misc-set-c-node val-reg src index-known-fixnum) 4187 (let* ((idx-reg ppc::imm0)) 4188 (if index-known-fixnum 4189 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *ppc2-target-node-shift*))) 4190 (! scale-node-misc-index idx-reg unscaled-idx)) 4191 (! misc-set-node val-reg src idx-reg))) 4192 (<- val-reg) 4193 (^)))))) 4242 4194 4243 4195 4244 … … 5316 5365 5317 5366 (defppc2 ppc2-%svset %svset (seg vreg xfer vector index value) 5318 (ppc2- misc-node-set seg vreg xfer vector index value nil))5367 (ppc2-vset seg vreg xfer :simple-vector vector index value nil)) 5319 5368 5320 5369 (defppc2 ppc2-svset svset (seg vreg xfer vector index value) 5321 (ppc2-misc-node-set seg vreg xfervector index value (nx-lookup-target-uvector-subtag :simple-vector)))5370 (ppc2-vset seg vreg xfer :simple-vector vector index value (nx-lookup-target-uvector-subtag :simple-vector))) 5322 5371 5323 5372 (defppc2 ppc2-typed-form typed-form (seg vreg xfer typespec form) … … 5513 5562 5514 5563 (defppc2 ppc2-struct-set struct-set (seg vreg xfer struct offset value) 5515 (ppc2- misc-node-set seg vreg xferstruct offset value (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :struct))))5564 (ppc2-vset seg vreg xfer :struct struct offset value (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag :struct)))) 5516 5565 5517 5566 (defppc2 ppc2-istruct-typep istruct-typep (seg vreg xfer cc form type) … … 7399 7448 (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef2))))) ) 7400 7449 7401 (defppc2 ppc2-%aset2 aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1)7450 (defppc2 ppc2-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) 7402 7451 (let* ((type-keyword (ppc2-immediate-operand typename)) 7403 (fixtype (nx-lookup-target-uvector-subtag type-keyword ))7452 (fixtype (nx-lookup-target-uvector-subtag type-keyword )) 7404 7453 (safe (unless *ppc2-reckless* fixtype)) 7405 7454 (dim0 (acode-fixnum-form-p dim0)) 7406 7455 (dim1 (acode-fixnum-form-p dim1))) 7407 (cond ((eq type-keyword :double-float-vector ) 7408 (with-fp-target () (target :double-float) 7409 (<- (ppc2-aset2 seg target arr i j new safe typename dim0 dim1)) 7410 (^))) 7411 ((eq type-keyword :single-float-vector) 7412 (with-fp-target () (target :single-float) 7413 (<- (ppc2-aset2 seg target arr i j new safe typename dim0 dim1)) 7414 (^))) 7456 (ppc2-aset2 seg vreg xfer arr i j new safe type-keyword dim0 dim1)) 7457 ) 7458 7459 (defppc2 ppc2-general-aset2 general-aset2 (seg vreg xfer arr i j new) 7460 (let* ((atype0 (acode-form-type arr t)) 7461 (ctype (if atype0 (specifier-type atype0))) 7462 (atype (if (array-ctype-p ctype) ctype)) 7463 (keyword (and atype 7464 (= 2 (length (array-ctype-dimensions atype))) 7465 (not (array-ctype-complexp atype)) 7466 (funcall 7467 (arch::target-array-type-name-from-ctype-function 7468 (backend-target-arch *target-backend*)) 7469 atype)))) 7470 (cond (keyword 7471 (let* ((dims (array-ctype-dimensions atype)) 7472 (dim0 (car dims)) 7473 (dim1 (cadr dims))) 7474 (ppc2-aset2 seg 7475 vreg 7476 xfer 7477 arr 7478 i 7479 j 7480 new 7481 (unless *ppc2-reckless* 7482 (nx-lookup-target-uvector-subtag keyword )) 7483 keyword 7484 (if (typep dim0 'fixnum) dim0) 7485 (if (typep dim1 'fixnum) dim1)))) 7415 7486 (t 7416 (ppc2-form seg vreg xfer 7417 (make-acode (%nx1-operator call) 7418 (make-acode (%nx1-operator immediate) '%aset2) 7419 (list (list arr) 7420 (list new j i)))))))) 7487 (ppc2-four-targeted-reg-forms seg 7488 arr ($ ppc::temp0) 7489 i ($ ppc::arg_x) 7490 j ($ ppc::arg_y) 7491 new ($ ppc::arg_z)) 7492 (ppc2-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset2)))))) 7493 7421 7494 7422 7495 (defppc2 ppc2-%typed-uvref %typed-uvref (seg vreg xfer subtag uvector index) … … 7442 7515 (if type-keyword 7443 7516 (ppc2-vset seg vreg xfer type-keyword uvector index newval (unless *ppc2-reckless* (nx-lookup-target-uvector-subtag type-keyword))) 7444 (progn ; Could always do a four-targeted-reg-forms ... 7445 (ppc2-vpush-register seg (ppc2-one-untargeted-reg-form seg subtag ppc::arg_z)) 7446 (ppc2-three-targeted-reg-forms seg uvector ($ ppc::arg_x) index ($ ppc::arg_y) newval ($ ppc::arg_z)) 7447 (ppc2-vpop-register seg ($ ppc::temp0)) 7517 (progn 7518 (ppc2-four-targeted-reg-forms seg 7519 subtag ($ ppc::temp0) 7520 uvector ($ ppc::arg_x) 7521 index ($ ppc::arg_y) 7522 newval ($ ppc::arg_z)) 7523 7448 7524 (! subtag-misc-set) 7449 7525 (when vreg (<- ($ ppc::arg_z))) … … 8478 8554 8479 8555 (defppc2 ppc2-global-setq global-setq (seg vreg xfer sym val) 8480 (ppc2- misc-node-set seg8481 vreg8482 xfer8483 (make-acode (%nx1-operator immediate) sym)8484 (make-acode (%nx1-operator fixnum)8485 (target-arch-case8486 8487 (:ppc64 ppc64::symbol.vcell-cell)))8488 8489 8556 (ppc2-vset seg 8557 vreg 8558 xfer 8559 :symbol 8560 (make-acode (%nx1-operator immediate) sym) 8561 (make-acode (%nx1-operator fixnum) 8562 (target-arch-case (:ppc32 ppc32::symbol.vcell-cell) 8563 (:ppc64 ppc64::symbol.vcell-cell))) 8564 val 8565 nil)) 8490 8566 8491 8567 (defppc2 ppc2-%current-frame-ptr %current-frame-ptr (seg vreg xfer)
Note:
See TracChangeset
for help on using the changeset viewer.
