Changeset 15022
- Timestamp:
- Oct 13, 2011, 3:27:43 PM (13 years ago)
- Location:
- trunk/source/compiler
- Files:
-
- 6 edited
-
X86/X8632/x8632-vinsns.lisp (modified) (7 diffs)
-
X86/X8664/x8664-vinsns.lisp (modified) (3 diffs)
-
X86/x862.lisp (modified) (24 diffs)
-
backend.lisp (modified) (1 diff)
-
vinsn.lisp (modified) (8 diffs)
-
vreg.lisp (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/compiler/X86/X8632/x8632-vinsns.lisp
r15006 r15022 252 252 253 253 (define-x8632-vinsn set-nargs (() 254 ((n :u16const))) 254 ((n :u16const)) 255 ((casualty (:lisp #.x8632::nargs)))) 255 256 ((:pred = n 0) 256 257 (xorl (:%l x8632::nargs) (:%l x8632::nargs))) … … 446 447 (cmpl (:$l (:apply target-nil-value)) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) 447 448 449 450 (define-x8632-vinsn compare-vframe-offset-to-fixnum (() 451 ((frame-offset :u16const) 452 (fixval :s32const))) 453 ((:and (:pred < fixval 128) (:pred >= fixval -128)) 454 (cmpl (:$b fixval) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) 455 ((:not (:and (:pred < fixval 128) (:pred >= fixval -128))) 456 (cmpl (:$l fixval) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp))))) 457 458 (define-x8632-vinsn add-constant-to-vframe-offset (() 459 ((frame-offset :u16const) 460 (constant :s32const))) 461 ((:and (:pred < constant 128) (:pred >= constant -128)) 462 (addl (:$b constant) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) 463 ((:not (:and (:pred < constant 128) (:pred >= constant -128))) 464 (addl (:$l constant) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp))))) 465 448 466 (define-x8632-vinsn compare-value-cell-to-nil (() 449 467 ((vcell :lisp))) … … 1013 1031 (define-x8632-vinsn zero-extend-u8 (((dest :s32)) 1014 1032 ((src :u8))) 1015 (movzbl (:%b src) (:%l dest))) 1033 ((:pred < (:apply %hard-regspec-value src) 4) 1034 (movzbl (:%b src) (:%l dest))) 1035 ((:pred >= (:apply %hard-regspec-value src) 4) 1036 (movl (:%l src) (:%l dest)) 1037 (movzbl (:%b dest) (:%l dest)))) 1038 1016 1039 1017 1040 (define-x8632-vinsn zero-extend-u16 (((dest :s32)) … … 1942 1965 (define-x8632-vinsn u8->u32 (((dest :u32)) 1943 1966 ((src :u8))) 1944 (movzbl (:%b src) (:%l dest))) 1967 ((:pred < (:apply %hard-regspec-value src) 4) 1968 (movzbl (:%b src) (:%l dest))) 1969 ((:pred >= (:apply %hard-regspec-value src) 4) 1970 (movl (:%l src) (:%l dest)) 1971 (movzbl (:%b dest) (:%l dest)))) 1972 1945 1973 1946 1974 (define-x8632-vinsn s16->s32 (((dest :s32)) … … 2711 2739 (define-x8632-vinsn mask-base-char (((dest :u8)) 2712 2740 ((src :lisp))) 2713 (movzbl (:%b src) (:%l dest))) 2741 ((:pred < (:apply %hard-regspec-value src) 4) 2742 (movzbl (:%b src) (:%l dest))) 2743 ((:pred >= (:apply %hard-regspec-value src) 4) 2744 (movl (:%l src) (:%l dest)) 2745 (movzbl (:%b dest) (:%l dest)))) 2746 2747 2714 2748 2715 2749 (define-x8632-vinsn event-poll (() … … 2819 2853 (sarl (:$ub x8632::charcode-shift) (:%l dest))) 2820 2854 2821 (define-x8632-vinsn adjust-vsp (() 2822 ((amount :s32const))) 2855 (define-x8632-vinsn (adjust-vsp :vsp :pop :discard) 2856 (() 2857 ((amount :s32const))) 2823 2858 ((:and (:pred >= amount -128) (:pred <= amount 127)) 2824 2859 (addl (:$b amount) (:%l x8632::esp))) … … 4027 4062 (btrl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) 4028 4063 4029 (define-x8632-vinsn mark-as-node (( )4064 (define-x8632-vinsn mark-as-node (((reg :imm)) 4030 4065 ((reg :imm))) 4031 4066 (xorl (:%l reg) (:%l reg)) -
trunk/source/compiler/X86/X8664/x8664-vinsns.lisp
r15006 r15022 548 548 (cmpb (:$b x8664::fulltag-nil) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) 549 549 550 (define-x8664-vinsn compare-vframe-offset-to-fixnum (() 551 ((frame-offset :u16const) 552 (fixval :s32const))) 553 ((:and (:pred < fixval 128) (:pred >= fixval -128)) 554 (cmpq (:$b fixval) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) 555 ((:not (:and (:pred < fixval 128) (:pred >= fixval -128))) 556 (cmpq (:$l fixval) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp))))) 557 558 559 (define-x8664-vinsn add-constant-to-vframe-offset (() 560 ((frame-offset :u16const) 561 (constant :s32const))) 562 ((:and (:pred < constant 128) (:pred >= constant -128)) 563 (addq (:$b constant) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) 564 ((:not (:and (:pred < constant 128) (:pred >= constant -128))) 565 (addq (:$l constant) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp))))) 566 550 567 551 568 (define-x8664-vinsn compare-value-cell-to-nil (() … … 970 987 (movq (:%q car) (:@ x8664::cons.car (:%q allocptr))) 971 988 (movq (:%q cdr) (:@ x8664::cons.cdr (:%q allocptr))) 972 (movq (:%q allocptr) (:%q dest))) 989 ((:pred /= (:apply %hard-regspec-value dest) (:apply %hard-regspec-value x8664::allocptr)) 990 (movq (:%q allocptr) (:%q dest)))) 973 991 974 992 (define-x8664-vinsn unbox-u8 (((dest :u8)) … … 3523 3541 (sarq (:$ub x8664::charcode-shift) (:%q dest))) 3524 3542 3525 (define-x8664-vinsn adjust-vsp (() 3526 ((amount :s32const))) 3543 (define-x8664-vinsn (adjust-vsp :vsp :pop :discard) 3544 (() 3545 ((amount :s32const))) 3527 3546 ((:and (:pred >= amount -128) (:pred <= amount 127)) 3528 3547 (addq (:$b amount) (:%q x8664::rsp))) -
trunk/source/compiler/X86/x862.lisp
r15006 r15022 226 226 (defvar *x862-ra0* nil) 227 227 (defvar *x862-codecoverage-reg* nil) 228 228 (defvar *x862-variable-shift-count-mask* 0) 229 229 (defvar *x862-allocptr* nil) 230 230 … … 356 356 ((addrspec-vcell-p ea) ; closed-over vcell 357 357 (x862-copy-register seg *x862-arg-z* valreg) 358 (setq valreg *x862-arg-z*) 358 359 (let* ((gvector (target-arch-case (:x8632 x8632::temp0) 359 360 (:x8664 x8664::arg_x)))) … … 551 552 (:x8632 $numx8632saveregs) 552 553 (:x8664 $numx8664saveregs))) 554 (*x862-variable-shift-count-mask* (ash 1 (hard-regspec-value 555 (target-arch-case 556 (:x8632 x8632::ecx) 557 (:x8664 x8664::rcx))))) 553 558 (*x862-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*))) 554 559 (*x862-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*))) … … 1471 1476 (memq offset (svref info reg))) 1472 1477 (return reg)))))) 1478 1479 1480 (defun x862-reg-for-form (form hint) 1481 (let* ((var (nx2-lexical-reference-p form))) 1482 (cond ((node-reg-p hint) 1483 (if var 1484 (let* ((ea (var-ea var))) 1485 (if (and (memory-spec-p ea) 1486 (not (addrspec-vcell-p ea))) 1487 (let* ((offset (memspec-frame-address-offset ea)) 1488 (mask *x862-gpr-locations-valid-mask*) 1489 (info *x862-gpr-locations*)) 1490 (declare (fixnum mask) (simple-vector info)) 1491 (dotimes (reg 16) 1492 (when (and (logbitp reg mask) 1493 (memq offset (svref info reg))) 1494 (return reg)))) 1495 (if (register-spec-p ea) 1496 ea))) 1497 (if (acode-p (setq form (acode-unwrapped-form form))) 1498 (let* ((op (acode-operator form))) 1499 (if (eql op (%nx1-operator immediate)) 1500 (x862-register-constant-p (cadr form))))))) 1501 ((eql (hard-regspec-class hint) hard-reg-class-fpr) 1502 (when var 1503 (let* ((ea (var-ea var))) 1504 (when (register-spec-p ea) 1505 (and (eql (hard-regspec-class ea) hard-reg-class-fpr) 1506 (eql (get-regspec-mode ea) (get-regspec-mode hint)) 1507 ea)))))))) 1508 1509 (defun same-x86-reg-p (x y) 1510 (and (eql (%hard-regspec-value x) (%hard-regspec-value y)) 1511 (eql (hard-regspec-class x) (hard-regspec-class y)))) 1512 1473 1513 1474 1514 (defun x862-stack-to-register (seg memspec reg) … … 3324 3364 (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg)))) 3325 3365 3326 (defun x862-one-untargeted-reg-form (seg form suggested) 3327 (with-x86-local-vinsn-macros (seg) 3328 (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr)) 3329 (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node)))) 3330 (if node-p 3331 (let* ((ref (x862-lexical-reference-ea form)) 3332 (reg (backend-ea-physical-reg ref hard-reg-class-gpr))) 3333 (if reg 3334 ref 3335 (if (nx-null form) 3336 (progn 3337 (! load-nil suggested) 3338 suggested) 3339 (if (and (acode-p form) 3340 (eq (acode-operator form) (%nx1-operator immediate)) 3341 (setq reg (x862-register-constant-p (cadr form)))) 3342 reg 3343 (x862-one-untargeted-lreg-form seg form suggested))))) 3344 (x862-one-untargeted-lreg-form seg form suggested))))) 3366 ;;; If REG is a node reg, add it to the bitmask. 3367 (defun x862-restrict-node-target (reg mask) 3368 (if (node-reg-p reg) 3369 (logior mask (ash 1 (hard-regspec-value reg))) 3370 mask)) 3371 3372 ;;; If suggested reg is a node reg that contains a stack location, 3373 ;;; try to use some other node temp. 3374 (defun x862-try-non-conflicting-reg (suggested reserved) 3375 (let* ((mask *x862-gpr-locations-valid-mask*)) 3376 (or (when (and (node-reg-p suggested) 3377 (logbitp (hard-regspec-value suggested) mask)) 3378 (setq mask (logior mask reserved)) 3379 (%available-node-temp (logand *available-backend-node-temps* 3380 (lognot mask)))) 3381 suggested))) 3382 3383 (defun x862-one-untargeted-reg-form (seg form suggested &optional (reserved 0)) 3384 (or (x862-reg-for-form form suggested) 3385 (with-x86-local-vinsn-macros (seg) 3386 (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr)) 3387 (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node)))) 3388 (if node-p 3389 (let* ((ref (x862-lexical-reference-ea form)) 3390 (reg (backend-ea-physical-reg ref hard-reg-class-gpr))) 3391 (if reg 3392 ref 3393 (let* ((target (x862-try-non-conflicting-reg suggested reserved))) 3394 (if (nx-null form) 3395 (progn 3396 (! load-nil target) 3397 target) 3398 (if (and (acode-p form) 3399 (eq (acode-operator form) (%nx1-operator immediate)) 3400 (setq reg (x862-register-constant-p (cadr form)))) 3401 reg 3402 (x862-one-untargeted-lreg-form seg form target)))))) 3403 (x862-one-untargeted-lreg-form seg form suggested)))))) 3345 3404 3346 3405 3347 3406 3348 3407 3349 (defun x862-push-register (seg areg )3408 (defun x862-push-register (seg areg &optional inhibit-note) 3350 3409 (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) 3351 3410 (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single))) … … 3354 3413 (with-x86-local-vinsn-macros (seg) 3355 3414 (if a-node 3356 (setq vinsn (x862-vpush-register seg areg :node-temp ))3415 (setq vinsn (x862-vpush-register seg areg :node-temp nil nil inhibit-note)) 3357 3416 (if a-single 3358 3417 (target-arch-case … … 3433 3492 (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0)) 3434 3493 (same-reg (eq (hard-regspec-value pushed-reg) 3435 (hard-regspec-value popped-reg))) 3436 (csp-p (vinsn-attribute-p push-vinsn :csp))) 3437 (when csp-p ; vsp case is harder. 3494 (hard-regspec-value popped-reg)))) 3495 (when (vinsn-attribute-p push-vinsn :csp) 3438 3496 (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :csp :discard) 3439 3497 (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p … … 3485 3543 (insert-dll-node-before restore pop-vinsn) 3486 3544 (elide-vinsn push-vinsn) 3487 (elide-vinsn pop-vinsn))))))))))))) 3545 (elide-vinsn pop-vinsn)))))))))) 3546 (when (and (vinsn-attribute-p push-vinsn :vsp)) 3547 (unless (or 3548 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :push) 3549 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :pop) 3550 (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p 3551 push-vinsn pop-vinsn pushed-reg)) 3552 (popped-reg-is-set (if same-reg 3553 pushed-reg-is-set 3554 (vinsn-sequence-sets-reg-p 3555 push-vinsn pop-vinsn popped-reg))) 3556 (popped-reg-is-reffed (unless same-reg 3557 (vinsn-sequence-refs-reg-p 3558 push-vinsn pop-vinsn popped-reg)))) 3559 (cond ((and (not (and pushed-reg-is-set popped-reg-is-set)) 3560 (or (null popped-reg-is-reffed) 3561 (vinsn-in-sequence-p pushed-reg-is-set popped-reg-is-reffed pop-vinsn))) 3562 (unless same-reg 3563 (let* ((copy (! copy-gpr popped-reg pushed-reg))) 3564 (remove-dll-node copy) 3565 (if popped-reg-is-reffed 3566 (insert-dll-node-after copy popped-reg-is-reffed) 3567 (if pushed-reg-is-set 3568 (insert-dll-node-after copy push-vinsn) 3569 (insert-dll-node-before copy push-vinsn))))) 3570 (elide-vinsn push-vinsn) 3571 (elide-vinsn pop-vinsn)) 3572 (t ; maybe allocate a node temp 3573 ))))))))) 3488 3574 3489 3575 … … 3500 3586 (if atriv 3501 3587 (x862-one-targeted-reg-form seg aform areg) 3502 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 3588 (setq apushed (x862-push-register 3589 seg 3590 (x862-one-untargeted-reg-form seg aform areg))))) 3503 3591 (x862-one-targeted-reg-form seg bform breg) 3504 3592 (if aconst … … 3508 3596 (values areg breg))) 3509 3597 3510 3511 (defun x862-two-untargeted-reg-forms (seg aform areg bform breg) 3598 3599 (defun x862-two-untargeted-reg-forms (seg aform areg bform breg &optional (restricted 0)) 3600 (unless (eql restricted 0) 3601 (setq *x862-gpr-locations-valid-mask* (logandc2 *x862-gpr-locations-valid-mask* restricted))) 3512 3602 (with-x86-local-vinsn-macros (seg) 3513 3603 (let* ((avar (nx2-lexical-reference-p aform)) … … 3521 3611 (unless aconst 3522 3612 (if atriv 3523 (setq adest (x862-one-untargeted-reg-form seg aform areg)) 3524 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 3525 (setq bdest (x862-one-untargeted-reg-form seg bform breg)) 3613 (progn 3614 (setq adest (x862-one-untargeted-reg-form seg aform areg restricted) 3615 restricted (x862-restrict-node-target adest restricted)) 3616 (when (same-x86-reg-p adest breg) 3617 (setq breg areg))) 3618 (setq apushed (x862-push-register 3619 seg 3620 (x862-one-untargeted-reg-form seg aform areg) 3621 t)))) 3622 (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) 3623 restricted (x862-restrict-node-target bdest restricted)) 3624 (when (same-x86-reg-p bdest areg) 3625 (setq areg breg) 3626 (when apushed 3627 (setq adest areg))) 3526 3628 (if aconst 3527 (setq adest (x862-one-untargeted-reg-form seg aform areg ))3528 ( ifapushed3629 (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) 3630 (when apushed 3529 3631 (x862-elide-pushes seg apushed (x862-pop-register seg areg))))) 3530 3632 (values adest bdest)))) … … 3558 3660 (if atriv 3559 3661 (x862-one-targeted-reg-form seg aform areg) 3560 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 3662 (setq apushed (x862-push-register 3663 seg 3664 (x862-one-targeted-reg-form seg aform areg))))) 3561 3665 (if (and bform (not bconst)) 3562 3666 (if btriv 3563 3667 (x862-one-targeted-reg-form seg bform breg) 3564 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) 3668 (setq bpushed (x862-push-register 3669 seg 3670 (x862-one-targeted-reg-form seg bform breg))))) 3565 3671 (x862-one-targeted-reg-form seg cform creg) 3566 3672 (unless btriv … … 3618 3724 (if atriv 3619 3725 (x862-one-targeted-reg-form seg aform areg) 3620 (setq apushed (x862-push-register seg (x862-one- untargeted-reg-form seg aform (x862-acc-reg-for areg))))))3726 (setq apushed (x862-push-register seg (x862-one-targeted-reg-form seg aform areg))))) 3621 3727 (if (and bform (not bconst)) 3622 3728 (if btriv 3623 3729 (x862-one-targeted-reg-form seg bform breg) 3624 (setq bpushed (x862-push-register seg (x862-one- untargeted-reg-form seg bform (x862-acc-reg-for breg))))))3730 (setq bpushed (x862-push-register seg (x862-one-targeted-reg-form seg bform breg))))) 3625 3731 (if (and cform (not cconst)) 3626 3732 (if ctriv 3627 3733 (x862-one-targeted-reg-form seg cform creg) 3628 (setq cpushed (x862-push-register seg (x862-one- untargeted-reg-form seg cform (x862-acc-reg-for creg))))))3734 (setq cpushed (x862-push-register seg (x862-one-targeted-reg-form seg cform creg))))) 3629 3735 (x862-one-targeted-reg-form seg dform dreg) 3630 3736 (unless ctriv … … 3642 3748 (values areg breg creg dreg))) 3643 3749 3644 (defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg )3750 (defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg &optional (restricted 0)) 3645 3751 (with-x86-local-vinsn-macros (seg) 3646 3752 (let* ((bnode (nx2-node-gpr-p breg)) … … 3672 3778 (if (and aform (not aconst)) 3673 3779 (if atriv 3674 (setq adest (x862-one-untargeted-reg-form seg aform ($ areg))) 3675 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 3780 (progn 3781 (setq adest (x862-one-untargeted-reg-form seg aform ($ areg) restricted) 3782 restricted (x862-restrict-node-target adest restricted)) 3783 (when (same-x86-reg-p adest breg) 3784 (setq breg areg)) 3785 (when (same-x86-reg-p adest creg) 3786 (setq creg areg))) 3787 (setq apushed (x862-push-register 3788 seg 3789 (x862-one-untargeted-reg-form seg aform areg))))) 3676 3790 (if (and bform (not bconst)) 3677 3791 (if btriv 3678 (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg))) 3679 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) 3680 (setq cdest (x862-one-untargeted-reg-form seg cform creg)) 3792 (progn 3793 (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg) restricted) 3794 restricted (x862-restrict-node-target bdest restricted)) 3795 (when (same-x86-reg-p bdest creg) 3796 (setq creg breg)) 3797 (when (same-x86-reg-p bdest areg) 3798 (setq areg breg))) 3799 (setq bpushed (x862-push-register 3800 seg (x862-one-untargeted-reg-form seg bform breg))))) 3801 (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) 3802 restricted (x862-restrict-node-target cdest restricted)) 3803 (when (same-x86-reg-p cdest areg) 3804 (setq areg creg) 3805 (when apushed 3806 (setq adest areg))) 3807 (when (same-x86-reg-p cdest breg) 3808 (setq breg creg) 3809 (when bpushed 3810 (setq bdest breg))) 3681 3811 (unless btriv 3682 3812 (if bconst 3683 (setq bdest (x862-one-untargeted-reg-form seg bform breg)) 3813 (progn 3814 (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) 3815 restricted (x862-restrict-node-target bdest restricted)) 3816 (when (same-x86-reg-p bdest areg) 3817 (setq areg breg) 3818 (when apushed 3819 (setq adest areg)))) 3684 3820 (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) 3685 3821 (unless atriv 3686 3822 (if aconst 3687 (setq adest (x862-one-untargeted-reg-form seg aform areg ))3823 (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) 3688 3824 (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) 3689 3825 (values adest bdest cdest)))) 3690 3826 3691 (defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg )3827 (defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg &optional (restricted 0)) 3692 3828 (let* ((bnode (nx2-node-gpr-p breg)) 3693 3829 (cnode (nx2-node-gpr-p creg)) … … 3736 3872 (if (and aform (not aconst)) 3737 3873 (if atriv 3738 (setq adest (x862-one-targeted-reg-form seg aform areg)) 3739 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) 3874 (progn 3875 (setq adest (x862-one-untargeted-reg-form seg aform areg restricted) 3876 restricted (x862-restrict-node-target adest restricted)) 3877 (when (same-x86-reg-p adest breg) 3878 (setq breg areg)) 3879 (when (same-x86-reg-p adest creg) 3880 (setq creg areg)) 3881 (when (same-x86-reg-p adest dreg) 3882 (setq dreg areg))) 3883 (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform areg))))) 3740 3884 (if (and bform (not bconst)) 3741 3885 (if btriv 3742 (setq bdest (x862-one-untargeted-reg-form seg bform breg)) 3743 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) 3886 (progn 3887 (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) 3888 restricted (x862-restrict-node-target bdest restricted)) 3889 (when (same-x86-reg-p bdest creg) 3890 (setq creg breg)) 3891 (when (same-x86-reg-p bdest dreg) 3892 (setq dreg breg))) 3893 (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform breg))))) 3744 3894 (if (and cform (not cconst)) 3745 3895 (if ctriv 3746 (setq cdest (x862-one-untargeted-reg-form seg cform creg)) 3747 (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) 3748 (setq ddest (x862-one-untargeted-reg-form seg dform dreg)) 3896 (progn 3897 (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) 3898 restricted (x862-restrict-node-target cdest restricted)) 3899 (when (same-x86-reg-p cdest dreg) 3900 (setq dreg creg))) 3901 (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform creg))))) 3902 (setq ddest (x862-one-untargeted-reg-form seg dform dreg restricted) 3903 restricted (x862-restrict-node-target ddest restricted)) 3904 (when (same-x86-reg-p ddest areg) 3905 (setq areg dreg) 3906 (when apushed 3907 (setq adest areg))) 3908 (when (same-x86-reg-p ddest breg) 3909 (setq breg dreg) 3910 (when bpushed 3911 (setq bdest breg))) 3912 (when (same-x86-reg-p ddest creg) 3913 (setq creg dreg) 3914 (when cpushed 3915 (setq cdest creg))) 3749 3916 (unless ctriv 3750 3917 (if cconst 3751 (setq cdest (x862-one-untargeted-reg-form seg cform creg)) 3918 (progn 3919 (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) 3920 restricted (x862-restrict-node-target cdest restricted)) 3921 (when (same-x86-reg-p cdest breg) 3922 (setq breg creg) 3923 (when bpushed 3924 (setq bdest breg)))) 3752 3925 (x862-elide-pushes seg cpushed (x862-pop-register seg creg)))) 3753 3926 (unless btriv 3754 3927 (if bconst 3755 (setq bdest (x862-one-untargeted-reg-form seg bform breg)) 3928 (progn 3929 (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) 3930 restricted (x862-restrict-node-target bdest restricted)) 3931 (when (same-x86-reg-p bdest areg) 3932 (setq areg bdest) 3933 (when apushed 3934 (setq adest areg)))) 3756 3935 (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) 3757 3936 (unless atriv 3758 3937 (if aconst 3759 (setq adest (x862-one-untargeted-reg-form seg aform areg ))3938 (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) 3760 3939 (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) 3761 3940 (values adest bdest cdest ddest))) … … 3870 4049 (x862-compare-u8 seg vreg xfer u8-operand u8 (if (and iu8 (not (eq cr-bit x86::x86-e-bits))) (logxor 1 cr-bit) cr-bit) true-p u8-operator) 3871 4050 (if (and boolean (or js32 is32)) 3872 (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*)) 4051 (let* ((ea (x862-lexical-reference-ea (if js32 i j))) 4052 (offset (and ea (memory-spec-p ea) (memspec-frame-address-offset ea))) 4053 (reg (unless offset (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*))) 3873 4054 (constant (or js32 is32))) 3874 (if (zerop constant) 3875 (! compare-reg-to-zero reg) 3876 (! compare-s32-constant reg (or js32 is32))) 4055 (if offset 4056 (! compare-vframe-offset-to-fixnum offset constant) 4057 (if (zerop constant) 4058 (! compare-reg-to-zero reg) 4059 (! compare-s32-constant reg (or js32 is32)))) 3877 4060 (unless (or js32 (eq cr-bit x86::x86-e-bits)) 3878 4061 (setq cr-bit (x862-reverse-cr-bit cr-bit))) … … 4107 4290 4108 4291 4109 (defun x862-vpush-register (seg src &optional why info attr )4292 (defun x862-vpush-register (seg src &optional why info attr inhibit-note) 4110 4293 (with-x86-local-vinsn-macros (seg) 4111 4294 (prog1 4112 4295 (! vpush-register src) 4113 (x862-regmap-note-store src *x862-vstack*) 4296 (unless inhibit-note 4297 (x862-regmap-note-store src *x862-vstack*)) 4114 4298 (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info) 4115 4299 (x862-adjust-vstack *x862-target-node-size*)))) … … 6589 6773 (unless *x862-reckless* 6590 6774 (! check-misc-bound i v)) 6591 (with-node-temps (v ) (temp)6775 (with-node-temps (v i) (temp) 6592 6776 (! %slot-ref temp v i) 6593 6777 (x862-copy-register seg target temp)))) … … 6647 6831 (x862-form seg nil nil y) 6648 6832 (x862-form seg nil xfer z)) 6649 (multiple-value-bind (yreg zreg) (x862-two-untargeted-reg-forms seg y *x862-arg-y* z *x862-arg-z*) 6833 (multiple-value-bind (yreg zreg) 6834 (x862-two-untargeted-reg-forms seg y *x862-arg-y* z *x862-arg-z* 6835 (ash 1 (hard-regspec-value *x862-allocptr*))) 6650 6836 (ensuring-node-target (target vreg) 6651 6837 (! cons target yreg zreg)) … … 6925 7111 (! %ilsl-c target const src) 6926 7112 (! lri target 0))) 6927 (multiple-value-bind (count src) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) 6928 (! %ilsl target count src)))) 7113 (multiple-value-bind (count src) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z* *x862-variable-shift-count-mask*) 7114 (if (= (ash 1 (hard-regspec-value target)) 7115 *x862-variable-shift-count-mask*) 7116 (progn 7117 (! %ilsl src count src) 7118 (! copy-gpr target src)) 7119 (! %ilsl target count src))))) 6929 7120 (^)))) 6930 7121 … … 7152 7343 (^))))) 7153 7344 7345 ;;; try to use a CISCy instruction for (SETQ stack-var (op stack-var other)). 7346 ;;; Don't do this if some register (incidentally) contains the value of EA. 7347 (defun x862-two-address-op (seg vreg xfer ea form) 7348 (when (and (memory-spec-p ea) 7349 (null vreg) 7350 (not (addrspec-vcell-p ea)) 7351 (acode-p (setq form (acode-unwrapped-form form)))) 7352 (let* ((offset (memspec-frame-address-offset ea))) 7353 (unless (x862-register-for-frame-offset ea) 7354 (let* ((op (acode-operator form)) 7355 (constant nil)) 7356 (with-x86-local-vinsn-macros (seg vreg xfer) 7357 (cond ((eql op (%nx1-operator %i+)) 7358 (destructuring-bind (arg1 arg2 &optional check-overflow) 7359 (cdr form) 7360 (unless check-overflow 7361 (when (or 7362 (and (setq constant (acode-s32-constant-p arg1)) 7363 (eql ea (x862-lexical-reference-ea arg2 t))) 7364 (and (setq constant (acode-s32-constant-p arg2)) 7365 (eql ea (x862-lexical-reference-ea arg2 t)))) 7366 (! add-constant-to-vframe-offset offset constant) 7367 (^) 7368 t))))))))))) 7369 7370 7154 7371 (defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form) 7155 7372 (let* ((ea (var-ea varspec))) 7156 ;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) 7157 (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) 7158 (or (null vreg) (eq ea vreg))) 7159 ea 7160 *x862-arg-z*)))) 7161 (x862-do-lexical-setq seg vreg ea valreg)) 7373 ;;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) 7374 (or (and ea (x862-two-address-op seg vreg xfer ea form)) 7375 (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) 7376 (or (null vreg) (eq ea vreg))) 7377 ea 7378 *x862-arg-z*)))) 7379 (x862-do-lexical-setq seg vreg ea valreg))) 7162 7380 (^))) 7163 7381 … … 8099 8317 (x862-one-untargeted-reg-form seg form2 *x862-arg-z*)) 8100 8318 (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) 8101 (! %iasr target cnt src)))) 8319 (if (= (ash 1 (hard-regspec-value target)) 8320 *x862-variable-shift-count-mask*) 8321 (progn 8322 (! %iasr src cnt src) 8323 (! copy-gpr target src)) 8324 (! %iasr target cnt src))))) 8102 8325 (^)))) 8103 8326 … … 8115 8338 (! lri target 0))) 8116 8339 (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) 8117 (! %ilsr target cnt src)))) 8340 (if (= (ash 1 (hard-regspec-value target)) 8341 *x862-variable-shift-count-mask*) 8342 (progn 8343 (! %ilsr src cnt src) 8344 (! copy-gpr target src)) 8345 (! %ilsr target cnt src))))) 8118 8346 (^)))) 8119 8347 -
trunk/source/compiler/backend.lisp
r14982 r15022 171 171 (backend-ea-physical-reg vreg hard-reg-class-crf)) 172 172 173 (defun %available-node-temp (mask) 174 (unless (eql 0 mask) 175 (if *backend-allocate-high-node-temps* 176 (do* ((bit 31 (1- bit))) 177 ((< bit 0)) 178 (when (logbitp bit mask) 179 (return bit))) 180 (dotimes (bit 32) 181 (when (logbitp bit mask) 182 (return bit)))))) 183 173 184 (defun available-node-temp (mask) 174 (if *backend-allocate-high-node-temps* 175 (do* ((bit 31 (1- bit))) 176 ((< bit 0) (error "Bug: ran out of node temp registers.")) 177 (when (logbitp bit mask) 178 (return bit))) 179 (dotimes (bit 32 (error "Bug: ran out of node temp registers.")) 180 (when (logbitp bit mask) 181 (return bit))))) 185 (or (%available-node-temp mask) 186 (error "Bug: ran out of node temp registers."))) 187 182 188 183 189 (defun ensure-node-target (reg) -
trunk/source/compiler/vinsn.lisp
r14972 r15022 77 77 (gprs-set 0) 78 78 (fprs-set 0) 79 (gprs-read 0) 80 (fprs-read 0) 79 81 ) 80 82 … … 84 86 (let* ((vinsn (alloc-dll-node *vinsn-freelist*))) 85 87 (loop 86 ; Sometimes, the compiler seems to return its node list 87 ; to the freelist without first removing the vinsn-labels in it. 88 ;; Sometimes, the compiler seems to return its node list 89 ;; to the freelist without first removing the vinsn-labels in it. 90 #-bootstrapped (when (and (typep vinsn 'vinsn) 91 (not (> (uvsize vinsn) 8))) 92 (setf (pool.data *vinsn-freelist*) nil) 93 (setq vinsn nil)) 88 94 (if (or (null vinsn) (typep vinsn 'vinsn)) (return)) 89 95 (setq vinsn (alloc-dll-node *vinsn-freelist*))) … … 94 100 (vinsn-annotation vinsn) nil 95 101 (vinsn-gprs-set vinsn) 0 96 (vinsn-fprs-set vinsn) 0) 102 (vinsn-fprs-set vinsn) 0 103 (vinsn-gprs-read vinsn) 0 104 (vinsn-fprs-read vinsn) 0) 97 105 vinsn) 98 106 (%make-vinsn template)))) … … 359 367 (fixup-vinsn-template template opcode-hash-table)) 360 368 templates)) 361 369 370 371 372 362 373 ;;; Could probably split this up and do some arg checking at macroexpand time. 363 374 (defun match-template-vregs (template vinsn supplied-vregs) … … 482 493 (eq (hard-regspec-value varpart-value) regval))) 483 494 495 (defun vinsn-refs-reg-p (element reg) 496 (if (typep element 'vinsn) 497 (if (vinsn-attribute-p element :call) 498 t 499 (let* ((class (hard-regspec-class reg)) 500 (value (hard-regspec-value reg))) 501 (if (eq class hard-reg-class-gpr) 502 (logbitp value (vinsn-gprs-read element)) 503 (if (eq class hard-reg-class-fpr) 504 ;; The FPR is logically read in the vinsn if it or any 505 ;; conflicting FPR is physically read in the vinsn. 506 (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-read element)))))))) 507 484 508 (defun vinsn-sets-reg-p (element reg) 485 509 (if (typep element 'vinsn) … … 508 532 (setq gprs-set (logior gprs-set (vinsn-gprs-set element)) 509 533 fprs-set (logior fprs-set (vinsn-fprs-set element)))))))) 534 535 510 536 511 ;;; Return T if any vinsn between START and END (exclusive) sets REG. 537 ;;; If any vinsn between START and END (exclusive) sets REG, return 538 ;;; that vinsn; otherwise, return NIL. 512 539 (defun vinsn-sequence-sets-reg-p (start end reg) 513 540 (do* ((element (dll-node-succ start) (dll-node-succ element))) 514 541 ((eq element end)) 515 542 (if (vinsn-sets-reg-p element reg) 516 (return t))))543 (return element)))) 517 544 545 ;;; If any vinsn between START and END (exclusive) refs REG, return 546 ;;; the last such vinsn; otherwise, return NIL. 547 (defun vinsn-sequence-refs-reg-p (start end reg) 548 (do* ((element (dll-node-pred end) (dll-node-pred element))) 549 ((eq element start)) 550 (if (vinsn-refs-reg-p element reg) 551 (return element)))) 552 518 553 519 554 ;;; Return T if any vinsn between START and END (exclusive) has all … … 523 558 ((eq element end)) 524 559 (when (typep element 'vinsn) 525 (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)) ))560 (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)) attr)) 526 561 (return t))))) 527 562 … … 529 564 `(%vinsn-sequence-has-attribute-p ,start ,end ,(encode-vinsn-attributes attrs))) 530 565 531 566 ;;; Return T iff vinsn is between START and END (exclusive). 567 (defun vinsn-in-sequence-p (vinsn start end) 568 (do* ((element (dll-node-succ start) (dll-node-succ element))) 569 ((eq element end)) 570 (when (eq vinsn element) 571 (return t)))) 572 573 (defun last-vinsn (seg) 574 ;; Try to find something that isn't a SOURCE-NOTE. Go ahead. I dare you. 575 (do* ((element (dll-header-last seg) (dll-node-pred element))) 576 ((eq element seg)) ;told ya! 577 (when (typep element 'vinsn) 578 (return element)))) 579 580 532 581 ;;; Flow-graph nodes (FGNs) 533 582 -
trunk/source/compiler/vreg.lisp
r14972 r15022 26 26 (def-standard-initial-binding *lreg-freelist* (%cons-pool)) 27 27 28 28 29 (defstruct (lreg 29 30 (:print-function print-lreg) … … 253 254 (setf (vinsn-gprs-set vinsn) (logior (vinsn-gprs-set vinsn) (ash 1 gpr)))) 254 255 255 (defun note-vinsn-sets-fpr (vinsn fpr)256 (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) (ash 1 fpr))))257 258 256 (defun note-vinsn-sets-fpr-lreg (vinsn fpr) 259 257 (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) … … 263 261 :single-float 264 262 :double-float))))) 263 264 (defun note-vinsn-refs-gpr (vinsn gpr) 265 (when (and (fboundp 'vinsn-gprs-read) 266 (> (uvsize vinsn) 8)) 267 (setf (vinsn-gprs-read vinsn) (logior (vinsn-gprs-read vinsn) (ash 1 gpr))))) 268 269 (defun note-vinsn-refs-fpr-lreg (vinsn fpr) 270 (when (and (fboundp 'vinsn-gprs-read) 271 (> (uvsize vinsn) 8)) 272 (setf (vinsn-fprs-read vinsn) (logior (vinsn-fprs-read vinsn) 273 (target-fpr-mask (hard-regspec-value fpr) 274 (if (eql (get-regspec-mode fpr) 275 hard-reg-class-fpr-mode-single) 276 :single-float 277 :double-float)))))) 265 278 266 279 … … 285 298 (:crf (use-crf-temp vreg-value)) 286 299 ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address) 287 (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) 300 (if result-p 301 (note-vinsn-sets-gpr vinsn vreg-value) 302 (note-vinsn-refs-gpr vinsn vreg-value)) 288 303 (use-imm-temp vreg-value)) 289 304 ((:single-float :double-float) 290 305 (use-fp-reg vreg) 291 (when result-p (note-vinsn-sets-fpr-lreg vinsn vreg))) 306 (if result-p 307 (note-vinsn-sets-fpr-lreg vinsn vreg) 308 (note-vinsn-refs-fpr-lreg vinsn vreg))) 292 309 ((:imm t) 293 (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) 310 (if result-p 311 (note-vinsn-sets-gpr vinsn vreg-value) 312 (note-vinsn-refs-gpr vinsn vreg-value)) 294 313 (if (logbitp vreg-value *backend-imm-temps*) 295 314 (use-imm-temp vreg-value) … … 297 316 (:lisp 298 317 (use-node-temp vreg-value) 299 (when result-p (note-vinsn-sets-gpr vinsn vreg-value))) 318 (if result-p 319 (note-vinsn-sets-gpr vinsn vreg-value) 320 (note-vinsn-refs-gpr vinsn vreg-value))) 300 321 (:extended))) 301 322 (unless (or (eq class 't) (vreg-ok-for-storage-class vreg class))
Note:
See TracChangeset
for help on using the changeset viewer.
