Changeset 6470
- Timestamp:
- May 9, 2007, 12:36:38 AM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/compiler/X86/x862.lisp (modified) (31 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/compiler/X86/x862.lisp
r6307 r6470 16 16 17 17 (in-package "CCL") 18 6 18 19 19 (eval-when (:compile-toplevel :execute) 20 20 (require "NXENV") … … 36 36 (defparameter *x862-target-num-arg-regs* 0) 37 37 (defparameter *x862-target-num-save-regs* 0) 38 (defparameter *x862-target-half-fixnum-type* nil) 38 39 39 40 (defparameter *x862-operator-supports-u8-target* ()) … … 457 458 (*x862-target-bits-in-word* (arch::target-nbits-in-word (backend-target-arch *target-backend*))) 458 459 (*x862-target-node-size* *x862-target-lcell-size*) 460 (*x862-target-half-fixnum-type* `(signed-byte ,(- *x862-target-bits-in-word* 461 (1+ *x862-target-fixnum-shift*)))) 459 462 (*x862-target-dnode-size* (* 2 *x862-target-lcell-size*)) 460 463 (*x862-all-lcells* ()) … … 1735 1738 new val-reg) 1736 1739 (x862-pop-register seg src))) 1737 (let* (( need-push-val-reg1738 1740 (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)) 1741 (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr) 1739 1742 (logbitp (hard-regspec-value val-reg) 1740 *backend-imm-temps*)))) 1741 (when need-push-val-reg (x862-push-register seg val-reg)) 1743 *backend-imm-temps*)) 1744 (use-imm-temp (hard-regspec-value val-reg))) 1745 1742 1746 (when safe 1743 1747 (when (typep safe 'fixnum) … … 1766 1770 (let* ((v ($ x8664::arg_x))) 1767 1771 (! array-data-vector-ref v src) 1768 (when need-push-val-reg1769 (x862-pop-register seg val-reg))1770 1772 (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)))))))))) 1771 1773 … … 2100 2102 (if (typep constval '(unsigned-byte 32)) 2101 2103 (x862-lri seg reg constval) 2102 (! unbox-u32 reg result-reg)))) 2104 (if *x862-reckless* 2105 (! %unbox-u32 reg result-reg) 2106 (! unbox-u32 reg result-reg))))) 2103 2107 reg))) 2104 2108 (is-16-bit … … 2107 2111 (if (typep constval '(signed-byte 16)) 2108 2112 (x862-lri seg reg constval) 2109 (! unbox-s16 reg result-reg)) 2113 (if *x862-reckless* 2114 (! %unbox-s16 reg result-reg) 2115 (! unbox-s16 reg result-reg))) 2110 2116 reg) 2111 2117 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16))) 2112 2118 (if (typep constval '(unsigned-byte 16)) 2113 2119 (x862-lri seg reg constval) 2114 (! unbox-u16 reg result-reg)) 2120 (if *x862-reckless* 2121 (! %unbox-u16 reg result-reg) 2122 (! unbox-u16 reg result-reg))) 2115 2123 reg))) 2116 2124 (is-8-bit … … 2119 2127 (if (typep constval '(signed-byte 8)) 2120 2128 (x862-lri seg reg constval) 2121 (! unbox-s8 reg result-reg)) 2129 (if *x862-reckless* 2130 (! %unbox-s8 reg result-reg) 2131 (! unbox-s8 reg result-reg))) 2122 2132 reg) 2123 2133 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8))) 2124 2134 (if (typep constval '(unsigned-byte 8)) 2125 2135 (x862-lri seg reg constval) 2126 (! unbox-u8 reg result-reg)) 2136 (if *x862-reckless* 2137 (! %unbox-u8 reg result-reg) 2138 (! unbox-u8 reg result-reg))) 2127 2139 reg))) 2128 2140 (t … … 2426 2438 (with-x86-local-vinsn-macros (seg) 2427 2439 (! emit-aligned-label (aref *backend-labels* labelnum)) 2428 (@ labelnum))) 2440 (@ labelnum) 2441 (! recover-fn-from-rip))) 2429 2442 2430 2443 … … 2444 2457 (label-p (and (fixnump fn) 2445 2458 (locally (declare (fixnum fn)) 2446 (and (= fn - 1) (- fn)))))2459 (and (= fn -2) (- fn))))) 2447 2460 (tail-p (eq xfer $backend-return)) 2448 2461 (func (if (consp f-op) (%cadr f-op))) … … 2499 2512 (! pass-multiple-values)) 2500 2513 (when mvpass-label 2501 (@= mvpass-label) 2502 (! recover-fn-from-ra0 (aref *backend-labels* mvpass-label)))) 2514 (@= mvpass-label))) 2503 2515 (progn 2504 2516 (if label-p 2505 2517 (progn 2506 (! call-label (aref *backend-labels* 1)))2518 (! call-label (aref *backend-labels* 2))) 2507 2519 (progn 2508 2520 (if a-reg … … 2555 2567 (progn (! pass-multiple-values) 2556 2568 (when mvpass-label 2557 (@= mvpass-label) 2558 (! recover-fn-from-ra0 (aref *backend-labels* mvpass-label)))) 2569 (@= mvpass-label))) 2559 2570 (! funcall)) 2560 2571 (cond ((or (null nargs) spread-p) … … 2606 2617 (dest ($ x8664::arg_z)) 2607 2618 (vsize (+ (length inherited-vars) 2608 4; %closure-code%, afunc2619 5 ; %closure-code%, afunc 2609 2620 1))) ; lfun-bits 2610 2621 (declare (list inherited-vars)) 2611 (let* ((cell 3))2622 (let* ((cell 4)) 2612 2623 (declare (fixnum cell)) 2613 2624 (if downward-p … … 2624 2635 (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) (target-arch-case (:x8664 x8664::fulltag-misc)))) 2625 2636 (! %allocate-uvector dest))) 2626 (! init- closure x8664::arg_z)2637 (! init-nclosure x8664::arg_z) 2627 2638 (x862-store-immediate seg (x862-afunc-lfun-ref afunc) x8664::ra0) 2628 2639 (with-node-temps (x8664::arg_z) (t0 t1 t2 t3) … … 4136 4147 (x862-%immediate-set-ptr seg vreg xfer ptr offset val) 4137 4148 (let* ((size (logand #xf bits)) 4138 (signed ( logbitp 5 bits))4149 (signed (not (logbitp 5 bits))) 4139 4150 (nbits (ash size 3)) 4140 4151 (intval (acode-integer-constant-p val nbits)) … … 4922 4933 (push reason unbind)))) 4923 4934 (if unbind 4924 (x862-dpayback-list seg (nreverse unbind))) 4935 (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)) 4936 (when retval (use-imm-temp x8664::nargs.q)) 4937 (x862-dpayback-list seg (nreverse unbind)))) 4925 4938 (when (and (neq lastcatch dest) 4926 4939 (%i> … … 5294 5307 (:long (frag-list-push-32 frag-list val)) 5295 5308 (:quad (frag-list-push-64 frag-list val)) 5296 (:align (finish-frag-for-align frag-list val)))) 5309 (:align (finish-frag-for-align frag-list val)) 5310 (:talign (finish-frag-for-talign frag-list val)))) 5297 5311 (let* ((pos (frag-list-position frag-list)) 5298 5312 (frag (frag-list-current frag-list)) … … 5307 5321 (:quad (frag-list-push-64 frag-list 0) 5308 5322 (setq reloctype :expr64)) 5309 ( :align (error ":align expression ~s not constant"arg)))5323 ((:align :talign) (error "~s expression ~s not constant" directive arg))) 5310 5324 (when reloctype 5311 5325 (push … … 5434 5448 (x862-allocate-global-registers *x862-fcells* *x862-vcells* (afunc-all-vars afunc) no-regs)) 5435 5449 (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 5450 (! establish-fn) 5451 (@ (backend-get-next-label)) ; self-call label 5436 5452 (unless next-method-p 5437 5453 (setq method-var nil)) … … 6297 6313 (defx862 x862-self-call self-call (seg vreg xfer arglist &optional spread-p) 6298 6314 (setq arglist (x862-augment-arglist *x862-cur-afunc* arglist (if spread-p 1 *x862-target-num-arg-regs*))) 6299 (x862-call-fn seg vreg xfer - 1arglist spread-p))6315 (x862-call-fn seg vreg xfer -2 arglist spread-p)) 6300 6316 6301 6317 … … 6775 6791 (keyword (if (and atype 6776 6792 (let* ((dims (array-ctype-dimensions atype))) 6777 ( or (atom dims)6778 (= (length dims) 1)))6793 (and (not (atom dims)) 6794 (= (length dims) 1))) 6779 6795 (not (array-ctype-complexp atype))) 6780 6796 (funcall … … 6792 6808 (keyword (if (and atype 6793 6809 (let* ((dims (array-ctype-dimensions atype))) 6794 ( or (atom dims)6810 (and (not (atom dims)) 6795 6811 (= (length dims) 1))) 6796 6812 (not (array-ctype-complexp atype))) … … 6804 6820 6805 6821 (defx862 x862-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow) 6822 (when overflow 6823 (let* ((type *x862-target-half-fixnum-type*)) 6824 (when (and (x862-form-typep form1 type) 6825 (x862-form-typep form2 type)) 6826 (setq overflow nil)))) 6806 6827 (cond ((null vreg) 6807 6828 (x862-form seg nil nil form1) … … 6854 6875 6855 6876 (defx862 x862-%i- %i- (seg vreg xfer num1 num2 &optional overflow) 6877 (when overflow 6878 (let* ((type *x862-target-half-fixnum-type*)) 6879 (when (and (x862-form-typep num1 type) 6880 (x862-form-typep num2 type)) 6881 (setq overflow nil)))) 6856 6882 (let* ((v1 (acode-fixnum-form-p num1)) 6857 6883 (v2 (acode-fixnum-form-p num2))) … … 7555 7581 (push v real-vars) 7556 7582 (push func real-funcs) 7557 (let* ((i 4) ; skip 3words of code, inner function7583 (let* ((i 5) ; skip 4 words of code, inner function 7558 7584 (our-var nil) 7559 7585 (item nil)) … … 7738 7764 (x862-one-targeted-reg-form seg tag ($ x8664::arg_z)) 7739 7765 (if mv-pass 7740 (! mkcatchmv tag-label-value)7741 (! mkcatch1v tag-label-value))7766 (! nmkcatchmv tag-label-value) 7767 (! nmkcatch1v tag-label-value)) 7742 7768 (x862-open-undo) 7743 7769 (if mv-pass … … 7750 7776 (x862-close-undo) 7751 7777 (@= tag-label) 7752 (! recover-fn-from-ra0 (aref *backend-labels* tag-label))7753 7778 (unless mv-pass (if vreg (<- x8664::arg_z))) 7754 7779 (let* ((*x862-returning-values* mv-pass)) ; nlexit keeps values on stack … … 7780 7805 (let* ((dims (array-ctype-dimensions atype))) 7781 7806 (and (typep dims 'list) 7782 7783 7807 (= 2 (length dims)))) 7784 7808 (not (array-ctype-complexp atype)) … … 7798 7822 j 7799 7823 (if *x862-reckless* 7800 *nx-nil*7824 nil 7801 7825 (nx-lookup-target-uvector-subtag keyword )) 7802 7826 keyword ;(make-acode (%nx1-operator immediate) ) … … 7851 7875 k 7852 7876 (if *x862-reckless* 7853 *nx-nil*7877 nil 7854 7878 (nx-lookup-target-uvector-subtag keyword )) 7855 7879 keyword ;(make-acode (%nx1-operator immediate) ) … … 8200 8224 (protform-label (backend-get-next-label)) 8201 8225 (old-stack (x862-encode-stack)) 8202 (yreg ($ x8664::arg_y))) 8203 (! ref-interrupt-level yreg) 8204 (x862-dbind seg (make-acode (%nx1-operator fixnum) -1) '*interrupt-level*) 8205 (! mkunwind (aref *backend-labels* protform-label) 8226 (ilevel '*interrupt-level*)) 8227 (! nmkunwind 8228 (aref *backend-labels* protform-label) 8206 8229 (aref *backend-labels* cleanup-label)) 8230 (x862-open-undo $undointerruptlevel) 8231 (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 ilevel) 8232 (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) ilevel) 8233 (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 ilevel) 8234 (x862-adjust-vstack (* 3 *x862-target-node-size*)) 8207 8235 (@= cleanup-label) 8208 8236 (let* ((*x862-vstack* *x862-vstack*) 8209 8237 (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)) 8210 8238 (x862-open-undo $undostkblk) ; tsp frame created by nthrow. 8211 ( ! save-cleanup-context (aref *backend-labels* cleanup-label))8212 (x862- vpush-register seg x8664::ra0)8239 (x862-new-vstack-lcell :cleanup-return *x862-target-lcell-size* 0 nil) 8240 (x862-adjust-vstack *x862-target-node-size*) 8213 8241 (x862-form seg nil nil cleanup-form) 8214 8242 (x862-close-undo) 8215 (x862-vpop-register seg x8664::ra0)8216 8243 (! jump-return-pc)) 8217 8244 (x862-open-undo) 8218 8245 (@= protform-label) 8219 (x862-dbind seg yreg '*interrupt-level*) 8246 (x862-open-undo $undointerruptlevel) 8247 (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 ilevel) 8248 (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) ilevel) 8249 (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 ilevel) 8250 (x862-adjust-vstack (* 3 *x862-target-node-size*)) 8220 8251 (x862-undo-body seg vreg xfer protected-form old-stack))) 8221 8252
Note:
See TracChangeset
for help on using the changeset viewer.
