Index: /branches/lscan/source/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /branches/lscan/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 16309) +++ /branches/lscan/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 16310) @@ -1077,5 +1077,10 @@ ((arg t))) ) - + +(define-x8664-vinsn incoming-register-arg (((dest :lisp)) + ((i :u32const) + (b :u32const))) + + ) (define-x8664-vinsn unbox-u8 (((dest :u8)) Index: /branches/lscan/source/compiler/X86/x862.lisp =================================================================== --- /branches/lscan/source/compiler/X86/x862.lisp (revision 16309) +++ /branches/lscan/source/compiler/X86/x862.lisp (revision 16310) @@ -1316,13 +1316,16 @@ ;;; Vpush register r, unless var gets a globally-assigned register. ;;; Return NIL if register was vpushed, else var. -(defun x862-vpush-arg-register (seg reg var) - (when var - (if (var-nvr var) - var - (progn - (if *backend-use-linear-scan* - (setf (var-lreg var) reg) - (x862-vpush-register seg reg)) - nil)))) +(defun x862-vpush-arg-register (seg reg var &optional (i 0) (n 0)) + (with-x86-local-vinsn-macros (seg) + (when var + (if (var-nvr var) + var + (progn + (if *backend-use-linear-scan* + (progn + (setf (var-lreg var) reg) + (! incoming-register-arg reg i n)) + (x862-vpush-register seg reg)) + nil))))) @@ -1357,12 +1360,14 @@ (:x8664 (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs - (let* ((nstackargs (length stack-args))) + (let* ((nstackargs (length stack-args)) + (i -1)) + (declare (fixnum i)) (x862-set-vstack (* nstackargs *x862-target-node-size*)) (if (>= nargs 3) - (push (x862-vpush-arg-register seg ($ x8664::arg_x) xvar) reg-vars)) + (push (x862-vpush-arg-register seg ($ x8664::arg_x) xvar (incf i)3 ) reg-vars)) (if (>= nargs 2) - (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar) reg-vars)) + (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar (incf i) (if (= nargs 2) 2 3)) reg-vars)) (if (>= nargs 1) - (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar) reg-vars)))))) + (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar (incf i) (min nargs 3)) reg-vars)))))) reg-vars))) @@ -1616,17 +1621,19 @@ (regno (%hard-regspec-value reg)) (other (x862-register-for-frame-offset offset regno))) - (unless (eql regno other) + (unless (and regno (eql regno other)) (cond (other (let* ((vinsn (! copy-gpr reg other))) - (setq *x862-gpr-locations-valid-mask* - (logior mask (ash 1 regno))) - (setf (svref info regno) - (copy-list (svref info other))) + (unless *backend-use-linear-scan* + (setq *x862-gpr-locations-valid-mask* + (logior mask (ash 1 regno))) + (setf (svref info regno) + (copy-list (svref info other)))) vinsn)) (t (let* ((vinsn (! vframe-load reg offset *x862-vstack*))) - (setq *x862-gpr-locations-valid-mask* - (logior mask (ash 1 regno))) - (setf (svref info regno) (list offset)) + (unless *backend-use-linear-scan* + (setq *x862-gpr-locations-valid-mask* + (logior mask (ash 1 regno))) + (setf (svref info regno) (list offset))) vinsn))))))) @@ -3233,5 +3240,5 @@ (setq *x862-cstack* cstack) (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p)) - (<- *x862-arg-z*) + (<- ($ *x862-arg-z*)) (x862-branch seg (logand (lognot $backend-mvpass-mask) xfer))))) nil))) @@ -5964,5 +5971,5 @@ (1 (! mem-set-c-byte *x862-imm0* ptr-reg offval)))))) (if for-value - (<- *x862-arg-z*))) + (<- ($ *x862-arg-z*)))) (t (with-imm-target () (ptr-reg :address) @@ -5970,5 +5977,5 @@ (with-imm-target (ptr-reg) (offset-reg :address) (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ *x862-arg-z*)) - (! fixnum->signed-natural offset-reg *x862-arg-z*) + (! fixnum->signed-natural offset-reg ($ *x862-arg-z*)) (! fixnum-add2 ptr-reg offset-reg) (x862-push-register seg ptr-reg)))) @@ -8115,22 +8122,22 @@ (if lreg (progn - (if (eq vreg :push) - (x862-vpush-register seg lreg) + (if (eq vreg :push) + (x862-vpush-register seg lreg) (progn (x862-copy-register seg vreg lreg))) (^)) - (let* ((ea-or-form (var-ea varnode))) - (if (and (acode-punted-var-p varnode) (not (fixnump ea-or-form))) - (if (or (not (eq vreg :push)) - (x862-acode-operator-supports-push ea-or-form)) - (x862-form seg vreg xfer ea-or-form) - (ensuring-node-target (target vreg) - (x862-form seg target xfer ea-or-form) - (! vpush-register target))) - (progn - (unless (or (typep ea-or-form 'lreg) (fixnump ea-or-form)) - (compiler-bug "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) - (x862-do-lexical-reference seg vreg ea-or-form) - (^))))))) + (let* ((ea-or-form (var-ea varnode))) + (if (and (acode-punted-var-p varnode) (not (fixnump ea-or-form))) + (if (or (not (eq vreg :push)) + (x862-acode-operator-supports-push ea-or-form)) + (x862-form seg vreg xfer ea-or-form) + (ensuring-node-target (target vreg) + (x862-form seg target xfer ea-or-form) + (! vpush-register target))) + (progn + (unless (or (typep ea-or-form 'lreg) (fixnump ea-or-form)) + (compiler-bug "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) + (x862-do-lexical-reference seg vreg ea-or-form) + (^))))))) ;;; try to use a CISCy instruction for (SETQ stack-var (op stack-var other)). @@ -8162,19 +8169,22 @@ (defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form) - (let* ((ea (var-ea varspec))) - ;;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) + (let* ((lreg (var-lreg varspec))) + (if lreg + (x862-one-lreg-form seg form lreg) + (let* ((ea (var-ea varspec))) + ;;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) - (if (and (memory-spec-p ea) - (eql (memspec-type ea) memspec-nfp-offset)) - (let* ((reg (x862-one-untargeted-reg-form seg form (x862-reg-for-nfp-set vreg ea)))) - (x862-nfp-set seg reg ea) - (when vreg (x862-copy-register seg vreg reg))) - (or (and ea (x862-two-address-op seg vreg xfer ea form)) - (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) - (or (null vreg) (eq ea vreg))) - ea - *x862-arg-z*)))) - (x862-do-lexical-setq seg vreg ea valreg)))) - (^))) + (if (and (memory-spec-p ea) + (eql (memspec-type ea) memspec-nfp-offset)) + (let* ((reg (x862-one-untargeted-reg-form seg form (x862-reg-for-nfp-set vreg ea)))) + (x862-nfp-set seg reg ea) + (when vreg (x862-copy-register seg vreg reg))) + (or (and ea (x862-two-address-op seg vreg xfer ea form)) + (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) + (or (null vreg) (eq ea vreg))) + ea + *x862-arg-z*)))) + (x862-do-lexical-setq seg vreg ea valreg)))) + (^))))) @@ -8608,5 +8618,5 @@ (x862-set-nargs seg nargs) (! list) - (<- *x862-arg-z*))) + (<- ($ *x862-arg-z*)))) (^)) @@ -8621,5 +8631,5 @@ (x862-set-nargs seg (1- nargs)) (! list*)) - (<- *x862-arg-z*))) + (<- ($ *x862-arg-z*)))) (^)) Index: /branches/lscan/source/compiler/vinsn.lisp =================================================================== --- /branches/lscan/source/compiler/vinsn.lisp (revision 16309) +++ /branches/lscan/source/compiler/vinsn.lisp (revision 16310) @@ -610,5 +610,10 @@ (id 0 :type unsigned-byte) (inedges ()) ; list of nodes which reference this node + (outedges ()) (visited nil) ; Boolean + live-gen + live-kill + live-out + live-in ) @@ -738,5 +743,7 @@ ;;; Create a flow graph from vinsns and return the entry node. (defun create-flow-graph (vinsns) - (let* ((nodes ())) + (let* ((nodes ()) + (nregs (length (vinsn-list-lregs vinsns)))) + (declare (fixnum nregs)) (flet ((label->fgn (label) (dll-node-pred label))) (loop @@ -754,6 +761,37 @@ (declare (fixnum id)) (insert-dll-node-after label node last) + (let* ((kill (make-array nregs :element-type 'bit)) + (gen (make-array nregs :element-type 'bit))) + (do* ((v (vinsn-label-succ label) (vinsn-succ v))) + ((eq v node) + (setf (fgn-live-gen node) gen + (fgn-live-kill node) kill + (fgn-live-out node) (make-array nregs :element-type 'bit) + (fgn-live-in node) (make-array nregs :element-type 'bit))) + (let* ((template (vinsn-template v)) + (nres (length (vinsn-template-result-vreg-specs template))) + (narg (length (vinsn-template-argument-vreg-specs template))) + (nvp (vinsn-template-nvp template)) + (vp (vinsn-variable-parts v))) + (declare (fixnum nres narg nvp)) + (do* ((i nres (1+ i)) + (j 0 (1+ j))) + ((= j narg)) + (let* ((val (svref vp j))) + (when (typep val 'lreg) + (let* ((id (lreg-id val))) + (when (eql 0 (sbit kill id)) + (setf (sbit gen id) 1)))))) + (dotimes (i nres) + (let* ((val (svref vp i))) + (when (typep val 'lreg) + (setf (sbit kill (lreg-id val)) 1)))) + (do* ((i (the fixnum (+ nres narg)) (1+ i))) + ((= i nvp)) + (let* ((val (svref vp i))) + (when (typep val 'lreg) + (setf (sbit kill (lreg-id val)) 1))))))) (push node nodes)))) - (dolist (node nodes nodes) + (dolist (node nodes) (if (typep node 'jumpnode) (let* ((jump (dll-header-last node)) @@ -765,5 +803,27 @@ (branchtarget (branch-target-node branch))) (setf (condnode-condbranch node) branch) - (pushnew node (fgn-inedges branchtarget)))))))))) + (pushnew node (fgn-inedges branchtarget))))))) + (let* ((rnodes (reverse nodes)) + (changed nil)) + (loop + (setq changed nil) + (dolist (block rnodes) + (let* ((in (make-array nregs :element-type 'bit)) + (out (make-array nregs :element-type 'bit))) + (declare (dynamic-extent in out)) + (when (typep block 'condnode) + (bit-ior out (fgn-live-in (branch-target-node (condnode-condbranch block))) out)) + (when (typep block 'jumpnode) + (bit-ior out (fgn-live-in (jumpnode-outedge block)))) + (bit-andc2 in (fgn-live-kill block) in) + (bit-ior in (fgn-live-gen block) in) + (unless (equal out (fgn-live-out block)) + (setq changed t) + (bit-boole boole-1 out out (fgn-live-out block))) + (unless (equal in (fgn-live-in block)) + (setq changed t) + (bit-boole boole-1 in in (fgn-live-in block))))) + (when changed (return nodes))))))) + (defun linearize-flow-graph (fg header) @@ -776,5 +836,5 @@ (when (and (vinsn-attribute-p last :jump) (eq (car tail) (branch-target-node last))) - (let* ((lab (car tail))) + (let* ((lab (dll-node-succ (car tail)))) (when (null (setf (vinsn-label-refs lab) (delete last (vinsn-label-refs lab)))) @@ -855,5 +915,5 @@ (defstruct (interval (:include dll-node) - (:constructor make-interval (lreg begin end regtype preg))) + (:constructor make-interval (lreg begin end regtype preg first-block last-block))) lreg (begin 0) @@ -863,4 +923,6 @@ (avail 0) ; available regs before we assigned preg idx + first-block + last-block ) @@ -876,8 +938,7 @@ (dest (svref vp 0)) (src (svref vp 1))) - ;; We can safely eliminate the copy vinsn if both the - ;; source and destination are defined exactly once - (when (and (null (cdr (lreg-defs src))) - (null (cdr (lreg-defs dest)))) + ;; This is probably not the only case where we can't + ;; avoid removing a COPY instruction. + (unless (lreg-wired dest) (setf (lreg-defs dest) nil) (dolist (ref (lreg-refs dest) (setf (lreg-refs dest) nil)) @@ -893,4 +954,6 @@ (let* ((max -1) (min (vinsn-list-max-seq seg)) + (first nil) + (last nil) (all (append (lreg-defs lreg) (lreg-refs lreg)))) (when all @@ -898,7 +961,9 @@ (let* ((seq (vinsn-sequence p))) (if (< seq min) - (setq min seq)) + (setq min seq + first p)) (if (> seq max) - (setq max seq)))) + (setq max seq + last p)))) (let* ((class (lreg-class lreg)) (regtype (cond ((eql class hard-reg-class-fpr) @@ -911,18 +976,21 @@ interval-regtype-imm))))) - (vector-push-extend (make-interval lreg min max regtype (if (lreg-wired lreg) (lreg-value lreg)) ) list))))) - (break "list elements = ~s, max-seq = ~s" (length list) (vinsn-list-max-seq seg)) + (vector-push-extend + (make-interval lreg min max regtype (if (lreg-wired lreg) (lreg-value lreg)) (if first (vinsn-fgn first)) (if last (vinsn-fgn last))) + list))))) (setf (vinsn-list-intervals seg) - (sort (subseq list 0) #'< :key #'interval-begin)))) + + (sort (subseq list 0) (lambda (x y) + (let* ((beginx (interval-begin x)) + (beginy (interval-begin y))) + (or (< beginx beginy) + (and (= beginx beginy) + (lreg-local-p (interval-lreg x)))))))))) (defun linear-scan (seg avail) (flet ((use-reg (regno type) - (when (eql type interval-regtype-node) - (format t "~& using ~d/~d" regno type)) (setf (svref avail type) (logandc2 (svref avail type) (ash 1 regno)))) (unuse-reg (regno type) - (when (eql type interval-regtype-node) - (format t "~& unusing ~d/~d" regno type)) (setf (svref avail type) (logior (svref avail type) (ash 1 regno))))) @@ -939,7 +1007,8 @@ (when (lreg-local-p lreg) (let* ((preg (lreg-value lreg))) + (format t "~& wired reg ~s at ~s" lreg (interval-begin i)) (unless (logbitp preg mask) (print i) - (do-dll-nodes (j active (break)) + (do-dll-nodes (j active) (format t "~& ~s" j)) (let* ((other @@ -948,5 +1017,5 @@ (eql preg (interval-preg j))) (return j))))) - (unless other (return nil)) + (unless other (break "5") (return nil)) (break "other = ~s" other) (do* ((other-idx (interval-idx other) (1+ other-idx)) @@ -954,11 +1023,30 @@ (other-avail (interval-avail q) (logand other-avail (if (eql (interval-regtype q) regtype) (interval-avail q) -1)))) ((= other-idx idx) - (break "other-avail = #x~x" other-avail))))))) + (if (eql other-avail 0) + (return-from linear-scan nil) + (let* ((other-preg + (dotimes (i 16) + (when (logbitp i other-avail) + (return i))))) + (setf (interval-preg other) other-preg + (interval-avail other) + (logandc2 (ash 1 preg) + (interval-avail other))) + (do* ((qidx (1+ (interval-idx other)) (1+ qidx))) + ((= qidx idx) + (setf (interval-avail i) + (logior (interval-avail i) + (ash 1 preg)) + (svref avail regtype) + (interval-avail i))) + (let* ((q (svref intervals qidx))) + (when (eql (interval-regtype q) regtype) + (setf (interval-avail q) + (logandc2 (interval-avail q) + (ash 1 other-preg)))))))))))))) (do-dll-nodes (other active) (let* ((other-end (interval-end other))) - (when (or (< other-end begin) - (and (= other-end begin) - (not (= begin (interval-end i))))) + (when (<= other-end begin) (let* ((regtype (interval-regtype other))) (unuse-reg (interval-preg other) regtype)