Changeset 16439


Ignore:
Timestamp:
Jun 28, 2015, 6:18:23 AM (4 years ago)
Author:
gb
Message:

Don't use SPILL-AND-SPLIT-INTERVAL to deal with intervals whose physical
registers are killed by a CALL; simply treat those registers as caller-save.
I am not certain why, but cases like

(if something (call) no-call)

didn't work correctly if the spill-and-split happened on one arm of the
branch and not on the other.

a CALL is just something that increases register pressure, so we should
check to ensure that the same problem doesn't occur when that pressure is
dealt with in the same way when the pressure arises in other ways.

Location:
branches/lscan/source/compiler
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/lscan/source/compiler/X86/x862.lisp

    r16433 r16439  
    489489             (x862-stack-to-register seg ea gvector)
    490490             (x862-lri seg *x862-arg-y* 0)
    491              (! call-subprim-3 *x862-arg-z* (subprim-name->offset '.SPgvset) gvector *x862-arg-y* *x862-arg-z*)))
     491             (! call-subprim (subprim-name->offset '.SPgvset))))
    492492          ((memory-spec-p ea)    ; vstack slot
    493493           (x862-register-to-stack seg valreg ea))
     
    13081308        (progn
    13091309          (if (eql min 0)
    1310             (! check-max-args max)
     1310            (! check-max-nargs max)
    13111311            (! check-min-max-nargs min max))))
    13121312      (if fixed
     
    15411541          (when target-other
    15421542            (x862-copy-register seg arg target))
    1543           (! call-subprim-1 result (subprim-name->offset '.SPfix-overflow) arg)
     1543          (! call-subprim (subprim-name->offset '.SPfix-overflow))
    15441544          (when target-other
    15451545            (x862-copy-register seg target result))))
     
    28452845                          (eql (hard-regspec-value val-reg) *x862-arg-z*))
    28462846               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
    2847              (! call-subprim-3 val-reg(subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
     2847             (! call-subprim (subprim-name->offset '.SPgvset)))
    28482848            (is-node
    28492849             (if (and index-known-fixnum (<= index-known-fixnum
     
    35083508
    35093509(defun x862-make-closure (seg afunc downward-p)
    3510   (when *backend-use-linear-scan*
    3511     (signal 'linear-scan-bailout))
    3512   (with-x86-local-vinsn-macros (seg)
    3513     (flet ((var-to-reg (var target)
    3514              (let* ((ea (var-ea (var-bits var))))
    3515                (if ea
    3516                  (x862-addrspec-to-reg seg (x862-ea-open ea) target)
    3517                  (! load-nil target))
    3518                target))
    3519            (set-some-cells (dest cellno c0 c1 c2 c3)
    3520              (declare (fixnum cellno))
    3521              (! misc-set-c-node c0 dest cellno)
    3522              (incf cellno)
    3523              (when c1
    3524                (! misc-set-c-node c1 dest cellno)
    3525                (incf cellno)
    3526                (when c2
    3527                  (! misc-set-c-node c2 dest cellno)
     3510  (if *backend-use-linear-scan*
     3511    (with-x86-local-vinsn-macros (seg)
     3512
     3513      (let* ((header ($ x8664::imm0 :mode :u64))
     3514             (disp ($ x8664::imm1 :mode :s64))
     3515             (dest ($ x8664::arg_z))
     3516             (inherited-vars (afunc-inherited-vars afunc))
     3517             (arch (backend-target-arch *target-backend*))
     3518             (vsize (+ (length inherited-vars)
     3519                       5                ; %closure-code%, afunc
     3520                       1))
     3521             (cell 4))
     3522        (! lri header (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
     3523        (! lri disp  (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc))
     3524        (! %allocate-uvector dest)
     3525        (! init-nclosure dest)
     3526        (let* ((func (?)))
     3527          (x862-store-immediate seg (x862-afunc-lfun-ref afunc) func)
     3528          (! misc-set-c-node func dest cell)
     3529          (incf cell))
     3530        (dolist ( var inherited-vars)
     3531          (let* ((reg (var-lreg (var-bits var))))
     3532            (! misc-set-c-node reg dest cell) ; ? vcell or contents ?
     3533            (incf cell)))
     3534        (let* ((bits (?)))
     3535          (x862-lri seg bits (ash (logior (ash -1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*))
     3536          (! misc-set-c-node bits dest cell))
     3537          (! finalize-closure dest)
     3538          dest))
     3539      (with-x86-local-vinsn-macros (seg)
     3540        (flet ((var-to-reg (var target)
     3541                 (let* ((ea (var-ea (var-bits var))))
     3542                   (if ea
     3543                     (x862-addrspec-to-reg seg (x862-ea-open ea) target)
     3544                     (! load-nil target))
     3545                   target))
     3546               (set-some-cells (dest cellno c0 c1 c2 c3)
     3547                 (declare (fixnum cellno))
     3548                 (! misc-set-c-node c0 dest cellno)
    35283549                 (incf cellno)
    3529                  (when c3
    3530                    (! misc-set-c-node c3 dest cellno)
    3531                    (incf cellno))))
    3532              cellno))
    3533       (let* ((inherited-vars (afunc-inherited-vars afunc))
    3534              (arch (backend-target-arch *target-backend*))
    3535              (dest ($ *x862-arg-z*))
    3536              (vsize (+ (length inherited-vars)
    3537                        (target-arch-case
    3538                         (:x8632 7)
    3539                         (:x8664 5))     ; %closure-code%, afunc
    3540                        1)))             ; lfun-bits
    3541         (declare (list inherited-vars))
    3542         (let* ((cell (target-arch-case (:x8632 6)
    3543                                        (:x8664 4))))
    3544           (declare (fixnum cell))
    3545           (if downward-p
    3546             (progn
    3547               (! make-fixed-stack-gvector
    3548                  dest
    3549                  (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch))
    3550                  (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
    3551               (x862-open-undo $undostkblk))
    3552             (progn
    3553               (x862-lri seg
    3554                         *x862-imm0*
    3555                         (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
    3556               (target-arch-case
    3557                (:x8632
    3558                 (! setup-uvector-allocation *x862-imm0*)
    3559                 (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc)))
    3560                (:x8664
    3561                 (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc))))
    3562               (! %allocate-uvector dest)))
    3563           (! init-nclosure *x862-arg-z*)
     3550                 (when c1
     3551                   (! misc-set-c-node c1 dest cellno)
     3552                   (incf cellno)
     3553                   (when c2
     3554                     (! misc-set-c-node c2 dest cellno)
     3555                     (incf cellno)
     3556                     (when c3
     3557                       (! misc-set-c-node c3 dest cellno)
     3558                       (incf cellno))))
     3559                 cellno))
     3560          (let* ((inherited-vars (afunc-inherited-vars afunc))
     3561                 (arch (backend-target-arch *target-backend*))
     3562                 (dest ($ *x862-arg-z*))
     3563                 (vsize (+ (length inherited-vars)
     3564                           (target-arch-case
     3565                            (:x8632 7)
     3566                            (:x8664 5)) ; %closure-code%, afunc
     3567                           1)))         ; lfun-bits
     3568            (declare (list inherited-vars))
     3569            (let* ((cell (target-arch-case (:x8632 6)
     3570                                           (:x8664 4))))
     3571              (declare (fixnum cell))
     3572              (if downward-p
     3573                (progn
     3574                  (! make-fixed-stack-gvector
     3575                     dest
     3576                     (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch))
     3577                     (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
     3578                  (x862-open-undo $undostkblk))
     3579                (progn
     3580                  (x862-lri seg
     3581                            *x862-imm0*
     3582                            (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
     3583                  (target-arch-case
     3584                   (:x8632
     3585                    (! setup-uvector-allocation *x862-imm0*)
     3586                    (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc)))
     3587                   (:x8664
     3588                    (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc))))
     3589                  (! %allocate-uvector dest)))
     3590              (! init-nclosure *x862-arg-z*)
    35643591          ;;; xxx --- x8632 likely to have register conflicts with *x862-ra0*
    3565           (x862-store-immediate seg (x862-afunc-lfun-ref afunc) *x862-ra0*)
    3566           (target-arch-case
    3567            (:x8632
    3568             (with-node-temps (*x862-arg-z*) (t0)
    3569               (do* ((func *x862-ra0* nil))
    3570                    ((null inherited-vars))
    3571                 (let* ((t0r (or func (if inherited-vars
    3572                                        (var-to-reg (pop inherited-vars) t0)))))
    3573                   (! misc-set-c-node t0r dest cell)
    3574                   (incf cell)))))
    3575            (:x8664
    3576             (with-node-temps (*x862-arg-z*) (t0 t1 t2 t3)
    3577               (do* ((func *x862-ra0* nil))
    3578                    ((null inherited-vars))
    3579                 (let* ((t0r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
    3580                        (t1r (if inherited-vars (var-to-reg (pop inherited-vars) t1)))
    3581                        (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
    3582                        (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
    3583                   (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))))
    3584           (x862-lri seg *x862-arg-y* (ash (logior (ash -1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*))
    3585           (! misc-set-c-node *x862-arg-y* dest cell))
    3586         (! finalize-closure dest)
    3587         dest))))
     3592              (x862-store-immediate seg (x862-afunc-lfun-ref afunc) *x862-ra0*)
     3593              (target-arch-case
     3594               (:x8632
     3595                (with-node-temps (*x862-arg-z*) (t0)
     3596                  (do* ((func *x862-ra0* nil))
     3597                       ((null inherited-vars))
     3598                    (let* ((t0r (or func (if inherited-vars
     3599                                           (var-to-reg (pop inherited-vars) t0)))))
     3600                      (! misc-set-c-node t0r dest cell)
     3601                      (incf cell)))))
     3602               (:x8664
     3603                (with-node-temps (*x862-arg-z*) (t0 t1 t2 t3)
     3604                  (do* ((func *x862-ra0* nil))
     3605                       ((null inherited-vars))
     3606                    (let* ((t0r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
     3607                           (t1r (if inherited-vars (var-to-reg (pop inherited-vars) t1)))
     3608                           (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
     3609                           (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
     3610                      (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))))
     3611              (x862-lri seg *x862-arg-y* (ash (logior (ash -1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*))
     3612              (! misc-set-c-node *x862-arg-y* dest cell))
     3613            (! finalize-closure dest)
     3614            dest)))))
    35883615       
    35893616(defun x862-symbol-entry-locative (sym)
     
    47564783
    47574784(defun x862-lexical-reference-ea (form &optional (no-closed-p t))
     4785  (unless *backend-use-linear-scan*
    47584786  (when (acode-p (setq form (acode-unwrapped-form-value form)))
    47594787    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
     
    47624790          addr
    47634791          (unless (and no-closed-p (addrspec-vcell-p addr ))
    4764             addr))))))
     4792            addr)))))))
    47654793
    47664794
     
    48104838(defun x862-copy-register (seg dest src)
    48114839  (unless (eq dest src)
    4812   (with-x86-local-vinsn-macros (seg)
    4813     (when dest
    4814       (let* ((dest-gpr (if (eql (hard-regspec-class dest) hard-reg-class-gpr) dest))
    4815              (src-gpr (if src (if (eql (hard-regspec-class src) hard-reg-class-gpr) src)))
    4816              (dest-fpr (if (eql (hard-regspec-class dest) hard-reg-class-fpr) dest))
    4817              (src-fpr (if src (if (eql (hard-regspec-class src) hard-reg-class-fpr) dest)))
    4818              (src-mode (if src (get-regspec-mode src)))
    4819              (dest-mode (get-regspec-mode dest))
    4820              (dest-crf (and dest (eql (hard-regspec-class  dest) hard-reg-class-crf) dest)))
    4821         (if (null src)
    4822           (if dest-gpr
    4823             (! load-nil dest-gpr)
    4824             (if dest-crf
    4825               (! set-eq-bit)))
    4826           (if (and dest-crf src-gpr)
    4827             ;; "Copying" a GPR to a CR field means comparing it to rnil
    4828             (! compare-to-nil src)
    4829             (if (and dest-gpr src-gpr)
    4830               (if (eq src-mode dest-mode)
    4831                 (unless (eq src-gpr dest-gpr)
    4832                   (! copy-gpr dest src))
    4833                 ;; This is the "GPR <- GPR" case.  There are
    4834                 ;; word-size dependencies, but there's also
    4835                 ;; lots of redundancy here.
    4836                 (target-arch-case
    4837                  (:x8632
    4838                   (ecase dest-mode
    4839                     (#.hard-reg-class-gpr-mode-node ; boxed result.
    4840                      (case src-mode
    4841                        (#.hard-reg-class-gpr-mode-node
    4842                         (unless (eql  dest-gpr src-gpr)
    4843                           (! copy-gpr dest src)))
    4844                        (#.hard-reg-class-gpr-mode-u32
    4845                         (x862-box-u32 seg dest src))
    4846                        (#.hard-reg-class-gpr-mode-s32
    4847                         (x862-box-s32 seg dest src))
    4848                        (#.hard-reg-class-gpr-mode-u16
    4849                         (! box-fixnum dest src))
    4850                        (#.hard-reg-class-gpr-mode-s16
    4851                         (! box-fixnum dest src))
    4852                        (#.hard-reg-class-gpr-mode-u8
    4853                         (! box-fixnum dest src))
    4854                        (#.hard-reg-class-gpr-mode-s8
    4855                         (! box-fixnum dest src))
    4856                        (#.hard-reg-class-gpr-mode-address
    4857                         (x862-macptr->heap seg dest src))))
    4858                     ((#.hard-reg-class-gpr-mode-u32
    4859                       #.hard-reg-class-gpr-mode-address)
    4860                      (case src-mode
    4861                        (#.hard-reg-class-gpr-mode-node
    4862                         (let* ((src-type (get-node-regspec-type-modes src)))
    4863                           (declare (fixnum src-type))
    4864                           (case dest-mode
    4865                             (#.hard-reg-class-gpr-mode-u32
    4866                              (! unbox-u32 dest src))
    4867                             (#.hard-reg-class-gpr-mode-address
    4868                              (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
    4869                                          *x862-reckless*)
    4870                                (! trap-unless-macptr src))
    4871                              (! deref-macptr dest src)))))
    4872                        ((#.hard-reg-class-gpr-mode-u32
    4873                          #.hard-reg-class-gpr-mode-s32
    4874                          #.hard-reg-class-gpr-mode-address)
    4875                         (unless (eql  dest-gpr src-gpr)
    4876                           (! copy-gpr dest src)))
    4877                        (#.hard-reg-class-gpr-mode-u16
    4878                         (! u16->u32 dest src))                 
    4879                        (#.hard-reg-class-gpr-mode-s16
    4880                         (! s16->s32 dest src))
    4881                        (#.hard-reg-class-gpr-mode-u8
    4882                         (! u8->u32 dest src))
    4883                        (#.hard-reg-class-gpr-mode-s8
    4884                         (! s8->s32 dest src))))
    4885                     (#.hard-reg-class-gpr-mode-s32
    4886                      (case src-mode
    4887                        (#.hard-reg-class-gpr-mode-node
    4888                         (! unbox-s32 dest src))
    4889                        ((#.hard-reg-class-gpr-mode-u32
    4890                          #.hard-reg-class-gpr-mode-s32
    4891                          #.hard-reg-class-gpr-mode-address)
    4892                         (unless (eql  dest-gpr src-gpr)
    4893                           (! copy-gpr dest src)))
    4894                        (#.hard-reg-class-gpr-mode-u16
    4895                         (! u16->u32 dest src))                 
    4896                        (#.hard-reg-class-gpr-mode-s16
    4897                         (! s16->s32 dest src))
    4898                        (#.hard-reg-class-gpr-mode-u8
    4899                         (! u8->u32 dest src))
    4900                        (#.hard-reg-class-gpr-mode-s8
    4901                         (! s8->s32 dest src))))
    4902                     (#.hard-reg-class-gpr-mode-u16
    4903                      (case src-mode
    4904                        (#.hard-reg-class-gpr-mode-node
    4905                         (! unbox-u16 dest src))
    4906                        ((#.hard-reg-class-gpr-mode-u8
    4907                          #.hard-reg-class-gpr-mode-s8)
    4908                         (! u8->u32 dest src))
    4909                        (t
    4910                         (unless (eql dest-gpr src-gpr)
    4911                           (! copy-gpr dest src)))))
    4912                     (#.hard-reg-class-gpr-mode-s16
    4913                      (case src-mode
    4914                        (#.hard-reg-class-gpr-mode-node
    4915                         (! unbox-s16 dest src))
    4916                        (#.hard-reg-class-gpr-mode-s8
    4917                         (! s8->s32 dest src))
    4918                        (#.hard-reg-class-gpr-mode-u8
    4919                         (! u8->u32 dest src))
    4920                        (t
    4921                         (unless (eql dest-gpr src-gpr)
    4922                           (! copy-gpr dest src)))))
    4923                     (#.hard-reg-class-gpr-mode-u8
    4924                      (case src-mode
    4925                        (#.hard-reg-class-gpr-mode-node
    4926                         (if *x862-reckless*
    4927                           (! %unbox-u8 dest src)
    4928                           (! unbox-u8 dest src)))
    4929                        (t
    4930                         (unless (eql dest-gpr src-gpr)
    4931                           (! copy-gpr dest src)))))
    4932                     (#.hard-reg-class-gpr-mode-s8
    4933                      (case src-mode
    4934                        (#.hard-reg-class-gpr-mode-node
    4935                         (! unbox-s8 dest src))
    4936                        (t
    4937                         (unless (eql dest-gpr src-gpr)
    4938                           (! copy-gpr dest src)))))))
    4939                  (:x8664
    4940                   (ecase dest-mode
    4941                     (#.hard-reg-class-gpr-mode-node ; boxed result.
    4942                      (case src-mode
    4943                        (#.hard-reg-class-gpr-mode-node
    4944                         (unless (eql  dest-gpr src-gpr)
    4945                           (! copy-gpr dest src)))
    4946                        (#.hard-reg-class-gpr-mode-u64
    4947                         (x862-box-u64 seg dest src))
    4948                        (#.hard-reg-class-gpr-mode-s64
    4949                         (x862-box-s64 seg dest src))
    4950                        (#.hard-reg-class-gpr-mode-u32
    4951                         (x862-box-u32 seg dest src))
    4952                        (#.hard-reg-class-gpr-mode-s32
    4953                         (x862-box-s32 seg dest src))
    4954                        (#.hard-reg-class-gpr-mode-u16
    4955                         (! box-fixnum dest src))
    4956                        (#.hard-reg-class-gpr-mode-s16
    4957                         (! box-fixnum dest src))
    4958                        (#.hard-reg-class-gpr-mode-u8
    4959                         (! box-fixnum dest src))
    4960                        (#.hard-reg-class-gpr-mode-s8
    4961                         (! box-fixnum dest src))
    4962                        (#.hard-reg-class-gpr-mode-address
    4963                         (x862-macptr->heap seg dest src))))
    4964                     ((#.hard-reg-class-gpr-mode-u64
    4965                       #.hard-reg-class-gpr-mode-address)
    4966                      (case src-mode
    4967                        (#.hard-reg-class-gpr-mode-node
    4968                         (let* ((src-type (get-node-regspec-type-modes src)))
    4969                           (declare (fixnum src-type))
    4970                           (case dest-mode
    4971                             (#.hard-reg-class-gpr-mode-u64
    4972                              (! unbox-u64 dest src))
    4973                             (#.hard-reg-class-gpr-mode-address
    4974                              (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
    4975                                          *x862-reckless*)
    4976                                (! trap-unless-macptr src))
    4977                              (! deref-macptr dest src)))))
    4978                        ((#.hard-reg-class-gpr-mode-u64
    4979                          #.hard-reg-class-gpr-mode-s64
    4980                          #.hard-reg-class-gpr-mode-address)
    4981                         (unless (eql  dest-gpr src-gpr)
    4982                           (! copy-gpr dest src)))
    4983                        ((#.hard-reg-class-gpr-mode-u16
    4984                          #.hard-reg-class-gpr-mode-s16)
    4985                         (! u16->u32 dest src))
    4986                        ((#.hard-reg-class-gpr-mode-u8
    4987                          #.hard-reg-class-gpr-mode-s8)
    4988                         (! u8->u32 dest src))))
    4989                     (#.hard-reg-class-gpr-mode-s64
    4990                      (case src-mode
    4991                        (#.hard-reg-class-gpr-mode-node
    4992                         (! unbox-s64 dest src))
    4993                        ((#.hard-reg-class-gpr-mode-u64
    4994                          #.hard-reg-class-gpr-mode-s64
    4995                          #.hard-reg-class-gpr-mode-address)
    4996                         (unless (eql  dest-gpr src-gpr)
    4997                           (! copy-gpr dest src)))
    4998                        ((#.hard-reg-class-gpr-mode-u16
    4999                          #.hard-reg-class-gpr-mode-s16)
    5000                         (! s16->s32 dest src))
    5001                        ((#.hard-reg-class-gpr-mode-u8
    5002                          #.hard-reg-class-gpr-mode-s8)
    5003                         (! s8->s32 dest src))))
    5004                     (#.hard-reg-class-gpr-mode-s32
    5005                      (case src-mode
    5006                        (#.hard-reg-class-gpr-mode-node
    5007                         (! unbox-s32 dest src))
    5008                        ((#.hard-reg-class-gpr-mode-u32
    5009                          #.hard-reg-class-gpr-mode-s32
    5010                          #.hard-reg-class-gpr-mode-address)
    5011                         (unless (eql  dest-gpr src-gpr)
    5012                           (! copy-gpr dest src)))
    5013                        (#.hard-reg-class-gpr-mode-u16
    5014                         (! u16->u32 dest src))                 
    5015                        (#.hard-reg-class-gpr-mode-s16
    5016                         (! s16->s32 dest src))
    5017                        (#.hard-reg-class-gpr-mode-u8
    5018                         (! u8->u32 dest src))
    5019                        (#.hard-reg-class-gpr-mode-s8
    5020                         (! s8->s32 dest src))))
    5021                     (#.hard-reg-class-gpr-mode-u32
    5022                      (case src-mode
    5023                        (#.hard-reg-class-gpr-mode-node
    5024                         (if *x862-reckless*
    5025                           (! %unbox-u32 dest src)
    5026                           (! unbox-u32 dest src)))
    5027                        ((#.hard-reg-class-gpr-mode-u32
    5028                          #.hard-reg-class-gpr-mode-s32)
    5029                         (unless (eql  dest-gpr src-gpr)
    5030                           (! copy-gpr dest src)))
    5031                        (#.hard-reg-class-gpr-mode-u16
    5032                         (! u16->u32 dest src))                 
    5033                        (#.hard-reg-class-gpr-mode-s16
    5034                         (! s16->s32 dest src))
    5035                        (#.hard-reg-class-gpr-mode-u8
    5036                         (! u8->u32 dest src))
    5037                        (#.hard-reg-class-gpr-mode-s8
    5038                         (! s8->s32 dest src))))
    5039                     (#.hard-reg-class-gpr-mode-u16
    5040                      (case src-mode
    5041                        (#.hard-reg-class-gpr-mode-node
    5042                         (if *x862-reckless*
    5043                           (! %unbox-u16 dest src)
    5044                           (! unbox-u16 dest src)))
    5045                        ((#.hard-reg-class-gpr-mode-u8
    5046                          #.hard-reg-class-gpr-mode-s8)
    5047                         (! u8->u32 dest src))
    5048                        (t
    5049                         (unless (eql dest-gpr src-gpr)
    5050                           (! copy-gpr dest src)))))
    5051                     (#.hard-reg-class-gpr-mode-s16
    5052                      (case src-mode
    5053                        (#.hard-reg-class-gpr-mode-node
    5054                         (! unbox-s16 dest src))
    5055                        (#.hard-reg-class-gpr-mode-s8
    5056                         (! s8->s32 dest src))
    5057                        (#.hard-reg-class-gpr-mode-u8
    5058                         (! u8->u32 dest src))
    5059                        (t
    5060                         (unless (eql dest-gpr src-gpr)
    5061                           (! copy-gpr dest src)))))
    5062                     (#.hard-reg-class-gpr-mode-u8
    5063                      (case src-mode
    5064                        (#.hard-reg-class-gpr-mode-node
    5065                         (if *x862-reckless*
    5066                           (! %unbox-u8 dest src)
    5067                           (! unbox-u8 dest src)))
    5068                        (t
    5069                         (unless (eql dest-gpr src-gpr)
    5070                           (! copy-gpr dest src)))))
    5071                     (#.hard-reg-class-gpr-mode-s8
    5072                      (case src-mode
    5073                        (#.hard-reg-class-gpr-mode-node
    5074                         (! unbox-s8 dest src))
    5075                        (t
    5076                         (unless (eql dest-gpr src-gpr)
    5077                           (! copy-gpr dest src)))))))))
    5078               (if src-gpr
    5079                 (if dest-fpr
    5080                   (progn
    5081                     (case src-mode
     4840    (with-x86-local-vinsn-macros (seg)
     4841      (when dest
     4842        (let* ((dest-gpr (if (eql (hard-regspec-class dest) hard-reg-class-gpr) dest))
     4843               (src-gpr (if src (if (eql (hard-regspec-class src) hard-reg-class-gpr) src)))
     4844               (dest-fpr (if (eql (hard-regspec-class dest) hard-reg-class-fpr) dest))
     4845               (src-fpr (if src (if (eql (hard-regspec-class src) hard-reg-class-fpr) dest)))
     4846               (src-mode (if src (get-regspec-mode src)))
     4847               (dest-mode (get-regspec-mode dest))
     4848               (dest-crf (and dest (eql (hard-regspec-class  dest) hard-reg-class-crf) dest)))
     4849          (if (null src)
     4850            (if dest-gpr
     4851              (! load-nil dest-gpr)
     4852              (if dest-crf
     4853                (! set-eq-bit)))
     4854            (if (and dest-crf src-gpr)
     4855              ;; "Copying" a GPR to a CR field means comparing it to rnil
     4856              (! compare-to-nil src)
     4857              (if (and dest-gpr src-gpr)
     4858                (if (eq src-mode dest-mode)
     4859                  (unless (eq src-gpr dest-gpr)
     4860                    (! copy-gpr dest src))
     4861                  ;; This is the "GPR <- GPR" case.  There are
     4862                  ;; word-size dependencies, but there's also
     4863                  ;; lots of redundancy here.
     4864                  (target-arch-case
     4865                   (:x8632
     4866                    (ecase dest-mode
     4867                      (#.hard-reg-class-gpr-mode-node ; boxed result.
     4868                       (case src-mode
     4869                         (#.hard-reg-class-gpr-mode-node
     4870                          (unless (eql  dest-gpr src-gpr)
     4871                            (! copy-gpr dest src)))
     4872                         (#.hard-reg-class-gpr-mode-u32
     4873                          (x862-box-u32 seg dest src))
     4874                         (#.hard-reg-class-gpr-mode-s32
     4875                          (x862-box-s32 seg dest src))
     4876                         (#.hard-reg-class-gpr-mode-u16
     4877                          (! box-fixnum dest src))
     4878                         (#.hard-reg-class-gpr-mode-s16
     4879                          (! box-fixnum dest src))
     4880                         (#.hard-reg-class-gpr-mode-u8
     4881                          (! box-fixnum dest src))
     4882                         (#.hard-reg-class-gpr-mode-s8
     4883                          (! box-fixnum dest src))
     4884                         (#.hard-reg-class-gpr-mode-address
     4885                          (x862-macptr->heap seg dest src))))
     4886                      ((#.hard-reg-class-gpr-mode-u32
     4887                        #.hard-reg-class-gpr-mode-address)
     4888                       (case src-mode
     4889                         (#.hard-reg-class-gpr-mode-node
     4890                          (let* ((src-type (get-node-regspec-type-modes src)))
     4891                            (declare (fixnum src-type))
     4892                            (case dest-mode
     4893                              (#.hard-reg-class-gpr-mode-u32
     4894                               (! unbox-u32 dest src))
     4895                              (#.hard-reg-class-gpr-mode-address
     4896                               (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
     4897                                           *x862-reckless*)
     4898                                 (! trap-unless-macptr src))
     4899                               (! deref-macptr dest src)))))
     4900                         ((#.hard-reg-class-gpr-mode-u32
     4901                           #.hard-reg-class-gpr-mode-s32
     4902                           #.hard-reg-class-gpr-mode-address)
     4903                          (unless (eql  dest-gpr src-gpr)
     4904                            (! copy-gpr dest src)))
     4905                         (#.hard-reg-class-gpr-mode-u16
     4906                          (! u16->u32 dest src))                 
     4907                         (#.hard-reg-class-gpr-mode-s16
     4908                          (! s16->s32 dest src))
     4909                         (#.hard-reg-class-gpr-mode-u8
     4910                          (! u8->u32 dest src))
     4911                         (#.hard-reg-class-gpr-mode-s8
     4912                          (! s8->s32 dest src))))
     4913                      (#.hard-reg-class-gpr-mode-s32
     4914                       (case src-mode
     4915                         (#.hard-reg-class-gpr-mode-node
     4916                          (! unbox-s32 dest src))
     4917                         ((#.hard-reg-class-gpr-mode-u32
     4918                           #.hard-reg-class-gpr-mode-s32
     4919                           #.hard-reg-class-gpr-mode-address)
     4920                          (unless (eql  dest-gpr src-gpr)
     4921                            (! copy-gpr dest src)))
     4922                         (#.hard-reg-class-gpr-mode-u16
     4923                          (! u16->u32 dest src))                 
     4924                         (#.hard-reg-class-gpr-mode-s16
     4925                          (! s16->s32 dest src))
     4926                         (#.hard-reg-class-gpr-mode-u8
     4927                          (! u8->u32 dest src))
     4928                         (#.hard-reg-class-gpr-mode-s8
     4929                          (! s8->s32 dest src))))
     4930                      (#.hard-reg-class-gpr-mode-u16
     4931                       (case src-mode
     4932                         (#.hard-reg-class-gpr-mode-node
     4933                          (! unbox-u16 dest src))
     4934                         ((#.hard-reg-class-gpr-mode-u8
     4935                           #.hard-reg-class-gpr-mode-s8)
     4936                          (! u8->u32 dest src))
     4937                         (t
     4938                          (unless (eql dest-gpr src-gpr)
     4939                            (! copy-gpr dest src)))))
     4940                      (#.hard-reg-class-gpr-mode-s16
     4941                       (case src-mode
     4942                         (#.hard-reg-class-gpr-mode-node
     4943                          (! unbox-s16 dest src))
     4944                         (#.hard-reg-class-gpr-mode-s8
     4945                          (! s8->s32 dest src))
     4946                         (#.hard-reg-class-gpr-mode-u8
     4947                          (! u8->u32 dest src))
     4948                         (t
     4949                          (unless (eql dest-gpr src-gpr)
     4950                            (! copy-gpr dest src)))))
     4951                      (#.hard-reg-class-gpr-mode-u8
     4952                       (case src-mode
     4953                         (#.hard-reg-class-gpr-mode-node
     4954                          (if *x862-reckless*
     4955                            (! %unbox-u8 dest src)
     4956                            (! unbox-u8 dest src)))
     4957                         (t
     4958                          (unless (eql dest-gpr src-gpr)
     4959                            (! copy-gpr dest src)))))
     4960                      (#.hard-reg-class-gpr-mode-s8
     4961                       (case src-mode
     4962                         (#.hard-reg-class-gpr-mode-node
     4963                          (! unbox-s8 dest src))
     4964                         (t
     4965                          (unless (eql dest-gpr src-gpr)
     4966                            (! copy-gpr dest src)))))))
     4967                   (:x8664
     4968                    (ecase dest-mode
     4969                      (#.hard-reg-class-gpr-mode-node ; boxed result.
     4970                       (case src-mode
     4971                         (#.hard-reg-class-gpr-mode-node
     4972                          (unless (eql  dest-gpr src-gpr)
     4973                            (! copy-gpr dest src)))
     4974                         (#.hard-reg-class-gpr-mode-u64
     4975                          (x862-box-u64 seg dest src))
     4976                         (#.hard-reg-class-gpr-mode-s64
     4977                          (x862-box-s64 seg dest src))
     4978                         (#.hard-reg-class-gpr-mode-u32
     4979                          (x862-box-u32 seg dest src))
     4980                         (#.hard-reg-class-gpr-mode-s32
     4981                          (x862-box-s32 seg dest src))
     4982                         (#.hard-reg-class-gpr-mode-u16
     4983                          (! box-fixnum dest src))
     4984                         (#.hard-reg-class-gpr-mode-s16
     4985                          (! box-fixnum dest src))
     4986                         (#.hard-reg-class-gpr-mode-u8
     4987                          (! box-fixnum dest src))
     4988                         (#.hard-reg-class-gpr-mode-s8
     4989                          (! box-fixnum dest src))
     4990                         (#.hard-reg-class-gpr-mode-address
     4991                          (x862-macptr->heap seg dest src))))
     4992                      ((#.hard-reg-class-gpr-mode-u64
     4993                        #.hard-reg-class-gpr-mode-address)
     4994                       (case src-mode
     4995                         (#.hard-reg-class-gpr-mode-node
     4996                          (let* ((src-type (get-node-regspec-type-modes src)))
     4997                            (declare (fixnum src-type))
     4998                            (case dest-mode
     4999                              (#.hard-reg-class-gpr-mode-u64
     5000                               (! unbox-u64 dest src))
     5001                              (#.hard-reg-class-gpr-mode-address
     5002                               (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
     5003                                           *x862-reckless*)
     5004                                 (! trap-unless-macptr src))
     5005                               (! deref-macptr dest src)))))
     5006                         ((#.hard-reg-class-gpr-mode-u64
     5007                           #.hard-reg-class-gpr-mode-s64
     5008                           #.hard-reg-class-gpr-mode-address)
     5009                          (unless (eql  dest-gpr src-gpr)
     5010                            (! copy-gpr dest src)))
     5011                         ((#.hard-reg-class-gpr-mode-u16
     5012                           #.hard-reg-class-gpr-mode-s16)
     5013                          (! u16->u32 dest src))
     5014                         ((#.hard-reg-class-gpr-mode-u8
     5015                           #.hard-reg-class-gpr-mode-s8)
     5016                          (! u8->u32 dest src))))
     5017                      (#.hard-reg-class-gpr-mode-s64
     5018                       (case src-mode
     5019                         (#.hard-reg-class-gpr-mode-node
     5020                          (! unbox-s64 dest src))
     5021                         ((#.hard-reg-class-gpr-mode-u64
     5022                           #.hard-reg-class-gpr-mode-s64
     5023                           #.hard-reg-class-gpr-mode-address)
     5024                          (unless (eql  dest-gpr src-gpr)
     5025                            (! copy-gpr dest src)))
     5026                         ((#.hard-reg-class-gpr-mode-u16
     5027                           #.hard-reg-class-gpr-mode-s16)
     5028                          (! s16->s32 dest src))
     5029                         ((#.hard-reg-class-gpr-mode-u8
     5030                           #.hard-reg-class-gpr-mode-s8)
     5031                          (! s8->s32 dest src))))
     5032                      (#.hard-reg-class-gpr-mode-s32
     5033                       (case src-mode
     5034                         (#.hard-reg-class-gpr-mode-node
     5035                          (! unbox-s32 dest src))
     5036                         ((#.hard-reg-class-gpr-mode-u32
     5037                           #.hard-reg-class-gpr-mode-s32
     5038                           #.hard-reg-class-gpr-mode-address)
     5039                          (unless (eql  dest-gpr src-gpr)
     5040                            (! copy-gpr dest src)))
     5041                         (#.hard-reg-class-gpr-mode-u16
     5042                          (! u16->u32 dest src))                 
     5043                         (#.hard-reg-class-gpr-mode-s16
     5044                          (! s16->s32 dest src))
     5045                         (#.hard-reg-class-gpr-mode-u8
     5046                          (! u8->u32 dest src))
     5047                         (#.hard-reg-class-gpr-mode-s8
     5048                          (! s8->s32 dest src))))
     5049                      (#.hard-reg-class-gpr-mode-u32
     5050                       (case src-mode
     5051                         (#.hard-reg-class-gpr-mode-node
     5052                          (if *x862-reckless*
     5053                            (! %unbox-u32 dest src)
     5054                            (! unbox-u32 dest src)))
     5055                         ((#.hard-reg-class-gpr-mode-u32
     5056                           #.hard-reg-class-gpr-mode-s32)
     5057                          (unless (eql  dest-gpr src-gpr)
     5058                            (! copy-gpr dest src)))
     5059                         (#.hard-reg-class-gpr-mode-u16
     5060                          (! u16->u32 dest src))                 
     5061                         (#.hard-reg-class-gpr-mode-s16
     5062                          (! s16->s32 dest src))
     5063                         (#.hard-reg-class-gpr-mode-u8
     5064                          (! u8->u32 dest src))
     5065                         (#.hard-reg-class-gpr-mode-s8
     5066                          (! s8->s32 dest src))))
     5067                      (#.hard-reg-class-gpr-mode-u16
     5068                       (case src-mode
     5069                         (#.hard-reg-class-gpr-mode-node
     5070                          (if *x862-reckless*
     5071                            (! %unbox-u16 dest src)
     5072                            (! unbox-u16 dest src)))
     5073                         ((#.hard-reg-class-gpr-mode-u8
     5074                           #.hard-reg-class-gpr-mode-s8)
     5075                          (! u8->u32 dest src))
     5076                         (t
     5077                          (unless (eql dest-gpr src-gpr)
     5078                            (! copy-gpr dest src)))))
     5079                      (#.hard-reg-class-gpr-mode-s16
     5080                       (case src-mode
     5081                         (#.hard-reg-class-gpr-mode-node
     5082                          (! unbox-s16 dest src))
     5083                         (#.hard-reg-class-gpr-mode-s8
     5084                          (! s8->s32 dest src))
     5085                         (#.hard-reg-class-gpr-mode-u8
     5086                          (! u8->u32 dest src))
     5087                         (t
     5088                          (unless (eql dest-gpr src-gpr)
     5089                            (! copy-gpr dest src)))))
     5090                      (#.hard-reg-class-gpr-mode-u8
     5091                       (case src-mode
     5092                         (#.hard-reg-class-gpr-mode-node
     5093                          (if *x862-reckless*
     5094                            (! %unbox-u8 dest src)
     5095                            (! unbox-u8 dest src)))
     5096                         (t
     5097                          (unless (eql dest-gpr src-gpr)
     5098                            (! copy-gpr dest src)))))
     5099                      (#.hard-reg-class-gpr-mode-s8
     5100                       (case src-mode
     5101                         (#.hard-reg-class-gpr-mode-node
     5102                          (! unbox-s8 dest src))
     5103                         (t
     5104                          (unless (eql dest-gpr src-gpr)
     5105                            (! copy-gpr dest src)))))))))
     5106                (if src-gpr
     5107                  (if dest-fpr
     5108                    (progn
     5109                      (case src-mode
     5110                        (#.hard-reg-class-gpr-mode-node
     5111                         (case dest-mode
     5112                           (#.hard-reg-class-fpr-mode-double
     5113                            (unless (or (logbitp hard-reg-class-fpr-type-double
     5114                                                 (get-node-regspec-type-modes src))
     5115                                        *x862-reckless*)
     5116                              (! trap-unless-double-float src))
     5117                            (! get-double dest src))
     5118                           (#.hard-reg-class-fpr-mode-single
     5119                            (unless *x862-reckless* (! trap-unless-single-float src))
     5120                            (! get-single dest src))
     5121                           (#.hard-reg-class-fpr-mode-complex-single-float
     5122                            (unless *x862-reckless* (! trap-unless-complex-single-float src))
     5123                            (! get-complex-single-float dest src))
     5124                           (#.hard-reg-class-fpr-mode-complex-double-float
     5125                            (unless *x862-reckless* (! trap-unless-complex-double-float src))
     5126                            (! get-complex-double-float dest src)))))))
     5127                  (if dest-gpr
     5128                    (case dest-mode
    50825129                      (#.hard-reg-class-gpr-mode-node
    5083                        (case dest-mode
     5130                       (case src-mode
    50845131                         (#.hard-reg-class-fpr-mode-double
    5085                           (unless (or (logbitp hard-reg-class-fpr-type-double
    5086                                            (get-node-regspec-type-modes src))
    5087                                       *x862-reckless*)
    5088                             (! trap-unless-double-float src))
    5089                           (! get-double dest src))
     5132                          (x862-double->heap seg dest src))
     5133                         (#.hard-reg-class-fpr-mode-complex-double-float
     5134                          (x862-complex-double-float->heap seg dest src))
     5135                         (#.hard-reg-class-fpr-mode-complex-single-float
     5136                          (x862-complex-single-float->heap seg dest src))
    50905137                         (#.hard-reg-class-fpr-mode-single
    5091                           (unless *x862-reckless* (! trap-unless-single-float src))
    5092                           (! get-single dest src))
    5093                          (#.hard-reg-class-fpr-mode-complex-single-float
    5094                           (unless *x862-reckless* (! trap-unless-complex-single-float src))
    5095                           (! get-complex-single-float dest src))
    5096                          (#.hard-reg-class-fpr-mode-complex-double-float
    5097                           (unless *x862-reckless* (! trap-unless-complex-double-float src))
    5098                           (! get-complex-double-float dest src)))))))
    5099                 (if dest-gpr
    5100                   (case dest-mode
    5101                     (#.hard-reg-class-gpr-mode-node
    5102                      (case src-mode
    5103                        (#.hard-reg-class-fpr-mode-double
    5104                         (x862-double->heap seg dest src))
    5105                        (#.hard-reg-class-fpr-mode-complex-double-float
    5106                         (x862-complex-double-float->heap seg dest src))
    5107                        (#.hard-reg-class-fpr-mode-complex-single-float
    5108                         (x862-complex-single-float->heap seg dest src))
    5109                        (#.hard-reg-class-fpr-mode-single
    5110                         (target-arch-case
    5111                          (:x8632
    5112                           (x862-single->heap seg dest src))
    5113                          (:x8664
    5114                           (! single->node dest src)))))))
    5115                   (if (and src-fpr dest-fpr)
    5116                     (progn
    5117                     (unless nil
    5118                       (if (eql src-mode dest-mode)
    5119                         (case (fpr-mode-value-name src-mode)
    5120                           (:single-float (! copy-single-float dest src))
    5121                           (:double-float (! copy-double-float dest src))
    5122                           (:complex-single-float
    5123                            (! copy-complex-single-float dest src))
    5124                           (:complex-double-float
    5125                            (! copy-complex-double-float dest src)))
    5126                         (if (and (eql src-mode hard-reg-class-fpr-mode-double)
    5127                                  (eql dest-mode hard-reg-class-fpr-mode-single))
    5128                           (! copy-double-to-single dest src)
    5129                           (if (and (eql dest-mode hard-reg-class-fpr-mode-double)
    5130                                    (eql src-mode hard-reg-class-fpr-mode-single))
    5131                             (! copy-single-to-double dest src)))))))))))))))))
     5138                          (target-arch-case
     5139                           (:x8632
     5140                            (x862-single->heap seg dest src))
     5141                           (:x8664
     5142                            (! single->node dest src)))))))
     5143                    (if (and src-fpr dest-fpr)
     5144                      (progn
     5145                        (unless nil
     5146                          (if (eql src-mode dest-mode)
     5147                            (case (fpr-mode-value-name src-mode)
     5148                              (:single-float (! copy-single-float dest src))
     5149                              (:double-float (! copy-double-float dest src))
     5150                              (:complex-single-float
     5151                               (! copy-complex-single-float dest src))
     5152                              (:complex-double-float
     5153                               (! copy-complex-double-float dest src)))
     5154                            (if (and (eql src-mode hard-reg-class-fpr-mode-double)
     5155                                     (eql dest-mode hard-reg-class-fpr-mode-single))
     5156                              (! copy-double-to-single dest src)
     5157                              (if (and (eql dest-mode hard-reg-class-fpr-mode-double)
     5158                                       (eql src-mode hard-reg-class-fpr-mode-single))
     5159                                (! copy-single-to-double dest src)))))))))))))))))
    51325160
    51335161#||
     
    56375665                     ;
    56385666                     (logbitp $vbitdynamicextent bits))
    5639                (signal 'linear-scan-bailout)
     5667               (linear-scan-bailout)
    56405668               (cond ((logbitp $vbitspecial bits)
    56415669                      (x862-dbind seg val sym))
     
    57235751    (when *backend-use-linear-scan*
    57245752      (let*  ((reg (or (var-lreg var) (let* ((r (?))) (setf (var-lreg var) r)))))
    5725         (when (or (%ilogbitp $vbitspecial bits) closed-p)
    5726           (break "not yet special or closed variable ~s" var))
     5753        (when (or closed-p)
     5754          (linear-scan-bailout (format nil "not yet closed variable ~s" var)))
    57275755        (let* ((offset (ash vloc -3)))
    57285756          (when (< offset *x862-incoming-args-on-stack*)
    57295757            (setf (lreg-spill-offset reg) offset
    57305758                  (lreg-flags reg)
    5731                   (logior lreg-flag-spill lreg-flag-pre-spill))))))
     5759                  (logior lreg-flag-pre-spill))))))
    57325760    (if (%ilogbitp $vbitspecial bits)
    57335761      (progn
     
    61456173
    61466174
    6147 i(defun x862-ref-symbol-value (seg vreg xfer sym check-boundp)
     6175(defun x862-ref-symbol-value (seg vreg xfer sym check-boundp)
    61486176  (declare (ignorable check-boundp))
    61496177  (setq check-boundp (not *x862-reckless*))
     
    63606388        (! trap-unless-cons ptr-vreg))
    63616389      (if setcdr
    6362         (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPrplacd) ptr-vreg val-vreg)
    6363         (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPrplaca) ptr-vreg val-vreg))
     6390        (! call-subprim (subprim-name->offset '.SPrplacd))
     6391        (! call-subprim (subprim-name->offset '.SPrplaca)))
    63646392      (if returnptr
    63656393        (<- ptr-vreg)
     
    67526780                            (tag-label-value (aref *backend-labels* tag-label)))
    67536781                     (x862-lri seg *x862-imm0* (ash numnthrow *x862-target-fixnum-shift*))
     6782                     (! label-address ($ x8664::ra0) tag-label-value)
    67546783                     (if retval
    6755                        (! nthrowvalues tag-label-value)
    6756                        (! nthrow1value tag-label-value))
     6784                       (! nthrowvalues)
     6785                       (! nthrow1value))
    67576786                     (@= tag-label))
    67586787                   (setq numnthrow 0)
     
    68086837
    68096838
     6839(defun x862-dpayback (seg n)
     6840  (declare (fixnum n))
     6841   (with-x86-local-vinsn-macros (seg)
     6842     (unless (eql n 0)
     6843    (if (eql n 1)
     6844      (! call-subprim (subprim-name->offset '.SPunbind))
     6845      (progn
     6846        (! lri ($ x8664::imm0 :mode :u64) n)
     6847        (! call-subprim (subprim-name->offset '.SPunbind-n)))))))
     6848             
     6849
     6850             
     6851           
     6852
     6853 
    68106854;;; Restore the most recent dynamic bindings.  Bindings
    68116855;;; of *INTERRUPT-LEVEL* get special treatment.
     
    68146858    (let* ((n 0))
    68156859      (declare (fixnum n))
    6816       (dolist (r reasons (if (> n 0) (! dpayback n)))
     6860      (dolist (r reasons (if (> n 0) (x862-dpayback seg n)))
    68176861        (if (eql r $undospecial)
    68186862          (incf n)
     
    68206864            (progn
    68216865              (when (> n 0)
    6822                 (! dpayback n)
     6866                (x862-dpayback seg n)
    68236867                (setq n 0))
    68246868              (if (and *x862-open-code-inline*
     
    72927336      (if idx-subprim
    72937337        (setq subprim idx-subprim)
    7294         (if index (! lri ($ *x862-imm0*) (ash index *x862-target-fixnum-shift*))))
     7338        (if index (! lri ($ *x862-imm0* :mode :natural) (ash index *x862-target-fixnum-shift*))))
    72957339      (if tail-p
    72967340        (! jump-subprim subprim)
     
    82198263        (let* ((index (arch::builtin-function-name-offset name))
    82208264               (idx-subprim (x862-builtin-index-subprim index)))
    8221           (! call-subprim-2 ($ *x862-arg-z*) idx-subprim ($ *x862-arg-y*) ($ *x862-arg-z*)))
     8265          (! call-subprim idx-subprim ))
    82228266        (@ done)
    82238267        (<- ($ *x862-arg-z*))
     
    82988342       
    82998343(defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form)
     8344  '(when *backend-use-linear-scan*
     8345    (linear-scan-bailout))
     8346                                             
    83008347  (let* ((lreg (var-lreg varspec)))
    83018348    (if lreg
     
    85098556                spread-p))
    85108557
    8511 (defx862 x862-builtin-call builtin-call (seg vreg xfer index arglist)
     8558(defx862 x862-builtin-call builtin-call (seg  vreg xfer index arglist)
    85128559  (let* ((nargs (x862-arglist seg arglist))
    85138560         (tail-p (and (x862-tailcallok xfer) (<= nargs *x862-target-num-arg-regs*)))
     
    85358582      (progn
    85368583        (! call-subprim subprim)
    8537         (<- *x862-arg-z*)
     8584        (<- ($ *x862-arg-z*))
    85388585        (^)))))
    85398586
     
    87168763         (cstack *x862-cstack*)
    87178764         (dest (if (backend-crf-p vreg) vreg (if vreg *x862-arg-z* (available-crf-temp *available-backend-crf-temps*))))
     8765         (destreg)
    87188766         (cd1 (x862-make-compound-cd
    87198767               (if (eq dest *x862-arg-z*) tag1 (x862-cd-merge (x862-cd-true xfer) tag1)) 0)))
    87208768    (while (cdr forms)
    8721       (x862-form seg dest (if (eq dest *x862-arg-z*) nil cd1) (car forms))
     8769      (setq destreg (make-unwired-lreg dest))
     8770      (x862-form seg destreg (if (eq dest *x862-arg-z*) nil cd1) (car forms))
    87228771      (when (eq dest *x862-arg-z*)
    87238772        (with-crf-target () val-crf
    8724           (x862-copy-register seg val-crf dest)
     8773          (x862-copy-register seg val-crf destreg)
    87258774          (x862-branch seg cd1)))
    87268775      (setq forms (%cdr forms)))
     
    87328781    (@ tag1)
    87338782    (when (eq dest *x862-arg-z*)
    8734       (<- *x862-arg-z*)
     8783      (<- destreg)
    87358784      (^))
    87368785    (@ tag2)))
     
    88338882              (! jump-subprim (subprim-name->offset '.SPbuiltin-minus))
    88348883              (progn
    8835                 (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-minus) ($ *x862-arg-y*) ($ *x862-arg-z*))
     8884                (! call-subprim (subprim-name->offset '.SPbuiltin-minus))
    88368885                (@ done)
    88378886                (x862-copy-register seg target ($ *x862-arg-z*)))))
     
    88818930            (! jump-subprim (subprim-name->offset '.SPbuiltin-plus))
    88828931            (progn
    8883               (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-plus) ($ *x862-arg-y*) ($ *x862-arg-z*))
     8932              (! call-subprim (subprim-name->offset '.SPbuiltin-plus) )
    88848933              (@ done)
    88858934              (x862-copy-register seg target ($ *x862-arg-z*)))))
     
    89508999                (! jump-subprim (subprim-name->offset '.SPbuiltin-logior))
    89519000                (progn
    8952                   (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-logior) ($ *x862-arg-y*) ($ *x862-arg-z*))
     9001                  (! call-subprim (subprim-name->offset '.SPbuiltin-logior))
    89539002                  (@ done)
    89549003                  (x862-copy-register seg target ($ *x862-arg-z*)))))
     
    90069055                (! jump-subprim (subprim-name->offset '.SPbuiltin-logand))
    90079056                (progn
    9008                   (! call-subprim-2 ($ *x862-arg-z*) (subprim-name->offset '.SPbuiltin-logand) ($ *x862-arg-y*) ($ *x862-arg-z*))
     9057                  (! call-subprim (subprim-name->offset '.SPbuiltin-logand))
    90099058                  (@ done)
    90109059                  (x862-copy-register seg target ($ *x862-arg-z*)))))
     
    92809329               (dolist (var rvars)
    92819330                 (let* ((bits (nx-var-bits var)))
    9282                    (when (or (logbitp $vbitspecial bits)
     9331                   (when (or ;;(logbitp $vbitspecial bits)
    92839332                             (logbitp $vbitclosed bits))
    9284                      (signal 'linear-scan-bailout))
     9333                     (slinear-scan-bailout))
    92859334                   (let* ((reg (?)))
    92869335                     (! vpop-register reg)
     
    1007010119            (x862-form
    1007110120             seg
    10072              (if need-break (if dest-vd *x862-arg-z*) dest-vd)
     10121             (if need-break (if dest-vd ($ *x862-arg-z*)) dest-vd)
    1007310122             (if need-break nil dest-cd)
    1007410123             value)
    1007510124            (when need-break
    1007610125              (x862-unwind-set seg dest-cd dest-stack)
    10077               (when dest-vd (x862-copy-register seg dest-vd *x862-arg-z*))
     10126              (when dest-vd (x862-copy-register seg dest-vd ($ *x862-arg-z*)))
    1007810127              (x862-branch seg dest-cd))))))
    1007910128    (x862-unreachable-store)))
     
    1009410143           (ensuring-node-target (target vreg)
    1009510144             (! lisp-word-ref-c target
    10096                 (x862-one-untargeted-reg-form seg base *x862-arg-z*)
     10145                (x862-one-untargeted-reg-form seg base  *x862-arg-z*)
    1009710146                (ash fixoffset *x862-target-fixnum-shift*)))
    1009810147           (^))
    1009910148          (t (multiple-value-bind (breg oreg)
    10100                                   (x862-two-untargeted-reg-forms seg base *x862-arg-y* offset *x862-arg-z*)
     10149                                  (x862-two-untargeted-reg-forms seg base  *x862-arg-y* offset *x862-arg-z*)
    1010110150               (ensuring-node-target (target vreg)
    1010210151                 (! lisp-word-ref target breg oreg))
     
    1014610195  (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc)
    1014710196    (let* ((arg ($ *x862-arg-z*))
    10148            (result ($ *x862-imm0*)))
     10197           (result ($ *x862-imm0* :mode :signed-natural)))
    1014910198      (x862-one-targeted-reg-form seg form arg)
    10150       (! call-subprim-1 result (subprim-name->offset '.SPinteger-sign) arg)
     10199      (! call-subprim (subprim-name->offset '.SPinteger-sign))
    1015110200    (x862-test-reg-%izerop seg vreg xfer result cr-bit true-p 0))))
    1015210201
     
    1017510224         (mv-pass (x862-mv-p xfer)))
    1017610225    (x862-one-targeted-reg-form seg tag ($ *x862-arg-z*))
     10226    (! label-address ($ x8664::xfn) tag-label-value)
    1017710227    (if mv-pass
    10178       (! nmkcatchmv tag-label-value)
    10179       (! nmkcatch1v tag-label-value))
     10228      (! call-subprim (subprim-name->offset '.SPmkcatchmv))
     10229      (! call-subprim (subprim-name->offset '.SPmkcatch1v)))
    1018010230    (x862-open-undo)
    1018110231    (if mv-pass
     
    1018310233      (x862-one-targeted-reg-form seg valform ($ *x862-arg-z*)))
    1018410234    (x862-lri seg *x862-imm0* (ash 1 *x862-target-fixnum-shift*))
     10235    (! label-address ($ x8664::ra0) tag-label-value)
    1018510236    (if mv-pass
    10186       (! nthrowvalues tag-label-value)
    10187       (! nthrow1value tag-label-value))
     10237      (! nthrowvalues)
     10238      (! nthrow1value))
    1018810239    (x862-close-undo)
    1018910240    (@= tag-label)
     
    1078210833         (protform-label (backend-get-next-label))
    1078310834         (old-stack (x862-encode-stack)))
    10784     (! nmkunwind
    10785        (aref *backend-labels* protform-label)
    10786        (aref *backend-labels* cleanup-label))
     10835    (! label-address ($ x8664::ra0) (aref *backend-labels* protform-label))
     10836    (! label-address ($ x8664::xfn) (aref *backend-labels* cleanup-label))
     10837    (! nmkunwind)
    1078710838    (x862-open-undo $undointerruptlevel)
    1078810839    (x862-adjust-vstack (* 3 *x862-target-node-size*))   
     
    1080710858    (! progvsave)
    1080810859    (x862-open-undo $undostkblk)
    10809     (! mkunwind
    10810        (aref *backend-labels* protform-label)
    10811        (aref *backend-labels* cleanup-label))
     10860    (! label-address ($ x8664::ra0) (aref *backend-labels* protform-label))
     10861    (! label-address ($ x8664::xfn) (aref *backend-labels* cleanup-label))
     10862    (! mkunwind)
    1081210863    (@= cleanup-label)
    1081310864    (! progvrestore)
  • branches/lscan/source/compiler/vinsn.lisp

    r16434 r16439  
    961961  parent
    962962  (spill-offset nil)
     963  (killed #() :type simple-vector)
    963964 
    964965)
     
    969970    (format stream "~d: ~s ~s/~s ~s (~s)" (interval-idx i)  (interval-lreg i) (interval-begin i) (interval-end i) (interval-regtype i) (interval-preg i))))
    970971
    971 (defun check-interval-lregs (seg)
    972   (dovector (x (vinsn-list-intervals seg))
    973     (let* ((lreg (interval-lreg x)))
    974       (when lreg (or (lreg-refs lreg) (lreg-defs lreg)
    975                      (break))))))
     972
    976973                   
    977974(defun remove-trivial-copies (header)
     
    981978             (dest (svref vp 0))
    982979             (src (svref vp 1)))
    983         (unless (typep dest 'lreg)
    984           (setf (svref vp 0) (setq dest (make-wired-lreg  dest))))
    985         (unless (typep src 'lreg)
    986           (setf (svref vp 1) (setq src (make-wired-lreg src))))
    987 
     980
     981        (when (typep dest 'fixnum) (setf (svref vp 0) (setq dest (make-unwired-lreg-like dest))) (push vinsn (lreg-defs dest)))
     982                                       
     983        (when (typep src 'fixnum) (setf (svref vp 0) (setq src (make-unwired-lreg-like src))) (push vinsn (lreg-refs src)))
    988984        ;; This is probably not the only case where we can't
    989985        ;; avoid removing a COPY instruction.
    990         (when (or (not (lreg-wired dest))
    991                   (let* ((srcval (lreg-value src))
    992                          (destval (lreg-value dest)))
    993                     (and srcval (eql srcval destval))))
     986        (when (and (not (cdr (lreg-defs dest)))
     987                   (or ;(not (lreg-wired dest))
     988                       (let* ((srcval (lreg-value src))
     989                              (destval (lreg-value dest)))
     990                         (and srcval (eql srcval destval)))))
    994991                       
    995992                   
     
    999996            (nsubstitute src dest (vinsn-variable-parts ref)))
    1000997          (setf (lreg-refs src) (delete vinsn (lreg-refs src)))
     998          (format t "~&~s triviaL" vinsn)
    1001999          (elide-vinsn vinsn))))))
    10021000
     
    10481046               (high (vinsn-sequence end-vinsn))
    10491047               (killed (make-array 4)))
    1050           (declare (simple-vector killed) (dynamic-extent killed))
     1048          (declare (simple-vector killed) )
    10511049          (unless (eq start-vinsn (callnode-mycall block))
    10521050            (break "bad callnode ~s" block))
    10531051          (registers-killed-by-call start-vinsn killed)
    1054           (dotimes (class (length killed))
    1055             (let* ((mask (svref killed class)))
    1056               (dotimes (i (integer-length mask))
    1057                 (when (logbitp i mask)
    1058                   (vector-push-extend (make-interval  nil high high class i ) list))))))))
     1052          (let* ((interval (make-interval nil low high nil nil)))
     1053            (setf (interval-killed interval) killed)
     1054            (vector-push-extend interval  list))
     1055          )))
    10591056             
    10601057               
     
    10661063             (min (vinsn-list-max-seq seg))
    10671064             (all (append (lreg-defs lreg) (lreg-refs lreg))))
     1065       
    10681066        (when all
    10691067          (dolist (p all)
     
    10721070                (setq min seq))
    10731071              (if (> seq max)
    1074                 (setq max seq))))
     1072               (setq max seq))))
    10751073          (let* ((class (lreg-class lreg))
    10761074                 (regtype (cond ((eql class hard-reg-class-fpr)
     
    10841082           
    10851083            (let* ((interval (make-interval lreg min max regtype nil)))
    1086               (setf (lreg-interval lreg) interval)
    10871084              (when (logbitp lreg-pre-spill-bit (lreg-flags lreg))
    10881085                (process-pre-spilled-interval seg interval lreg (lreg-spill-offset lreg)))
     
    11481145        (insert-dll-node-before vinsn target)
    11491146        (setf (vinsn-sequence vinsn) pred-seq)))))
     1147
     1148(defun insert-vinsn-after (vinsn target)
     1149  (let* ((target-seq (vinsn-sequence target))
     1150         (succ-seq (1+ target-seq))
     1151         (succ (vinsn-succ target)))
     1152    (declare (fixnum target-seq succ-seq))
     1153    (if (and (typep succ 'vinsn)
     1154             (eql (vinsn-sequence succ) succ-seq))
     1155      (insert-vinsn-after vinsn succ)
     1156      (progn
     1157        (insert-dll-node-after vinsn target)
     1158        (setf (vinsn-sequence vinsn) succ-seq)))))
    11501159         
    11511160;;; treat incoming stack arguments as if they had
     
    11711180          (when (< reload-seq (interval-begin interval))
    11721181            (setf (interval-begin interval) reload-seq)))))))
    1173      
    1174      
     1182
     1183(defun spill-offset-for-interval (seg interval)
     1184  (let* ((used (vinsn-list-spill-area-used seg))
     1185         (base (vinsn-list-spill-base seg))
     1186         (nregs (length (vinsn-list-lregs seg))))
     1187    (or (interval-spill-offset interval)
     1188        (setf (interval-spill-offset interval)
     1189              (if (eql (interval-regtype interval) interval-regtype-node)
     1190                (dotimes (i nregs)
     1191                  (when (eql 0 (sbit used i))
     1192                    (setf (sbit used i) 1)
     1193                    (incf (vinsn-list-spill-depth seg))
     1194                    (when (> (vinsn-list-spill-depth seg)
     1195                             (vinsn-list-max-spill-depth seg))
     1196                      (setf  (vinsn-list-max-spill-depth seg)
     1197                             (vinsn-list-spill-depth seg)))
     1198                    (return (+ i base))))
     1199                (prog1 (vinsn-list-nfp-spill-offset seg)
     1200                  (incf (vinsn-list-nfp-spill-offset seg) 16)
     1201                  (when (> (vinsn-list-nfp-spill-offset seg)
     1202                           (vinsn-list-max-nfp-spill-depth seg))
     1203                    (setf (vinsn-list-max-nfp-spill-depth seg)
     1204                          (vinsn-list-nfp-spill-offset seg)))))))))
     1205
     1206
     1207
    11751208(defun spill-and-split-interval (seg parent new-end vector list)
    1176   (check-interval-lregs seg)
     1209
    11771210
    11781211  (let* ((lreg (interval-lreg parent)))
     
    12051238                                       (setf (vinsn-list-max-nfp-spill-depth seg)
    12061239                                             (vinsn-list-nfp-spill-offset seg)))))))))
     1240                                   
    12071241          (let* ((spill-point (find-vinsn seg new-end))
    12081242                 (spill-vinsn (select-vinsn (spill-vinsn-for-interval parent) templates (list lreg offset))))
    12091243            ;;(push spill-vinsn (lreg-refs lreg))
    12101244            (insert-vinsn-before spill-vinsn spill-point)
    1211             (let* ((min (vinsn-list-max-seq seg)))
     1245            (let* ((min (vinsn-list-max-seq seg))
     1246                   (max (interval-end parent))
     1247                   (reloads ())
     1248                     
     1249                   )
     1250             
    12121251              (dolist (ref (lreg-refs lreg))
    12131252                (let*  ((seq (vinsn-sequence ref)))
    1214                   (format t "seq = ~s, new-end = ~a" seq new-end)
    12151253                  (when (> seq new-end)
    12161254                   
     
    12201258
    12211259                        (insert-vinsn-before reload-vinsn ref)
    1222                  
    1223                         (push reload-vinsn (lreg-defs lreg)))()))))
     1260                        (push reload-vinsn reloads)
     1261                        )()))))
    12241262              (dolist (def (lreg-defs lreg))
    1225                 (let*  ((seq (vinsn-sequence def)))
     1263                (let*  ((seq (vinsn-sequence def))
     1264                        )
    12261265 
    1227                       (when (> seq new-end)
    1228                         (if (< seq min) (setq min seq)))))
     1266                  (when (> seq new-end)
     1267                    (if (< seq min) (setq min seq))
     1268                    (unless (or parent-is-child (memq def reloads))
     1269                      (let* ((spill (select-vinsn (spill-vinsn-for-interval parent) templates (list lreg offset))))
     1270                       
     1271                        (insert-vinsn-after  spill def)
     1272                        (let* ((spill-seq (vinsn-sequence spill)))
     1273                          (when (> spill-seq max)
     1274                            (setq max spill-seq))))))))
    12291275              (when (eql min (vinsn-list-max-seq seg)) (break "refs - ~s, defs =  ~s, new-end = ~s" (lreg-refs lreg) (lreg-defs lreg) new-end) (compiler-bug "empty interval"))
    1230               (let* ((child (make-interval  lreg min (interval-end parent) (interval-regtype parent) nil  )))
    1231                     (setf (interval-parent child) parent
    1232                           (interval-spill-offset child) offset)
    1233                     (do-dll-nodes (r list (error "no next interval"))
    1234                       (when (> (interval-begin r) min)
    1235                         (insert-dll-node-before child r)
    1236                         (rebuild-interval-vector vector  child r)   
    1237                         (return)))
     1276              (let* ((child (make-interval  lreg min max (interval-regtype parent) nil  )))
     1277                (setf (interval-parent child) parent
     1278                      (interval-spill-offset child) offset)
     1279                (do-dll-nodes (r list (error "no next interval"))
     1280                  (when (> (interval-begin r) min)
     1281                    (insert-dll-node-before child r)
     1282                    (rebuild-interval-vector seg vector  child r)   
     1283                    (return)))
    12381284               
    12391285
    12401286
    1241                     ;; Ready to expire
    1242                     (setf (interval-end parent) (1-  new-end))))))))))
    1243 
    1244 
    1245 (defun rebuild-interval-vector (vector new-element succ)
     1287                ;; Ready to expire
     1288                (setf (interval-end parent) (1-  new-end))))))))))
     1289
     1290(defun assign-interval-indices (vector)
     1291  (declare (type (vector t) vector))
     1292  (dotimes (i (length vector))
     1293    (setf (interval-idx (aref vector i)) i)))
     1294
     1295(defun rebuild-interval-vector (seg vector new-element succ)
    12461296  (declare (type (vector t) vector))
    12471297  (let* ((idx (interval-idx succ)))
    1248     (declare (fixnum idx))
     1298    (declare (fixnum idx) (ignorable idx))
    12491299    (let* ((n (length vector)))
    1250       (declare (Fixnum n))
     1300      (declare (Fixnum n) (ignorable n))
     1301      (progn
     1302      (vector-push-extend new-element vector)
     1303      (setf (vinsn-list-intervals seg)
     1304      (sort vector (lambda (x y)
     1305                       (let* ((beginx (interval-begin x))
     1306                              (beginy (interval-begin y)))
     1307                         (or (< beginx beginy)
     1308                             (and (= beginx beginy)
     1309                                  (or (null (interval-lreg x))
     1310                                      (lreg-local-p (interval-lreg x))))))))))
     1311      #+no
     1312      (progn
    12511313      (vector-push-extend nil vector)   ; make room
     1314     
    12521315      (do* ((j n (1- j))
    12531316            (i (1- j) (1- i)))
    12541317           ((= j idx)
    1255             (setf (interval-idx new-element) idx)
    1256             (aref vector idx) new-element)
     1318            (setf (aref vector idx) new-element)
     1319)
     1320
    12571321        (declare (fixnum i j))
    12581322                               
    1259         (setf (aref vector j) (aref vector i))))))
     1323        (setf (aref vector j) (aref vector i))
     1324        ))
     1325      (assign-interval-indices vector)
     1326      )))
    12601327           
    12611328
     
    12641331  (let* ((seq (vinsn-sequence vinsn)))
    12651332    (declare (fixnum seq))
    1266     (when (= seq 2500) (break))
    12671333    (unless (or (< seq start) (> seq end))
    12681334      (let* ((v (vinsn-variable-parts vinsn)))
     
    13081374
    13091375
     1376
    13101377(defun linear-scan (seg )
    1311   (check-interval-lregs seg)
    13121378  (let* ((avail (vinsn-list-available-physical-registers seg)))
    13131379    (flet ((use-reg (regno type i)
     
    13361402               (expired (make-dll-header))
    13371403               (limit (vinsn-list-max-seq seg)))
     1404          (assign-interval-indices intervals)
    13381405          (dotimes (i (length intervals))
    13391406            (let*  ((interval (aref intervals i)))
    1340               (setf (interval-idx interval ) i)
    13411407              (append-dll-node interval unhandled)))
    13421408          (do* ((i (pop-dll-node unhandled) (pop-dll-node unhandled))
     
    13501416                (when (< other-end begin)
    13511417                  (expire-interval seg other expired))))
    1352            
    1353             (let* ((regtype (interval-regtype i))
    1354                    (mask (svref avail regtype))
    1355                    (idx (interval-idx i)))
    1356               (setf (interval-avail i) mask)
    1357               (when (and nil (eql 0 mask))
    1358                 (do-dll-nodes (victim active)
    1359                   (when (and (eql regtype (interval-regtype victim))
    1360                              (interval-lreg victim)
    1361                              (> (interval-end victim) begin))
    1362                     (when (eq i victim) (dbg))
    1363                     (return (spill-and-split-interval   seg victim begin intervals unhandled)))))
     1418
     1419            (if (null (interval-lreg i))
     1420              (let* ((caller-save ())
     1421                     (call-vinsn (find-vinsn seg begin))
     1422                     (templates (backend-p2-vinsn-templates *target-backend*)))
     1423                (do-dll-nodes (a active)
     1424                  (when (>= (interval-end a) (interval-end i))
     1425                    ;; should see if preg is in the killed set
     1426                    (push a caller-save)))
     1427                (dolist (cs caller-save)
     1428                  (let* ((offset (spill-offset-for-interval seg cs))
     1429                         (cs-lreg (interval-lreg cs))
     1430                         (spill-vinsn (select-vinsn (spill-vinsn-for-interval cs) templates (list cs-lreg offset)))
     1431                         (reload-vinsn (select-vinsn (reload-vinsn-for-interval cs) templates (list cs-lreg offset))))
     1432                    (insert-vinsn-before spill-vinsn call-vinsn)
     1433                    (insert-vinsn-after reload-vinsn call-vinsn)))
     1434                 
     1435                         
     1436                )
     1437           
     1438              (let* ((regtype (interval-regtype i))
     1439                     (mask (svref avail regtype))
     1440                     (idx (interval-idx i)))
     1441                (setf (interval-avail i) mask)
     1442                (when (eql 0 mask)
     1443                  (do-dll-nodes (victim active)
     1444                    (when (and (eql regtype (interval-regtype victim))
     1445                               (interval-lreg victim)
     1446                               (> (interval-end victim) begin))
     1447                      (return (progn (spill-and-split-interval   seg victim begin intervals unhandled) (expire-interval seg victim expired) (setq mask (svref avail regtype)) (when (eql mask 0) (break "mask is still 0 after spilling ~s" victim)))))))
    13641448                                 
    13651449
    13661450
    1367               (let* ((lreg (interval-lreg i))
    1368                      (regtype (interval-regtype i))
    1369                      (mask (svref avail regtype)))
    1370                 (let* ((fixed (interval-preg i))
    1371                        (targeted (and lreg (or (lreg-wired lreg) (lreg-local-p lreg)) (lreg-value lreg)))
    1372                        (preg (or fixed (if (and targeted (logbitp targeted mask))
    1373                                          targeted
    1374                                          (select-available-register-high mask)))))
    1375 
    1376 
    1377 
    1378                   (when (and fixed (not (logbitp fixed mask)))
    1379                     (let* ((other (do-dll-nodes (x active (error "can't find interval with ~d" fixed))
    1380                                     (when (and (eql regtype (interval-regtype x))
    1381                                                (eql fixed (interval-preg x))
    1382                                                (interval-lreg x))
     1451                (let* ((lreg (interval-lreg i))
     1452                       (regtype (interval-regtype i))
     1453                       (mask (svref avail regtype)))
     1454                  (let* ((fixed (interval-preg i))
     1455                         (targeted (and lreg (or (lreg-wired lreg) (lreg-local-p lreg)) (lreg-value lreg)))
     1456                         (preg (or fixed (if (and targeted (logbitp targeted mask))
     1457                                           targeted
     1458                                           (select-available-register-high mask)))))
     1459
     1460
     1461
     1462                    (when (and fixed (not (logbitp fixed mask)))
     1463                      (let* ((other (do-dll-nodes (x active (error "can't find interval with ~d" fixed))
     1464                                      (when (and (eql regtype (interval-regtype x))
     1465                                                 (eql fixed (interval-preg x))
     1466                                                 (interval-lreg x))
    13831467                                     
    1384                                       (return x)))))
    1385                       (spill-and-split-interval seg other begin intervals unhandled)))
    1386 
    1387                   (when (and targeted (not (eql targeted preg)))
    1388 
    1389                     (let*  ((rival (do-dll-nodes (other active (error "can't find rival on active-list"))
    1390                                      (when (and (eql (interval-preg other) targeted)
    1391                                                 (eql (interval-regtype other) regtype)
    1392                                                 )
    1393                                        (return other))))
    1394                             (rival-lreg (and rival (interval-lreg rival)))
    1395                             )
     1468                                        (return x)))))
     1469                        (spill-and-split-interval seg other begin intervals unhandled)))
     1470
     1471                    (when (and targeted (not (eql targeted preg)))
     1472
     1473                      (let*  ((rival (do-dll-nodes (other active (error "can't find rival on active-list"))
     1474                                       (when (and (eql (interval-preg other) targeted)
     1475                                                  (eql (interval-regtype other) regtype)
     1476                                                  )
     1477                                         (return other))))
     1478                              (rival-lreg (and rival (interval-lreg rival)))
     1479                              )
    13961480
    13971481                                       
    13981482
    1399                         (break "want to use reg ~d, for ~s in use by ~s. ~d may be free" targeted lreg rival-lreg preg)
    1400                       (cond ((null rival-lreg) (break "no lreg for conflicting interval ~s" rival))
    1401                             ((or (lreg-wired rival-lreg) (lreg-local-p rival-lreg))
    1402                              (if (or (eql (interval-end rival) begin)
    1403                                      (null (lreg-refs rival-lreg))
    1404                                      (null (lreg-refs lreg)))
    1405                                (setq preg targeted)
    1406                                (error "conflicting intervals overlap")))
    1407                                                  
    1408                             (rival
    1409                              (do* ((rival-idx (interval-idx rival) (1+ rival-idx))
    1410                                    (q rival (aref intervals rival-idx))
    1411                                    (rival-avail (interval-avail q) (logand rival-avail (if (eql regtype (interval-regtype q)) (interval-avail q) -1))))
    1412                                   ((= rival-idx idx)
    1413                                    (if (eql rival-avail 0)
    1414                                      (break)
    1415                                      (let*  ((other-preg (select-available-register-high rival-avail)))
    1416                                        ;;(format t "should have used ~d" other-preg)
    1417                                        (use-reg other-preg regtype rival)
     1483                        (format t "~&want to use reg ~d, for ~s in use by ~s. ~d may be free" targeted lreg rival-lreg preg)
     1484                        (cond ((null rival-lreg) (break "no lreg for conflicting interval ~s" rival))
     1485                              ((or (lreg-wired rival-lreg) (lreg-local-p rival-lreg))
     1486                               (if (or (and (lreg-wired lreg)
     1487                                            (lreg-wired rival-lreg))
     1488                                       (eql (interval-end rival) begin)
     1489                                       (null (lreg-refs rival-lreg))
     1490                                       (null (lreg-refs lreg)))
     1491                                 (setq preg targeted)
     1492                                 (error "conflicting intervals overlap")))
     1493
     1494                              ((eql (interval-end rival) begin)
     1495                               (setq preg targeted))
     1496                              (rival
     1497                               (do* ((rival-idx (interval-idx rival) (1+ rival-idx))
     1498                                     (q rival (aref intervals rival-idx))
     1499                                     (rival-avail (interval-avail q) (logand rival-avail (if (eql regtype (interval-regtype q)) (interval-avail q) -1))))
     1500                                    ((= rival-idx idx)
     1501                                     (if (eql rival-avail 0)
     1502                                       ;; we made an unfortunate choice when we
     1503                                       ;; assigned rhe register we want now  to
     1504                                       ;; the rival interval, and can't back out
     1505                                       ;; of that choice.  copy the rival's
     1506                                       ;; preg to something that is now free and
     1507                                       ;; split the rival.
     1508                                       (progn
     1509                                         (let* ((begin-vinsn (find-vinsn seg begin))
     1510                                                (begin-vp (vinsn-variable-parts begin-vinsn)))
     1511                                           (when (find rival-lreg begin-vp)
     1512                                             (break "surprise! ~s" begin-vinsn)))
     1513                                                                               
     1514                                         (spill-and-split-interval seg rival begin intervals unhandled))
     1515                                       (let*  ((other-preg (select-available-register-high rival-avail)))
     1516                                         ;;(format t "should have used ~d" other-preg)
     1517                                         (use-reg other-preg regtype rival)
    14181518                                     
    1419                                        (setf (interval-preg rival) other-preg)
    1420                                        (do* ((qidx (1+ (interval-idx rival)) (1+ qidx)))
    1421                                             ((= qidx idx)
    1422                                              (setf (svref avail regtype)
    1423                                                    (logior (svref avail regtype)
    1424                                                            (ash 1 targeted))))
    1425                                          (let* ((q (aref intervals qidx)))
    1426                                            (when (eql (interval-regtype q) regtype)
    1427                                              (setf (interval-avail q)
    1428                                                    (logandc2 (interval-avail q)
    1429                                                              (ash 1 other-preg)))))))))
    1430                                (setq preg targeted))))))
    1431 
    1432 
    1433                   (use-reg preg regtype i)
    1434                   (setf (interval-preg i) preg)
    1435                   (append-dll-node i active))))))))))
     1519                                         (setf (interval-preg rival) other-preg)
     1520                                         (do* ((qidx (1+ (interval-idx rival)) (1+ qidx)))
     1521                                              ((= qidx idx)
     1522                                               (setf (svref avail regtype)
     1523                                                     (logior (svref avail regtype)
     1524                                                             (ash 1 targeted))))
     1525                                           (let* ((q (aref intervals qidx)))
     1526                                             (when (eql (interval-regtype q) regtype)
     1527                                               (setf (interval-avail q)
     1528                                                     (logandc2 (interval-avail q)
     1529                                                               (ash 1 other-preg)))))))))
     1530                                 (setq preg targeted))))))
     1531
     1532
     1533                    (use-reg preg regtype i)
     1534                    (setf (interval-preg i) preg)
     1535                    (append-dll-node i active)))))))))))
    14361536
    14371537
    14381538
    14391539(defun linear-scan-bailout (&optional (reason "generic failure"))
    1440   (format *error-output* "~%~%bailing-out of linear-scan:~s~&~&" reason)
    1441   (signal 'liear-scan-bailout))
     1540  (format *error-output* "~%~%bailing-out of linear-scan:~&~&~a" reason)
     1541  (signal 'linear-scan-bailout))
    14421542
    14431543(defun optimize-vinsns (header)
Note: See TracChangeset for help on using the changeset viewer.