Changeset 5515
- Timestamp:
- Nov 7, 2006, 7:40:12 PM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/compiler/X86/x862.lisp (modified) (13 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/compiler/X86/x862.lisp
r5492 r5515 1439 1439 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1440 1440 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1441 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector : fixnum-vector)))1441 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) 1442 1442 (vreg-class (and (not (eq vreg :push)) (hard-regspec-class vreg))) 1443 1443 (vreg-mode … … 1624 1624 1625 1625 1626 (defun x862-aset2 (seg target array i j new safe typename &optionaldim0 dim1)1626 (defun x862-aset2 (seg vreg xfer array i j new safe type-keyword dim0 dim1) 1627 1627 (with-x86-local-vinsn-macros (seg target) 1628 1628 (let* ((i-known-fixnum (acode-fixnum-form-p i)) 1629 1629 (j-known-fixnum (acode-fixnum-form-p j)) 1630 1630 (arch (backend-target-arch *target-backend*)) 1631 (is-node (member type-keyword (arch::target-gvector-types arch))) 1632 (constval (x862-constant-value-ok-for-type-keyword type-keyword new)) 1633 (needs-memoization (and is-node (x862-acode-needs-memoization new))) 1631 1634 (src) 1632 1635 (unscaled-i) 1633 1636 (unscaled-j) 1634 ( need-scale t)1637 (val-reg (x862-target-reg-for-aset vreg type-keyword)) 1635 1638 (constidx 1636 1639 (and dim0 dim1 i-known-fixnum j-known-fixnum … … 1642 1645 (progn 1643 1646 (if constidx 1644 (multiple-value-setq (src target)1645 (x862-two-targeted-reg-forms seg array ($ x8664:: arg_z) new target))1646 (multiple-value-setq (src unscaled-i unscaled-j target)1647 (multiple-value-setq (src val-reg) 1648 (x862-two-targeted-reg-forms seg array ($ x8664::temp0) new val-reg)) 1649 (multiple-value-setq (src unscaled-i unscaled-j val-reg) 1647 1650 (x862-four-untargeted-reg-forms seg 1648 array ($ x8664:: arg_x)1649 i ($ x8664::arg_ y)1650 j ($ x8664::arg_ z)1651 new target)))1651 array ($ x8664::temp0) 1652 i ($ x8664::arg_x) 1653 j ($ x8664::arg_y) 1654 new val-reg))) 1652 1655 (when safe 1653 1656 (when (typep safe 'fixnum) 1654 (! trap-unless- array-header src)1655 (! check-arrayH-rank src 2)1656 (! check-arrayH-flags src1657 (dpb safe target::arrayh.flags-cell-subtag-byte1658 (ash 1 $arh_simple_bit))))1657 (! trap-unless-simple-array-2 1658 src 1659 (dpb safe target::arrayH.flags-cell-subtag-byte 1660 (ash 1 $arh_simple_bit)) 1661 (nx-error-for-simple-2d-array-type type-keyword))) 1659 1662 (unless i-known-fixnum 1660 1663 (! trap-unless-fixnum unscaled-i)) 1661 1664 (unless j-known-fixnum 1662 1665 (! trap-unless-fixnum unscaled-j))) 1663 (with-imm-t emps () (dim1 idx-reg)1664 ( unless constidx1665 ( if safe1666 ( ! check-2d-bound dim1 unscaled-i unscaled-j src)1667 (! 2d-dim1 dim1 src))1668 (! 2d-unscaled-index idx-reg src unscaled-i unscaled-j dim1))1669 (with-node-temps () (v)1670 (let* (( bias (arch::target-misc-data-offset arch)))1666 (with-imm-target () dim1 1667 (let* ((idx-reg ($ x8664::arg_y))) 1668 (unless constidx 1669 (if safe 1670 (! check-2d-bound dim1 unscaled-i unscaled-j src) 1671 (! 2d-dim1 dim1 src)) 1672 (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j)) 1673 (let* ((v ($ x8664::arg_x))) 1671 1674 (! array-data-vector-ref v src) 1672 (multiple-value-bind (shift limit) 1673 (case typename 1674 (:double-float-vector 1675 (setq bias (arch::target-misc-dfloat-offset arch)) 1676 (values 3 (arch::target-max-64-bit-constant-index arch))) 1677 (:single-float-vector 1678 (values 2 (arch::target-max-32-bit-constant-index arch)))) 1679 (when (and constidx (>= constidx limit)) 1680 (x862-absolute-natural seg idx-reg nil (+ bias 1681 (ash constidx shift))) 1682 (setq constidx nil need-scale nil))) 1683 (case typename 1684 (:double-float-vector 1685 (if constidx 1686 (! misc-set-c-double-float target v constidx) 1687 (progn 1688 (! misc-set-double-float target v idx-reg)))) 1689 (:single-float-vector 1690 (if constidx 1691 (! misc-set-c-single-float target v constidx) 1692 (progn 1693 (when need-scale (! scale-32bit-misc-index idx-reg idx-reg)) 1694 (! misc-set-single-float target v idx-reg))))))))))) 1695 target) 1675 (x862-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (x862-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization)))))))) 1696 1676 1697 1677 … … 1775 1755 1776 1756 (defun x862-constant-value-ok-for-type-keyword (type-keyword form) 1777 (if (and (acode-p form) 1778 (or (eq (acode-operator form) (%nx1-operator immediate)) 1779 (eq (acode-operator form) (%nx1-operator fixnum)))) 1780 (let* ((val (%cadr form)) 1781 (typep (cond ((eq type-keyword :signed-32-bit-vector) 1782 (typep val '(signed-byte 32))) 1783 ((eq type-keyword :single-float-vector) 1784 (typep val 'short-float)) 1785 ((eq type-keyword :double-float-vector) 1786 (typep val 'double-float)) 1787 ((eq type-keyword :simple-string) 1788 (typep val 'base-char)) 1789 ((eq type-keyword :signed-8-bit-vector) 1790 (typep val '(signed-byte 8))) 1791 ((eq type-keyword :unsigned-8-bit-vector) 1792 (typep val '(unsigned-byte 8))) 1793 ((eq type-keyword :signed-16-bit-vector) 1794 (typep val '(signed-byte 16))) 1795 ((eq type-keyword :unsigned-16-bit-vector) 1796 (typep val '(unsigned-byte 16))) 1797 ((eq type-keyword :bit-vector) 1798 (typep val 'bit))))) 1799 (if typep val)))) 1800 1801 #|| 1802 ;;; Caller has to have handled node case specially, may also have wanted to have 1803 ;;; targeted the value to a specific register. 1804 (defun x862-vset1 (seg vreg xfer type-keyword vector index-reg index-known-fixnum val-reg constval) 1757 (let* ((arch (backend-target-arch *target-backend*)) 1758 (is-node (member type-keyword (arch::target-gvector-types arch)))) 1759 (if is-node 1760 (cond ((eq form *nx-nil*) 1761 (arch::target-nil-value arch)) 1762 ((eq form *nx-t*) 1763 (+ (arch::target-nil-value arch) (arch::target-t-offset arch))) 1764 (t 1765 (let* ((fixval (acode-fixnum-form-p form))) 1766 (if fixval 1767 (ash fixval (arch::target-fixnum-shift arch)))))) 1768 (if (and (acode-p form) 1769 (or (eq (acode-operator form) (%nx1-operator immediate)) 1770 (eq (acode-operator form) (%nx1-operator fixnum)))) 1771 (let* ((val (%cadr form)) 1772 1773 (typep (cond ((eq type-keyword :signed-32-bit-vector) 1774 (typep val '(signed-byte 32))) 1775 ((eq type-keyword :single-float-vector) 1776 (typep val 'short-float)) 1777 ((eq type-keyword :double-float-vector) 1778 (typep val 'double-float)) 1779 ((eq type-keyword :simple-string) 1780 (typep val 'base-char)) 1781 ((eq type-keyword :signed-8-bit-vector) 1782 (typep val '(signed-byte 8))) 1783 ((eq type-keyword :unsigned-8-bit-vector) 1784 (typep val '(unsigned-byte 8))) 1785 ((eq type-keyword :signed-16-bit-vector) 1786 (typep val '(signed-byte 16))) 1787 ((eq type-keyword :unsigned-16-bit-vector) 1788 (typep val '(unsigned-byte 16))) 1789 ((eq type-keyword :bit-vector) 1790 (typep val 'bit))))) 1791 (if typep val)))))) 1792 1793 (defun x862-target-reg-for-aset (vreg type-keyword) 1805 1794 (let* ((arch (backend-target-arch *target-backend*)) 1806 1795 (is-node (member type-keyword (arch::target-gvector-types arch))) … … 1809 1798 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1810 1799 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1811 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))) 1812 (cond (is-node 1813 (! misc-set-node val-reg vector index-reg) 1814 )))) 1815 ||# 1816 1817 (defun x862-vset (seg vreg xfer type-keyword vector index value safe) 1818 (let* ((arch (backend-target-arch *target-backend*)) 1819 (is-node (member type-keyword (arch::target-gvector-types arch))) 1820 (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) 1821 (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) 1822 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1823 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1824 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))) 1825 (if is-node 1826 (x862-misc-node-set seg vreg xfer vector index value safe) 1827 (let* ((vreg-class (if vreg (hard-regspec-class vreg))) 1828 (vreg-mode 1829 (if (and vreg-class (= vreg-class hard-reg-class-gpr)) 1830 (get-regspec-mode vreg) 1831 hard-reg-class-gpr-mode-invalid))) 1832 (declare (fixnum vreg-class vreg-mode)) 1833 (if (and (eq type-keyword :double-float-vector) 1834 (or (null vreg) (eql vreg-class hard-reg-class-fpr))) 1835 (x862-df-vset seg vreg xfer vector index value safe) 1836 (if (and (eq type-keyword :single-float-vector) 1837 (or (null vreg) (eql vreg-class hard-reg-class-fpr))) 1838 (x862-sf-vset seg vreg xfer vector index value safe) 1839 (if (target-arch-case 1840 (:x8664 (and (eq type-keyword :unsigned-64-bit-vector) 1841 (or (null vreg) (eql vreg-mode hard-reg-class-gpr-mode-u64))))) 1842 (x862-natural-vset seg vreg xfer vector index value safe) 1843 (with-x86-local-vinsn-macros (seg vreg xfer) 1844 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 1845 (constval (x862-constant-value-ok-for-type-keyword type-keyword value)) 1846 (need-val-reg (or vreg (not constval))) 1847 (unscaled-idx nil) 1848 (idx-reg nil) 1849 (val-reg) 1850 (src nil)) 1851 (if (or safe (not index-known-fixnum)) 1852 (if need-val-reg 1853 (multiple-value-setq (src unscaled-idx val-reg) 1854 (x862-three-untargeted-reg-forms seg vector x8664::arg_x index x8664::arg_y value x8664::arg_z)) 1855 (multiple-value-setq (src unscaled-idx) 1856 (x862-two-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z))) 1857 (if need-val-reg 1858 (multiple-value-setq (src val-reg) 1859 (x862-two-untargeted-reg-forms seg vector x8664::arg_y value x8664::arg_z)) 1860 (setq src (x862-one-untargeted-reg-form seg vector x8664::arg_z)))) 1861 (when safe 1862 (if (typep safe 'fixnum) 1863 (! trap-unless-typecode= src safe)) 1864 (unless index-known-fixnum 1865 (! trap-unless-fixnum unscaled-idx)) 1866 (! check-misc-bound unscaled-idx src)) 1867 (if is-1-bit 1868 ;; bit-vector case. 1869 ;; It's easiest to do this when the bitnumber is 1870 ;; known (and a little easier still 1871 ;; if the value's known.) 1872 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) 1800 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1801 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) 1802 (vreg-class (if (and vreg (not (eq vreg :push))) (hard-regspec-class vreg))) 1803 (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr) 1804 (eql vreg-class hard-reg-class-fpr)) 1805 (get-regspec-mode vreg))) 1806 (next-imm-target (available-imm-temp *available-backend-imm-temps*)) 1807 (next-fp-target (available-fp-temp *available-backend-fp-temps*)) 1808 (acc (make-wired-lreg x8664::arg_z))) 1809 (cond ((or is-node 1810 (eq vreg :push) 1811 is-1-bit 1812 (eq type-keyword :simple-string) 1813 (eq type-keyword :fixnum-vector) 1814 (and (eql vreg-class hard-reg-class-gpr) 1815 (eql vreg-mode hard-reg-class-gpr-mode-node))) 1816 acc) 1817 ;; If there's no vreg - if we're setting for effect only, and 1818 ;; not for value - we can target an unboxed register directly. 1819 ;; Usually. 1820 ((null vreg) 1821 (cond (is-64-bit 1822 (if (eq type-keyword :double-float-vector) 1823 (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double) 1824 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64)))) 1825 (is-32-bit 1826 (if (eq type-keyword :single-float-vector) 1827 (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single) 1828 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32)))) 1829 (is-16-bit 1830 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16))) 1831 (is-8-bit 1832 (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8))) 1833 (t "Bug: can't determine operand size for ~s" type-keyword))) 1834 ;; Vreg is non-null. We might be able to use it directly. 1835 (t 1836 (let* ((lreg (if vreg-mode 1837 (make-unwired-lreg (lreg-value vreg))))) 1838 (if 1839 (cond 1840 (is-64-bit 1841 (if (eq type-keyword :double-float-vector) 1842 (and (eql vreg-class hard-reg-class-fpr) 1843 (eql vreg-mode hard-reg-class-fpr-mode-double)) 1844 (if is-signed 1845 (and (eql vreg-class hard-reg-class-gpr) 1846 (eql vreg-mode hard-reg-class-gpr-mode-s64)) 1847 (and (eql vreg-class hard-reg-class-gpr) 1848 (eql vreg-mode hard-reg-class-gpr-mode-u64))))) 1849 (is-32-bit 1850 (if (eq type-keyword :single-float-vector) 1851 (and (eql vreg-class hard-reg-class-fpr) 1852 (eql vreg-mode hard-reg-class-fpr-mode-single)) 1853 (if is-signed 1854 (and (eql vreg-class hard-reg-class-gpr) 1855 (or (eql vreg-mode hard-reg-class-gpr-mode-s32) 1856 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1857 (and (eql vreg-class hard-reg-class-gpr) 1858 (or (eql vreg-mode hard-reg-class-gpr-mode-u32) 1859 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1860 (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) 1861 (is-16-bit 1862 (if is-signed 1863 (and (eql vreg-class hard-reg-class-gpr) 1864 (or (eql vreg-mode hard-reg-class-gpr-mode-s16) 1865 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1866 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1867 (and (eql vreg-class hard-reg-class-gpr) 1868 (or (eql vreg-mode hard-reg-class-gpr-mode-u16) 1869 (eql vreg-mode hard-reg-class-gpr-mode-u32) 1870 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1871 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1872 (eql vreg-mode hard-reg-class-gpr-mode-s64))))) 1873 (t 1874 (if is-signed 1875 (and (eql vreg-class hard-reg-class-gpr) 1876 (or (eql vreg-mode hard-reg-class-gpr-mode-s8) 1877 (eql vreg-mode hard-reg-class-gpr-mode-s16) 1878 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1879 (eql vreg-mode hard-reg-class-gpr-mode-s64))) 1880 (and (eql vreg-class hard-reg-class-gpr) 1881 (or (eql vreg-mode hard-reg-class-gpr-mode-u8) 1882 (eql vreg-mode hard-reg-class-gpr-mode-u16) 1883 (eql vreg-mode hard-reg-class-gpr-mode-u32) 1884 (eql vreg-mode hard-reg-class-gpr-mode-u64) 1885 (eql vreg-mode hard-reg-class-gpr-mode-s16) 1886 (eql vreg-mode hard-reg-class-gpr-mode-s32) 1887 (eql vreg-mode hard-reg-class-gpr-mode-s64)))))) 1888 lreg 1889 acc)))))) 1890 1891 (defun x862-unboxed-reg-for-aset (seg type-keyword result-reg safe constval) 1892 (with-x86-local-vinsn-macros (seg) 1893 (let* ((arch (backend-target-arch *target-backend*)) 1894 (is-node (member type-keyword (arch::target-gvector-types arch))) 1895 (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) 1896 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1897 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1898 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1899 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))) 1900 (result-is-node-gpr (and (eql (hard-regspec-class result-reg) 1901 hard-reg-class-gpr) 1902 (eql (get-regspec-mode result-reg) 1903 hard-reg-class-gpr-mode-node))) 1904 (next-imm-target (available-imm-temp *available-backend-imm-temps*)) 1905 (next-fp-target (available-fp-temp *available-backend-fp-temps*))) 1906 (if (or is-node (not result-is-node-gpr)) 1907 result-reg 1908 (cond (is-64-bit 1909 (if (eq type-keyword :double-float-vector) 1910 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double))) 1911 (if safe 1912 (! get-double? reg result-reg) 1913 (! get-double reg result-reg)) 1914 reg) 1915 (if is-signed 1916 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s64))) 1917 (if (eq type-keyword :fixnum-vector) 1918 (progn 1919 (when safe 1920 (! trap-unless-fixnum result-reg)) 1921 (! fixnum->signed-natural reg result-reg)) 1922 (! unbox-s64 reg result-reg)) 1923 reg) 1924 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u64))) 1925 (! unbox-u64 reg result-reg) 1926 reg)))) 1927 (is-32-bit 1928 ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR 1929 ;; case here. 1930 (if is-signed 1931 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32))) 1932 (if (eq type-keyword :fixnum-vector) 1933 (progn 1934 (when safe 1935 (! trap-unless-fixnum result-reg)) 1936 (! fixnum->signed-natural reg result-reg)) 1937 (! unbox-s32 reg result-reg)) 1938 reg) 1939 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32))) 1940 (cond ((eq type-keyword :simple-string) 1941 (if (characterp constval) 1942 (x862-lri seg reg (char-code constval)) 1943 (! unbox-base-char reg result-reg))) 1944 ((eq type-keyword :single-float-vector) 1945 (if (typep constval 'single-float) 1946 (x862-lri seg reg (single-float-bits constval)) 1947 (progn 1948 (when safe 1949 (! trap-unless-single-float result-reg)) 1950 (! single-float-bits reg result-reg)))) 1951 (t 1952 (if (typep constval '(unsigned-byte 32)) 1953 (x862-lri seg reg constval) 1954 (! unbox-u32 reg result-reg)))) 1955 reg))) 1956 (is-16-bit 1957 (if is-signed 1958 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16))) 1959 (if (typep constval '(signed-byte 16)) 1960 (x862-lri seg reg constval) 1961 (! unbox-s16 reg result-reg)) 1962 reg) 1963 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16))) 1964 (if (typep constval '(unsigned-byte 16)) 1965 (x862-lri seg reg constval) 1966 (! unbox-u16 reg result-reg)) 1967 reg))) 1968 (is-8-bit 1969 (if is-signed 1970 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8))) 1971 (if (typep constval '(signed-byte 8)) 1972 (x862-lri seg reg constval) 1973 (! unbox-s8 reg result-reg)) 1974 reg) 1975 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) 1976 (if (typep constval '(unsigned-byte 8)) 1977 (x862-lri seg reg constval) 1978 (! unbox-u8 reg result-reg)) 1979 reg))) 1980 (t 1981 (let* ((reg result-reg)) 1982 (unless (typep constval 'bit) 1983 (when safe 1984 (! trap-unless-bit reg ))) 1985 reg))))))) 1986 1987 (defun x862-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval node-value-needs-memoization) 1988 (with-x86-local-vinsn-macros (seg vreg xfer) 1989 (let* ((arch (backend-target-arch *target-backend*)) 1990 (is-node (member type-keyword (arch::target-gvector-types arch))) 1991 (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch))) 1992 (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch))) 1993 (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch))) 1994 (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch))) 1995 (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch))) 1996 (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))) 1997 (cond ((and is-node node-value-needs-memoization) 1998 (unless (and (eql (hard-regspec-value src) x8664::arg_x) 1999 (eql (hard-regspec-value unscaled-idx) x8664::arg_y) 2000 (eql (hard-regspec-value val-reg) x8664::arg_z)) 2001 (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg))) 2002 (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg)) 2003 (is-node 2004 (if (and index-known-fixnum (<= index-known-fixnum 2005 (target-word-size-case 2006 (32 (arch::target-max-32-bit-constant-index arch)) 2007 (64 (arch::target-max-64-bit-constant-index arch))))) 2008 (if (typep constval '(signed-byte 32)) 2009 (! misc-set-immediate-c-node constval src index-known-fixnum) 2010 (! misc-set-c-node val-reg src index-known-fixnum)) 2011 (progn 2012 (if index-known-fixnum 2013 (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *x862-target-node-shift*)))) 2014 (if (typep constval '(signed-byte 32)) 2015 (! misc-set-immediate-node constval src unscaled-idx) 2016 (! misc-set-node val-reg src unscaled-idx))))) 2017 (t 2018 (with-imm-target (unboxed-val-reg) scaled-idx 2019 (cond 2020 (is-64-bit 2021 (if (and index-known-fixnum 2022 (<= index-known-fixnum 2023 (arch::target-max-64-bit-constant-index arch))) 2024 (if (eq type-keyword :double-float-vector) 2025 (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum) 2026 (if is-signed 2027 (! misc-set-c-s64 unboxed-val-reg src index-known-fixnum) 2028 (! misc-set-c-u64 unboxed-val-reg src index-known-fixnum))) 2029 (progn 2030 (if index-known-fixnum 2031 (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))) 2032 (if (eq type-keyword :double-float-vector) 2033 (! misc-set-double-float unboxed-val-reg src unscaled-idx) 2034 (if is-signed 2035 (! misc-set-s64 unboxed-val-reg src unscaled-idx) 2036 (! misc-set-u64 unboxed-val-reg src unscaled-idx)))))) 2037 (is-32-bit 2038 (if (and index-known-fixnum 2039 (<= index-known-fixnum 2040 (arch::target-max-32-bit-constant-index arch))) 2041 (if (eq type-keyword :single-float-vector) 2042 (if (eq (hard-regspec-class unboxed-val-reg) 2043 hard-reg-class-fpr) 2044 (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum) 2045 (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)) 2046 (if is-signed 2047 (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum) 2048 (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))) 2049 (progn 2050 (if index-known-fixnum 2051 (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 2052 (! scale-32bit-misc-index scaled-idx unscaled-idx)) 2053 (if (and (eq type-keyword :single-float-vector) 2054 (eql (hard-regspec-class unboxed-val-reg) 2055 hard-reg-class-fpr)) 2056 (! misc-set-single-float unboxed-val-reg src scaled-idx) 2057 (if is-signed 2058 (! misc-set-s32 unboxed-val-reg src scaled-idx) 2059 (! misc-set-u32 unboxed-val-reg src scaled-idx)))))) 2060 (is-16-bit 2061 (if (and index-known-fixnum 2062 (<= index-known-fixnum 2063 (arch::target-max-16-bit-constant-index arch))) 2064 (if is-signed 2065 (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum) 2066 (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum)) 2067 (progn 2068 (if index-known-fixnum 2069 (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 2070 (! scale-16bit-misc-index scaled-idx unscaled-idx)) 2071 (if is-signed 2072 (! misc-set-s16 unboxed-val-reg src scaled-idx) 2073 (! misc-set-u16 unboxed-val-reg src scaled-idx))))) 2074 (is-8-bit 2075 (if (and index-known-fixnum 2076 (<= index-known-fixnum 2077 (arch::target-max-8-bit-constant-index arch))) 2078 (if is-signed 2079 (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum) 2080 (! misc-set-c-u8 unboxed-val-reg src index-known-fixnum)) 2081 (progn 2082 (if index-known-fixnum 2083 (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 2084 (! scale-8bit-misc-index scaled-idx unscaled-idx)) 2085 (if is-signed 2086 (! misc-set-s8 unboxed-val-reg src scaled-idx) 2087 (! misc-set-u8 unboxed-val-reg src scaled-idx))))) 2088 (is-1-bit 2089 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) 2090 (if constval 2091 (if (zerop constval) 2092 (! set-constant-bit-to-zero src index-known-fixnum) 2093 (! set-constant-bit-to-one src index-known-fixnum)) 2094 (progn 2095 (! set-constant-bit-to-variable-value src index-known-fixnum val-reg))) 2096 (with-imm-temps () (word-index bit-number) 2097 (if index-known-fixnum 2098 (progn 2099 (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) 2100 (x862-lri seg bit-number (logand index-known-fixnum #x63))) 2101 (! word-index-and-bitnum-from-index word-index bit-number unscaled-idx)) 1873 2102 (if constval 1874 2103 (if (zerop constval) 1875 (! set- constant-bit-to-zero src index-known-fixnum)1876 (! set- constant-bit-to-one src index-known-fixnum))2104 (! set-variable-bit-to-zero src word-index bit-number) 2105 (! set-variable-bit-to-one src word-index bit-number)) 1877 2106 (progn 1878 (if safe 1879 (! trap-unless-bit val-reg)) 1880 (! set-constant-bit-to-variable-value src index-known-fixnum val-reg))) 1881 (with-imm-temps () (word-index bit-number) 1882 (if index-known-fixnum 1883 (progn 1884 (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) 1885 (x862-lri seg bit-number (logand index-known-fixnum #x63))) 1886 (! word-index-and-bitnum-from-index word-index bit-number unscaled-idx)) 1887 (if constval 1888 (if (zerop constval) 1889 (! set-variable-bit-to-zero src word-index bit-number) 1890 (! set-variable-bit-to-one src word-index bit-number)) 1891 (progn 1892 (if safe 1893 (! trap-unless-bit val-reg)) 1894 (! set-variable-bit-to-variable-value src word-index bit-number val-reg))))) 1895 (with-imm-temps () (temp) 1896 (cond (is-32-bit 1897 (if constval 1898 (x862-lri seg temp 1899 (if (typep constval 'single-float) 1900 (x862-single-float-bits constval) 1901 (if (typep constval 'character) 1902 (char-code constval) 1903 constval))) 1904 (cond ((eq type-keyword :single-float-vector) 1905 (when safe 1906 (! trap-unless-single-float val-reg)) 1907 (! single-float-bits temp val-reg)) 1908 ((eq type-keyword :signed-32-bit-vector) 1909 (! unbox-s32 temp val-reg)) 1910 ((eq type-keyword :simple-string) 1911 (! unbox-base-char temp val-reg)) 1912 (t 1913 (! unbox-u32 temp val-reg)))) 1914 (if (and index-known-fixnum 1915 (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) 1916 (! misc-set-c-u32 temp src index-known-fixnum) 1917 (progn 1918 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1919 (if index-known-fixnum 1920 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 1921 (! scale-32bit-misc-index idx-reg unscaled-idx)) 1922 (! misc-set-u32 temp src idx-reg)))) 1923 (is-8-bit 1924 (if constval 1925 (x862-lri seg temp (if (characterp constval) (char-code constval) constval)) 1926 (if safe 1927 (cond ((eq type-keyword :simple-string) 1928 (! unbox-base-char temp val-reg)) 1929 ((eq type-keyword :signed-8-bit-vector) 1930 (! unbox-s8 temp val-reg)) 1931 (t 1932 (! unbox-u8 temp val-reg))) 1933 (if (eq type-keyword :simple-string) 1934 (! character->code temp val-reg) 1935 (! fixnum->unsigned-natural temp val-reg)))) 1936 (if (and index-known-fixnum 1937 (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch))) 1938 (! misc-set-c-u8 temp src index-known-fixnum) 1939 (progn 1940 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1941 (if index-known-fixnum 1942 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 1943 (! scale-8bit-misc-index idx-reg unscaled-idx)) 1944 (! misc-set-u8 temp src idx-reg)))) 1945 (is-16-bit 1946 (if constval 1947 (x862-lri seg temp (if (characterp constval) (char-code constval) constval)) 1948 (if safe 1949 (cond ((eq type-keyword :signed-16-bit-vector) 1950 (! unbox-s16 temp val-reg)) 1951 (t 1952 (! unbox-u16 temp val-reg))) 1953 (! fixnum->unsigned-natural temp val-reg))) 1954 (if (and index-known-fixnum 1955 (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch))) 1956 (! misc-set-c-u16 temp src index-known-fixnum) 1957 (progn 1958 (setq idx-reg (make-unwired-lreg (select-imm-temp :natural))) 1959 (if index-known-fixnum 1960 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 1961 (! scale-16bit-misc-index idx-reg unscaled-idx)) 1962 (! misc-set-u16 temp src idx-reg)))) 1963 (is-64-bit 1964 (ecase type-keyword 1965 (:double-float-vector 1966 (if safe 1967 (! get-double? x8664::fp1 val-reg) 1968 (! get-double x8664::fp1 val-reg)) 1969 (if (and index-known-fixnum 1970 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1971 (! misc-set-c-double-float x8664::fp1 src index-known-fixnum) 1972 (progn 1973 (if index-known-fixnum 1974 (progn 1975 (setq idx-reg temp) 1976 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))) 1977 (setq idx-reg unscaled-idx)) 1978 (! misc-set-double-float x8664::fp1 src idx-reg)))) 1979 ((:signed-64-bit-vector :fixnum-vector) 1980 (with-imm-target (temp) (s64 :s64) 1981 (if (eq type-keyword :fixnum-vector) 1982 (progn 1983 (when safe 1984 (! trap-unless-fixnum val-reg) 1985 (! fixnum->signed-natural s64 val-reg))) 1986 (! unbox-s64 s64 val-reg)) 1987 (if (and index-known-fixnum 1988 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 1989 (! misc-set-c-s64 s64 src index-known-fixnum) 1990 (progn 1991 (if index-known-fixnum 1992 (progn 1993 (setq idx-reg temp) 1994 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))) 1995 (setq idx-reg unscaled-idx)) 1996 (! misc-set-s64 s64 src idx-reg))))) 1997 (:unsigned-64-bit-vector 1998 (with-imm-target (temp) (u64 :u64) 1999 (! unbox-u64 u64 val-reg) 2000 (if (and index-known-fixnum 2001 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 2002 (! misc-set-c-u64 u64 src index-known-fixnum) 2003 (progn 2004 (if index-known-fixnum 2005 (progn 2006 (setq idx-reg temp) 2007 2008 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))) 2009 (setq idx-reg unscaled-idx)) 2010 (! misc-set-u64 u64 src idx-reg))))) 2011 )) 2012 (t 2013 (nx-error "~& unsupported vector type: ~s" 2014 type-keyword))))) 2015 (when vreg (<- val-reg))) 2016 (^))))))))) 2017 2018 2019 ;;; In this case, the destination (vreg) is either an FPR or null, so 2020 ;;; we can maybe avoid boxing the value. 2021 (defun x862-df-vset (seg vreg xfer vector index value safe) 2022 (with-x86-local-vinsn-macros (seg vreg xfer) 2023 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 2024 (arch (backend-target-arch *target-backend*)) 2025 (src nil) 2026 (unscaled-idx nil)) 2027 (with-fp-target () fp-val 2028 (if (or safe (not index-known-fixnum)) 2029 (multiple-value-setq (src unscaled-idx fp-val) 2030 (x862-three-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z value (or vreg fp-val))) 2031 (multiple-value-setq (src fp-val) 2032 (x862-two-untargeted-reg-forms seg vector x8664::arg_z value (or vreg fp-val)))) 2107 (! set-variable-bit-to-variable-value src word-index bit-number val-reg)))))))))) 2108 (when (and vreg val-reg) (<- val-reg)) 2109 (^)))) 2110 2111 2112 2113 (defun x862-vset (seg vreg xfer type-keyword vector index value safe) 2114 (with-x86-local-vinsn-macros (seg) 2115 (let* ((arch (backend-target-arch *target-backend*)) 2116 (is-node (member type-keyword (arch::target-gvector-types arch))) 2117 (constval (x862-constant-value-ok-for-type-keyword type-keyword value)) 2118 (needs-memoization (and is-node (x862-acode-needs-memoization value))) 2119 (index-known-fixnum (acode-fixnum-form-p index))) 2120 (let* ((src ($ x8664::arg_x)) 2121 (unscaled-idx ($ x8664::arg_y)) 2122 (result-reg ($ x8664::arg_z))) 2123 (cond (needs-memoization 2124 (x862-three-targeted-reg-forms seg 2125 vector src 2126 index unscaled-idx 2127 value result-reg)) 2128 (t 2129 (setq result-reg (x862-target-reg-for-aset vreg type-keyword)) 2130 (x862-three-targeted-reg-forms seg 2131 vector src 2132 index unscaled-idx 2133 value result-reg))) 2033 2134 (when safe 2135 (let* ((*available-backend-imm-temps* *available-backend-imm-temps*) 2136 (value (if (eql (hard-regspec-class result-reg) 2137 hard-reg-class-gpr) 2138 (hard-regspec-value result-reg)))) 2139 (when (and value (logbitp value *available-backend-imm-temps*)) 2140 (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*))) 2034 2141 (if (typep safe 'fixnum) 2035 2142 (! trap-unless-typecode= src safe)) 2036 2143 (unless index-known-fixnum 2037 2144 (! trap-unless-fixnum unscaled-idx)) 2038 (! check-misc-bound unscaled-idx src)) 2039 (if (and index-known-fixnum 2040 (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch))) 2041 (! misc-set-c-double-float fp-val src index-known-fixnum) 2042 (progn 2043 (if index-known-fixnum 2044 (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3)))) 2045 (! misc-set-double-float fp-val src unscaled-idx))) 2046 (<- fp-val) ; should be a no-op in this case 2047 (^))))) 2048 2049 (defun x862-sf-vset (seg vreg xfer vector index value safe) 2050 (with-x86-local-vinsn-macros (seg vreg xfer) 2051 (let* ((index-known-fixnum (acode-fixnum-form-p index)) 2052 (arch (backend-target-arch *target-backend*)) 2053 (src nil) 2054 (unscaled-idx nil)) 2055 (with-fp-target () (fp-val :single-float) 2056 (if (or safe (not index-known-fixnum)) 2057 (multiple-value-setq (src unscaled-idx fp-val) 2058 (x862-three-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z value (or vreg fp-val))) 2059 (multiple-value-setq (src fp-val) 2060 (x862-two-untargeted-reg-forms seg vector x8664::arg_z value (or vreg fp-val)))) 2061 (when safe 2062 (if (typep safe 'fixnum) 2063 (! trap-unless-typecode= src safe)) 2064 (unless index-known-fixnum 2065 (! trap-unless-fixnum unscaled-idx)) 2066 (! check-misc-bound unscaled-idx src)) 2067 (if (and index-known-fixnum 2068 (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch))) 2069 (! misc-set-c-single-float fp-val src index-known-fixnum) 2070 (with-imm-temps () (idx-reg) 2071 (if index-known-fixnum 2072 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 2073 (! scale-32bit-misc-index idx-reg unscaled-idx)) 2074 (! misc-set-single-float fp-val src idx-reg))) 2075 (<- fp-val) ; should be a no-op in this case 2076 (^))))) 2145 (! check-misc-bound unscaled-idx src))) 2146 (x862-vset1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum result-reg (x862-unboxed-reg-for-aset seg type-keyword result-reg safe constval) constval needs-memoization))))) 2147 2077 2148 2078 2149 … … 2759 2830 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) 2760 2831 (x862-one-targeted-reg-form seg cform creg) 2832 (unless btriv 2833 (if bconst 2834 (x862-one-targeted-reg-form seg bform breg) 2835 (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) 2836 (unless atriv 2837 (if aconst 2838 (x862-one-targeted-reg-form seg aform areg) 2839 (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) 2840 (values areg breg creg))) 2841 2842 (defun x862-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg) 2843 (unless (typep areg 'lreg) 2844 (warn "~s is not an lreg (1/4)" areg)) 2845 (unless (typep breg 'lreg) 2846 (warn "~s is not an lreg (2/4)" breg)) 2847 (unless (typep creg 'lreg) 2848 (warn "~s is not an lreg (3/4)" creg)) 2849 (unless (typep dreg 'lreg) 2850 (warn "~s is not an lreg (4/4)" dreg)) 2851 (let* ((atriv (or (null aform) 2852 (and (x862-trivial-p bform) 2853 (x862-trivial-p cform) 2854 (x862-trivial-p dform)))) 2855 (btriv (or (null bform) 2856 (and (x862-trivial-p cform) 2857 (x862-trivial-p dform)))) 2858 (ctriv (or (null cform) 2859 (x862-trivial-p dform))) 2860 (aconst (and (not atriv) 2861 (or (x86-side-effect-free-form-p aform) 2862 (let ((avar (x862-lexical-reference-p aform))) 2863 (and avar 2864 (x862-var-not-set-by-form-p avar bform) 2865 (x862-var-not-set-by-form-p avar cform) 2866 (x862-var-not-set-by-form-p avar dform)))))) 2867 (bconst (and (not btriv) 2868 (or 2869 (x86-side-effect-free-form-p bform) 2870 (let ((bvar (x862-lexical-reference-p bform))) 2871 (and bvar 2872 (x862-var-not-set-by-form-p bvar cform) 2873 (x862-var-not-set-by-form-p bvar dform)))))) 2874 (cconst (and (not ctriv) 2875 (or 2876 (x86-side-effect-free-form-p cform) 2877 (let ((cvar (x862-lexical-reference-p cform))) 2878 (and cvar (x862-var-not-set-by-form-p cvar dform)))))) 2879 (apushed nil) 2880 (bpushed nil) 2881 (cpushed nil)) 2882 (if (and aform (not aconst)) 2883 (if atriv 2884 (x862-one-targeted-reg-form seg aform areg) 2885 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 2886 (if (and bform (not bconst)) 2887 (if btriv 2888 (x862-one-targeted-reg-form seg bform breg) 2889 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) 2890 (if (and cform (not cconst)) 2891 (if ctriv 2892 (x862-one-targeted-reg-form seg cform creg) 2893 (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) 2894 (x862-one-targeted-reg-form seg dform dreg) 2895 (unless ctriv 2896 (if cconst 2897 (x862-one-targeted-reg-form seg cform creg) 2898 (x862-elide-pushes seg cpushed (x862-pop-register seg creg)))) 2761 2899 (unless btriv 2762 2900 (if bconst … … 4074 4212 4075 4213 4076 (defun x862-misc-node-set (seg vreg xfer miscobj index value safe)4077 (with-x86-local-vinsn-macros (seg vreg xfer)4078 (let* ((memoize (x862-acode-needs-memoization value)))4079 (if memoize4080 (multiple-value-bind (src unscaled-idx val-reg)4081 (x862-three-targeted-reg-forms seg miscobj ($ x8664::arg_x) index ($ x8664::arg_y) value ($ x8664::arg_z))4082 (when safe4083 (if (typep safe 'fixnum)4084 (! trap-unless-typecode= src safe))4085 (! trap-unless-fixnum unscaled-idx)4086 (! check-misc-bound unscaled-idx src))4087 (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg)4088 (<- val-reg)4089 (^))4090 ;; no memoization needed4091 (let* ((index-known-fixnum (acode-fixnum-form-p index))4092 (arch (backend-target-arch *target-backend*))4093 (src )4094 (unscaled-idx )4095 (val-reg ))4096 (if (or safe (not index-known-fixnum))4097 (multiple-value-setq (src unscaled-idx val-reg)4098 (x862-three-untargeted-reg-forms seg miscobj x8664::arg_x index x8664::arg_y value x8664::arg_z))4099 (multiple-value-setq (src val-reg)4100 (x862-two-untargeted-reg-forms seg miscobj x8664::arg_y value x8664::arg_z)))4101 (when safe4102 (if (typep safe 'fixnum)4103 (! trap-unless-typecode= src safe))4104 (unless index-known-fixnum4105 (! trap-unless-fixnum unscaled-idx))4106 (! check-misc-bound unscaled-idx src))4107 (if (and index-known-fixnum (<= index-known-fixnum4108 (target-word-size-case4109 (32 (arch::target-max-32-bit-constant-index arch))4110 (64 (arch::target-max-64-bit-constant-index arch)))))4111 (! misc-set-c-node val-reg src index-known-fixnum)4112 (let* ((idx-reg x8664::imm0))4113 (if index-known-fixnum4114 (x862-absolute-natural seg idx-reg nil (ash index-known-fixnum *x862-target-node-shift*)))4115 4116 (! misc-set-node val-reg src unscaled-idx)))4117 (<- val-reg)4118 (^))))))4119 4120 4121 4214 4122 4215 (defun x862-misc-byte-count (subtag element-count) … … 5439 5532 5440 5533 (defx862 x862-%svset %svset (seg vreg xfer vector index value) 5441 (x862- misc-node-set seg vreg xfer vector index value nil))5534 (x862-vset seg vreg xfer :simple-vector vector index value nil)) 5442 5535 5443 5536 (defx862 x862-svset svset (seg vreg xfer vector index value) 5444 (x862- misc-node-set seg vreg xfer vectorindex value (nx-lookup-target-uvector-subtag :simple-vector)))5537 (x862-vset seg vreg xfer :simple-vector vector index value (nx-lookup-target-uvector-subtag :simple-vector))) 5445 5538 5446 5539 (defx862 x862-typed-form typed-form (seg vreg xfer typespec form) … … 5631 5724 5632 5725 (defx862 x862-struct-set struct-set (seg vreg xfer struct offset value) 5633 (x862- misc-node-set seg vreg xferstruct offset value (unless *x862-reckless* (nx-lookup-target-uvector-subtag :struct))))5726 (x862-vset seg vreg xfer :struct struct offset value (unless *x862-reckless* (nx-lookup-target-uvector-subtag :struct)))) 5634 5727 5635 5728 (defx862 x862-istruct-typep istruct-typep (seg vreg xfer cc form type) … … 7539 7632 (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SParef2)))))) 7540 7633 7541 7542 (defx862 x862-%aset2 aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) 7543 (let* ((fixtype (nx-lookup-target-uvector-subtag typename )) 7634 (defx862 x862-general-aset2 general-aset2 (seg vreg xfer arr i j new) 7635 (let* ((atype0 (acode-form-type arr t)) 7636 (ctype (if atype0 (specifier-type atype0))) 7637 (atype (if (array-ctype-p ctype) ctype)) 7638 (keyword (and atype 7639 (= 2 (length (array-ctype-dimensions atype))) 7640 (not (array-ctype-complexp atype)) 7641 (funcall 7642 (arch::target-array-type-name-from-ctype-function 7643 (backend-target-arch *target-backend*)) 7644 atype)))) 7645 (cond (keyword 7646 (let* ((dims (array-ctype-dimensions atype)) 7647 (dim0 (car dims)) 7648 (dim1 (cadr dims))) 7649 (x862-aset2 seg 7650 vreg 7651 xfer 7652 arr 7653 i 7654 j 7655 new 7656 (unless *x862-reckless* 7657 (nx-lookup-target-uvector-subtag keyword )) 7658 keyword 7659 (if (typep dim0 'fixnum) dim0) 7660 (if (typep dim1 'fixnum) dim1)))) 7661 (t 7662 (x862-four-targeted-reg-forms seg 7663 arr ($ x8664::temp0) 7664 i ($ x8664::arg_x) 7665 j ($ x8664::arg_y) 7666 new ($ x8664::arg_z)) 7667 (x862-fixed-call-builtin seg vreg xfer nil (subprim-name->offset '.SPaset2)))))) 7668 7669 7670 (defx862 x862-%aset2 simple-typed-aset2 (seg vreg xfer typename arr i j new &optional dim0 dim1) 7671 (let* ((type-keyword (x862-immediate-operand typename)) 7672 (fixtype (nx-lookup-target-uvector-subtag type-keyword)) 7544 7673 (safe (unless *x862-reckless* fixtype)) 7545 7674 (dim0 (acode-fixnum-form-p dim0)) 7546 7675 (dim1 (acode-fixnum-form-p dim1))) 7547 (cond ((eq typename :double-float-vector ) 7548 (with-fp-target () (target :double-float) 7549 (<- (x862-aset2 seg target arr i j new safe typename dim0 dim1)) 7550 (^))) 7551 ((eq typename :single-float-vector) 7552 (with-fp-target () (target :single-float) 7553 (<- (x862-aset2 seg target arr i j new safe typename dim0 dim1)) 7554 (^))) 7555 (t 7556 (x862-form seg vreg xfer 7557 (make-acode (%nx1-operator call) 7558 (make-acode (%nx1-operator immediate) '%aset2) 7559 (list (list arr) 7560 (list new j i)))))))) 7676 (x862-aset2 seg vreg xfer arr i j new safe type-keyword dim0 dim1))) 7561 7677 7562 7678 (defx862 x862-%typed-uvref %typed-uvref (seg vreg xfer subtag uvector index) … … 7583 7699 (x862-vset seg vreg xfer type-keyword uvector index newval (unless *x862-reckless* (nx-lookup-target-uvector-subtag type-keyword))) 7584 7700 (progn 7585 ;; Could always do a four-targeted-reg-forms ... 7586 (x862-vpush-register seg (x862-one-untargeted-reg-form seg subtag x8664::arg_z)) 7587 (x862-three-targeted-reg-forms seg uvector ($ x8664::arg_x) index ($ x8664::arg_y) newval ($ x8664::arg_z)) 7588 (x862-vpop-register seg ($ x8664::temp0)) 7701 (x862-four-targeted-reg-forms seg subtag ($ x8664::temp0) uvector ($ x8664::arg_x) index ($ x8664::arg_y) newval ($ x8664::arg_z)) 7589 7702 (! subtag-misc-set) 7590 7703 (when vreg (<- ($ x8664::arg_z))) … … 8349 8462 (x862-store-immediate seg sym symreg))) 8350 8463 (! symbol-ref target symreg (target-arch-case 8351 8352 8464 (:x8664 x8664::symbol.vcell-cell)))))) 8353 8465 (^)) 8354 8466 8355 8467 (defx862 x862-global-setq global-setq (seg vreg xfer sym val) 8356 (x862- misc-node-set seg8357 8358 xfer8359 (make-acode (%nx1-operator %symptr->symvector)8360 (make-acode (%nx1-operator immediate) sym))8361 (make-acode (%nx1-operator fixnum)8362 (target-arch-case8363 8364 8365 8366 8468 (x862-vset seg 8469 vreg 8470 xfer 8471 :symbol 8472 (make-acode (%nx1-operator %symptr->symvector) 8473 (make-acode (%nx1-operator immediate) sym)) 8474 (make-acode (%nx1-operator fixnum) 8475 (target-arch-case 8476 (:x8664 x8664::symbol.vcell-cell))) 8477 val 8478 nil)) 8367 8479 8368 8480 (defx862 x862-%current-frame-ptr %current-frame-ptr (seg vreg xfer) … … 8483 8595 (^)))) 8484 8596 8485 (defx862 ppc2-%fixnum-to-double %fixnum-to-double (seg vreg xfer arg)8597 (defx862 x862-%fixnum-to-double %fixnum-to-double (seg vreg xfer arg) 8486 8598 (with-fp-target () (dreg :double-float) 8487 8599 (let* ((r (x862-one-untargeted-reg-form seg arg x8664::arg_z)))
Note:
See TracChangeset
for help on using the changeset viewer.
