- Timestamp:
- Dec 4, 2007, 2:16:07 PM (17 years ago)
- File:
-
- 1 edited
-
branches/ia32/compiler/X86/x862.lisp (modified) (24 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/ia32/compiler/X86/x862.lisp
r7787 r7819 107 107 (:fpr hard-reg-class-fpr) 108 108 (:crf hard-reg-class-crf))) 109 (mode-val 109 (mode-val-or-form 110 110 (if (eq class :gpr) 111 (gpr-mode-name-value mode) 111 (if (member mode '(:natural :signed-natural)) 112 `(gpr-mode-name-value ,mode) 113 (gpr-mode-name-value mode)) 112 114 (if (eq class :fpr) 113 115 (if (eq mode :single-float) … … 117 119 `(make-unwired-lreg nil 118 120 :class ,class-val 119 :mode ,mode-val )))121 :mode ,mode-val-or-form))) 120 122 ($ (reg &key (class :gpr) (mode :lisp)) 121 123 (let* ((class-val … … 124 126 (:fpr hard-reg-class-fpr) 125 127 (:crf hard-reg-class-crf))) 126 (mode-val 128 (mode-val-or-form 127 129 (if (eq class :gpr) 128 (gpr-mode-name-value mode) 130 (if (member mode '(:natural :signed-natural)) 131 `(gpr-mode-name-value ,mode) 132 (gpr-mode-name-value mode)) 129 133 (if (eq class :fpr) 130 134 (if (eq mode :single-float) … … 134 138 `(make-wired-lreg ,reg 135 139 :class ,class-val 136 :mode ,mode-val ))))140 :mode ,mode-val-or-form)))) 137 141 ,@body)))) 138 142 … … 1475 1479 (let* ((lab (x86-double-float-constant-label form))) 1476 1480 (! load-double-float-constant vreg lab)))) 1477 (if (and (typep form '(unsigned-byte 32)) 1478 (= (hard-regspec-class vreg) hard-reg-class-gpr) 1479 (= (get-regspec-mode vreg) 1480 hard-reg-class-gpr-mode-u32)) 1481 (x862-lri seg vreg form) 1482 (ensuring-node-target 1483 (target vreg) 1484 (if (characterp form) 1485 (! load-character-constant target (char-code form)) 1486 (x862-store-immediate seg form target))))) 1481 (target-arch-case 1482 (:x8632 1483 (if (and (= (hard-regspec-class vreg) hard-reg-class-gpr) 1484 (member (get-regspec-mode vreg) 1485 '(hard-reg-class-gpr-mode-u32 1486 hard-reg-class-gpr-mode-s32 1487 hard-reg-class-gpr-mode-address)) 1488 (or (typep form '(unsigned-byte 32)) 1489 (typep form '(signed-byte 32)))) 1490 ;; The bits fit. Get them in the register somehow. 1491 (if (typep form '(signed-byte 32)) 1492 (x862-lri seg vreg form) 1493 (x862-lriu seg vreg form)) 1494 (ensuring-node-target (target vreg) 1495 (if (characterp form) 1496 (! load-character-constant target (char-code form)) 1497 (x862-store-immediate seg form target))))) 1498 (:x8664 1499 (if (and (typep form '(unsigned-byte 32)) 1500 (= (hard-regspec-class vreg) hard-reg-class-gpr) 1501 (= (get-regspec-mode vreg) 1502 hard-reg-class-gpr-mode-u32)) 1503 (x862-lri seg vreg form) 1504 (ensuring-node-target 1505 (target vreg) 1506 (if (characterp form) 1507 (! load-character-constant target (char-code form)) 1508 (x862-store-immediate seg form target))))))) 1487 1509 (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*)) 1488 1510 (x862-store-immediate seg form ($ *x862-temp0*)))) … … 1596 1618 (! call-subprim (subprim-name->offset '.SPmakeu64)) 1597 1619 (x862-copy-register seg node-dest arg_z))))) 1620 1621 (defun x862-single->heap (seg dest src) 1622 (with-x86-local-vinsn-macros (seg) 1623 (! setup-single-float-allocation) 1624 (! %allocate-uvector dest) 1625 (! set-single-float-value dest src))) 1598 1626 1599 1627 (defun x862-double->heap (seg dest src) … … 1644 1672 (! single->node target fp-val))))) 1645 1673 (t 1646 (with-imm-target () temp 1647 (if is-signed 1648 (! misc-ref-c-s32 temp src index-known-fixnum) 1649 (! misc-ref-c-u32 temp src index-known-fixnum)) 1650 (ensuring-node-target (target vreg) 1651 (if (eq type-keyword :simple-string) 1652 (! u32->char target temp) 1653 (! box-fixnum target temp)))))) 1654 (with-imm-target () idx-reg 1655 (if index-known-fixnum 1656 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 1657 (! scale-32bit-misc-index idx-reg unscaled-idx)) 1658 (cond ((eq type-keyword :single-float-vector) 1659 (with-fp-target () (fp-val :single-float) 1660 (if (and (eql vreg-class hard-reg-class-fpr) 1661 (eql vreg-mode hard-reg-class-fpr-mode-single)) 1662 (setq fp-val vreg)) 1663 (! misc-ref-single-float fp-val src idx-reg) 1664 (if (eq vreg-class hard-reg-class-fpr) 1665 (<- fp-val) 1666 (ensuring-node-target (target vreg) 1667 (! single->node target fp-val))))) 1668 (t (with-imm-target () temp 1669 (if is-signed 1670 (! misc-ref-s32 temp src idx-reg) 1671 (! misc-ref-u32 temp src idx-reg)) 1672 (ensuring-node-target (target vreg) 1673 (if (eq type-keyword :simple-string) 1674 (! u32->char target temp) 1675 (! box-fixnum target temp))))))))) 1674 (with-additional-imm-reg () 1675 (with-imm-target () temp 1676 (if is-signed 1677 (! misc-ref-c-s32 temp src index-known-fixnum) 1678 (! misc-ref-c-u32 temp src index-known-fixnum)) 1679 (ensuring-node-target (target vreg) 1680 (if (eq type-keyword :simple-string) 1681 (! u32->char target temp) 1682 (! box-fixnum target temp))))))) 1683 (with-additional-imm-reg () 1684 (with-imm-target () idx-reg 1685 (if index-known-fixnum 1686 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2))) 1687 (! scale-32bit-misc-index idx-reg unscaled-idx)) 1688 (cond ((eq type-keyword :single-float-vector) 1689 (with-fp-target () (fp-val :single-float) 1690 (if (and (eql vreg-class hard-reg-class-fpr) 1691 (eql vreg-mode hard-reg-class-fpr-mode-single)) 1692 (setq fp-val vreg)) 1693 (! misc-ref-single-float fp-val src idx-reg) 1694 (if (eq vreg-class hard-reg-class-fpr) 1695 (<- fp-val) 1696 (ensuring-node-target (target vreg) 1697 (! single->node target fp-val))))) 1698 (t (with-additional-imm-reg () 1699 (with-imm-target () temp 1700 (if is-signed 1701 (! misc-ref-s32 temp src idx-reg) 1702 (! misc-ref-u32 temp src idx-reg)) 1703 (ensuring-node-target (target vreg) 1704 (if (eq type-keyword :simple-string) 1705 (! u32->char target temp) 1706 (! box-fixnum target temp))))))))))) 1676 1707 (is-8-bit 1677 1708 (with-imm-target () temp … … 1680 1711 (! misc-ref-c-s8 temp src index-known-fixnum) 1681 1712 (! misc-ref-c-u8 temp src index-known-fixnum)) 1682 (with-imm-target () idx-reg 1683 (if index-known-fixnum 1684 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 1685 (! scale-8bit-misc-index idx-reg unscaled-idx)) 1686 (if is-signed 1687 (! misc-ref-s8 temp src idx-reg) 1688 (! misc-ref-u8 temp src idx-reg)))) 1713 (with-additional-imm-reg () 1714 (with-imm-target () idx-reg 1715 (if index-known-fixnum 1716 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum)) 1717 (! scale-8bit-misc-index idx-reg unscaled-idx)) 1718 (if is-signed 1719 (! misc-ref-s8 temp src idx-reg) 1720 (! misc-ref-u8 temp src idx-reg))))) 1689 1721 (if (eq type-keyword :simple-string) 1690 1722 (ensuring-node-target (target vreg) … … 1703 1735 (! misc-ref-c-s16 temp src index-known-fixnum) 1704 1736 (! misc-ref-c-u16 temp src index-known-fixnum)) 1705 (with-imm-target () idx-reg 1706 (if index-known-fixnum 1707 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 1708 (! scale-16bit-misc-index idx-reg unscaled-idx)) 1709 (if is-signed 1710 (! misc-ref-s16 temp src idx-reg) 1711 (! misc-ref-u16 temp src idx-reg)))) 1737 (with-additional-imm-reg () 1738 (with-imm-target () idx-reg 1739 (if index-known-fixnum 1740 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1))) 1741 (! scale-16bit-misc-index idx-reg unscaled-idx)) 1742 (if is-signed 1743 (! misc-ref-s16 temp src idx-reg) 1744 (! misc-ref-u16 temp src idx-reg))))) 1712 1745 (! box-fixnum target temp)))) 1713 1746 ;; Down to the dregs. … … 1762 1795 (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch))) 1763 1796 (! misc-ref-c-bit-fixnum target src index-known-fixnum) 1764 (with-imm-temps 1765 () (word-index bitnum) 1766 (if index-known-fixnum 1767 (progn 1768 (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) 1769 (x862-lri seg bitnum (logand index-known-fixnum #x63))) 1770 (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx)) 1771 (! ref-bit-vector-fixnum target bitnum src word-index)))))))) 1797 (with-additional-imm-reg () 1798 (with-imm-temps 1799 () (word-index bitnum) 1800 (if index-known-fixnum 1801 (progn 1802 (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6))) 1803 (x862-lri seg bitnum (logand index-known-fixnum #x63))) 1804 (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx)) 1805 (! ref-bit-vector-fixnum target bitnum src word-index))))))))) 1772 1806 (^))) 1773 1807 … … 3385 3419 (! lri reg value))) 3386 3420 3421 ;;; unsigned variant 3422 (defun x862-lriu (seg reg value) 3423 (with-x86-local-vinsn-macros (seg) 3424 (! lriu reg value))) 3387 3425 3388 3426 (defun x862-multiple-value-body (seg form) … … 4023 4061 (x862-double->heap seg dest src)) 4024 4062 (#.hard-reg-class-fpr-mode-single 4025 (! single->node dest src))))) 4063 (target-arch-case 4064 (:x8632 4065 (x862-single->heap seg dest src)) 4066 (:x8664 4067 (! single->node dest src))))))) 4026 4068 (if (and src-fpr dest-fpr) 4027 4069 (unless (eql dest-fpr src-fpr) … … 6443 6485 (defx862 x862-%set-scharcode %set-scharcode (seg vreg xfer str idx char) 6444 6486 (multiple-value-bind (src unscaled-idx char) 6445 (x862-three-untargeted-reg-forms seg str x8664::arg_x idx *x862-arg-y* 6487 (x862-three-untargeted-reg-forms seg str (target-arch-case 6488 (:x8632 x8632::temp0) 6489 (:x8664 x8664::arg_x)) 6490 idx *x862-arg-y* 6446 6491 char *x862-arg-z*) 6447 6492 (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) 6448 6493 (256 (! %set-scharcode8 src unscaled-idx char)) 6449 (t (! %set-scharcode32 src unscaled-idx char))) 6494 (t 6495 (with-additional-imm-reg () 6496 (! %set-scharcode32 src unscaled-idx char)))) 6450 6497 (when vreg (<- char)) 6451 6498 (^))) … … 7598 7645 (! mem-ref-c-single-float fp-reg ptrreg fixoffset))) 7599 7646 (with-imm-target () (ptrreg :address) 7600 (with-imm-target (ptrreg) (offsetreg :s64) 7601 (x862-two-targeted-reg-forms seg 7602 ptr ptrreg 7603 offset ($ *x862-arg-z*)) 7604 (! fixnum->signed-natural offsetreg *x862-arg-z*) 7605 (if double-p 7606 (! mem-ref-double-float fp-reg ptrreg offsetreg) 7607 (! mem-ref-single-float fp-reg ptrreg offsetreg))))) 7647 (with-additional-imm-reg () 7648 (with-imm-target (ptrreg) (offsetreg :signed-natural) 7649 (x862-two-targeted-reg-forms seg 7650 ptr ptrreg 7651 offset ($ *x862-arg-z*)) 7652 (! fixnum->signed-natural offsetreg *x862-arg-z*) 7653 (if double-p 7654 (! mem-ref-double-float fp-reg ptrreg offsetreg) 7655 (! mem-ref-single-float fp-reg ptrreg offsetreg)))))) 7608 7656 (<- fp-reg)) 7609 7657 (^))))) … … 7637 7685 (! mem-set-c-single-float fp-reg ptr-reg fixoffset))) 7638 7686 (t 7639 (with-imm-target (ptr-reg) (offset-reg :s32) 7640 (x862-push-register 7641 seg 7642 (x862-one-untargeted-reg-form seg 7643 ptr 7644 ptr-reg)) 7645 (x862-push-register 7646 seg 7647 (x862-one-untargeted-reg-form seg 7648 offset 7649 *x862-arg-z*)) 7650 (x862-one-targeted-reg-form seg newval fp-reg) 7651 (x862-pop-register seg *x862-arg-z*) 7652 (x862-pop-register seg ptr-reg) 7653 (! fixnum->signed-natural offset-reg *x862-arg-z*) 7654 (if double-p 7655 (! mem-set-double-float fp-reg ptr-reg offset-reg) 7656 (! mem-set-single-float fp-reg ptr-reg offset-reg))))) 7687 (with-additional-imm-reg () 7688 (with-imm-target (ptr-reg) (offset-reg :s32) 7689 (x862-push-register 7690 seg 7691 (x862-one-untargeted-reg-form seg 7692 ptr 7693 ptr-reg)) 7694 (x862-push-register 7695 seg 7696 (x862-one-untargeted-reg-form seg 7697 offset 7698 *x862-arg-z*)) 7699 (x862-one-targeted-reg-form seg newval fp-reg) 7700 (x862-pop-register seg *x862-arg-z*) 7701 (x862-pop-register seg ptr-reg) 7702 (! fixnum->signed-natural offset-reg *x862-arg-z*) 7703 (if double-p 7704 (! mem-set-double-float fp-reg ptr-reg offset-reg) 7705 (! mem-set-single-float fp-reg ptr-reg offset-reg)))))) 7657 7706 (<- fp-reg)) 7658 7707 (t … … 7666 7715 (x862-one-targeted-reg-form seg newval rnew) 7667 7716 (x862-pop-register seg ptr-reg) 7668 (with-imm-temps (ptr-reg) () 7669 (x862-copy-register seg fp-reg rnew) 7670 (if double-p 7671 (! mem-set-c-double-float fp-reg ptr-reg fixoffset) 7672 (! mem-set-c-single-float fp-reg ptr-reg fixoffset))))) 7717 (with-additional-imm-reg () 7718 (with-imm-temps (ptr-reg) () 7719 (x862-copy-register seg fp-reg rnew) 7720 (if double-p 7721 (! mem-set-c-double-float fp-reg ptr-reg fixoffset) 7722 (! mem-set-c-single-float fp-reg ptr-reg fixoffset)))))) 7673 7723 (t 7674 7724 (let* ((roffset ($ *x862-arg-y*)) … … 7683 7733 newval rnew) 7684 7734 (x862-pop-register seg ptr-reg) 7685 (with-imm-target (ptr-reg) (offset-reg :s32) 7686 (with-imm-temps (ptr-reg) () 7687 (x862-copy-register seg fp-reg rnew) 7688 (! fixnum->signed-natural offset-reg roffset)) 7689 (if double-p 7690 (! mem-set-double-float fp-reg ptr-reg offset-reg) 7691 (! mem-set-single-float fp-reg ptr-reg offset-reg)))))) 7735 (with-additional-imm-reg () 7736 (with-imm-target (ptr-reg) (offset-reg :s32) 7737 (with-additional-imm-reg () 7738 (with-imm-temps (ptr-reg) () 7739 (x862-copy-register seg fp-reg rnew) 7740 (! fixnum->signed-natural offset-reg roffset))) 7741 (if double-p 7742 (! mem-set-double-float fp-reg ptr-reg offset-reg) 7743 (! mem-set-single-float fp-reg ptr-reg offset-reg))))))) 7692 7744 (<- *x862-arg-z*))) 7693 7745 (^))))) … … 7755 7807 (x862-one-targeted-reg-form seg ptr src-reg) 7756 7808 (if (node-reg-p vreg) 7757 7758 7759 7760 7761 7809 (! mem-ref-c-bit-fixnum vreg src-reg offval) 7810 (with-imm-target () ;OK if src-reg & dest overlap 7811 (dest :u8) 7812 (! mem-ref-c-bit dest src-reg offval) 7813 (<- dest)))) 7762 7814 (with-imm-target () (src-reg :address) 7763 7815 (x862-two-targeted-reg-forms seg ptr src-reg offset ($ *x862-arg-z*)) 7764 7816 (if (node-reg-p vreg) 7765 (! mem-ref-bit-fixnum vreg src-reg ($ *x862-arg-z*)) 7766 (with-imm-target () ;OK if src-reg & dest overlap 7767 (dest :u8) 7768 (! mem-ref-bit dest src-reg offset) 7769 (<- dest))))) 7817 (with-additional-imm-reg (*x862-arg-z*) 7818 (! mem-ref-bit-fixnum vreg src-reg ($ *x862-arg-z*))) 7819 (with-imm-target () ;OK if src-reg & dest overlap 7820 (dest :u8) 7821 (! mem-ref-bit dest src-reg offset) 7822 (<- dest))))) 7770 7823 (^)))) 7771 7824 … … 8621 8674 (^))) 8622 8675 8676 ;; used for x8632 only 8677 (defx862 x862-%setf-short-float %setf-short-float (seg vref xfer fnode fval) 8678 (target-arch-case 8679 (:x8664 (error "%setf-short-float makes no sense on x8664"))) 8680 (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*)) 8681 (let* ((target ($ *x862-fp1* :class :fpr :mode :single-float)) 8682 (node ($ *x862-arg-z*))) 8683 (x862-one-targeted-reg-form seg fval target) 8684 (x862-vpop-register seg node) 8685 (unless (or *x862-reckless* (x862-form-typep fnode 'single-float)) 8686 (! trap-unless-single-float node)) 8687 (! store-single node target) 8688 (<- node) 8689 (^))) 8690 8623 8691 (defx862 x862-%setf-double-float %setf-double-float (seg vref xfer fnode fval) 8624 8692 (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*)) … … 8697 8765 (if (typep abs '(signed-byte 16)) 8698 8766 (x862-test-reg-%izerop seg vreg xfer other-target cr-bit true-p abs) 8699 (with-imm-temps (other-target) ((abs-target :address)) 8700 (use-imm-temp other-target) 8701 (x862-lri seg abs-target abs) 8702 (x862-compare-registers seg vreg xfer other-target abs-target cr-bit true-p)))) 8767 (with-additional-imm-reg () 8768 (with-imm-temps (other-target) ((abs-target :address)) 8769 (use-imm-temp other-target) 8770 (x862-lri seg abs-target abs) 8771 (x862-compare-registers seg vreg xfer other-target abs-target cr-bit true-p))))) 8703 8772 ;; Neither expression is obviously a constant-valued macptr. 8704 8773 (with-imm-target () (target-a :address) … … 8707 8776 (x862-open-undo $undostkblk) 8708 8777 (x862-one-targeted-reg-form seg y target-a) 8709 (with-imm-target (target-a) (target-b :address) 8710 (! temp-pop-unboxed-word target-b) 8711 (x862-close-undo) 8712 (x862-compare-registers seg vreg xfer target-b target-a cr-bit true-p)))))))) 8778 (with-additional-imm-reg () 8779 (with-imm-target (target-a) (target-b :address) 8780 (! temp-pop-unboxed-word target-b) 8781 (x862-close-undo) 8782 (x862-compare-registers seg vreg xfer target-b target-a cr-bit true-p))))))))) 8713 8783 8714 8784 (defx862 x862-set-bit %set-bit (seg vreg xfer ptr offset newval) … … 8727 8797 (with-imm-target () (src :address) 8728 8798 (x862-two-targeted-reg-forms seg ptr src newval ($ *x862-arg-z*)) 8729 (! mem-set-c-bit-variable-value src offval ($ *x862-arg-z*)) 8799 (with-additional-imm-reg () 8800 (! mem-set-c-bit-variable-value src offval ($ *x862-arg-z*))) 8730 8801 (<- ($ *x862-arg-z*))))) 8731 8802 (if constval … … 8739 8810 (with-imm-target () (src :address) 8740 8811 (x862-three-targeted-reg-forms seg ptr src offset ($ *x862-arg-y*) newval ($ *x862-arg-z*)) 8741 (! mem-set-bit-variable-value src ($ *x862-arg-y*) ($ *x862-arg-z*)) 8812 (with-additional-imm-reg () 8813 (! mem-set-bit-variable-value src ($ *x862-arg-y*) ($ *x862-arg-z*))) 8742 8814 (<- ($ *x862-arg-z*))))) 8743 8815 (^))) … … 8875 8947 (defx862 x862-i386-ff-call i386-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor) 8876 8948 (declare (ignore monitor)) 8949 #+debug 8877 8950 (format t "~&~%i386-ff-call: argspecs = ~s, argvals = ~s, resultspec = ~s" 8878 8951 argspecs argvals resultspec)
Note:
See TracChangeset
for help on using the changeset viewer.
