Changeset 16488


Ignore:
Timestamp:
Jul 24, 2015, 5:46:14 PM (4 years ago)
Author:
gb
Message:

Work-in-progress.

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

Legend:

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

    r16480 r16488  
    1 ;;-*-Mode: LISP; Package: CCL -*-
     1;;;-*-Mode: LISP; Package: CCL -*-
    22;;;
    33;;;   Copyright (C) 2005-2009 Clozure Associates
     
    13301330            (! default-3-args min))))
    13311331      (setq *x862-incoming-args-on-stack* (- max *x862-target-num-arg-regs*))
     1332      (let*  ((nspilled *x862-incoming-args-on-stack*))
     1333        (declare (fixnum nspilled))
     1334        (setq *x862-vstack* (ash nspilled 3)))
    13321335     
     1336
    13331337      (! reserve-spill-area)
    13341338      (! save-nfp)
     
    13451349                 (setf (lreg-spill-offset reg) offset
    13461350                       (lreg-flags reg)
    1347                        (logior lreg-flag-spill lreg-flag-pre-spill)))
     1351                       (logior lreg-flag-spill lreg-flag-pre-spill))
     1352                 )
     1353
     1354                         
    13481355                ((= nargs 3)
    13491356                 (! copy-gpr reg ($ x8664::arg_x)))
     
    40354042;;; would vpop the first argument out of line.)
    40364043(defun x862-two-targeted-reg-forms (seg aform areg bform breg)
     4044  (cond (*backend-use-linear-scan*
     4045         (multiple-value-bind (atemp btemp) (x862-two-untargeted-reg-forms seg aform areg  bform breg)
     4046           (x862-copy-register seg breg breg)
     4047           (x862-copy-register seg breg btemp)
     4048           (x862-copy-register seg areg atemp)
     4049           (values areg breg)))
     4050        (t
    40374051  (let* ((avar (nx2-lexical-reference-p aform))
    40384052         (atriv (and (x862-trivial-p bform areg) (nx2-node-gpr-p breg)))
     
    40504064        (if apushed
    40514065          (x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
    4052     (values areg breg)))
     4066    (values areg breg)))))
    40534067
    40544068 
     
    57745788                          (addr (x862-vloc-ea vloc)))
    57755789  (with-x86-local-vinsn-macros (seg)
    5776     (push var *x862-stack-vars*)
     5790    (let* ((lreg (var-lreg var)))
     5791      (when (or (not lreg) (not (eql 0 (lreg-flags lreg))))
     5792        (push var *x862-stack-vars*)))
    57775793    (when *backend-use-linear-scan*
    57785794      (let*  ((reg (or (var-lreg var) (let* ((r (?))) (setf (var-lreg var) r)))))
  • branches/lscan/source/compiler/vinsn.lisp

    r16487 r16488  
    648648  extended-pred
    649649  extended-succ
     650  call-vinsns
    650651)
    651652
     
    716717                      (succ (fgn-extended-succ last) (fgn-extended-succ last)))
    717718                     ((null succ) last))))
    718     (unless (and (eq first fgn) (eq last fgn)) (break))
    719719    (values (vinsn-sequence (dll-node-succ (dll-header-first first)))
    720720              (vinsn-sequence (dll-header-last last)))))
     
    875875    (flet ((label->fgn (label) (dll-node-pred label)))
    876876      (loop
    877           (multiple-value-bind (label last) (remove-last-basic-block vinsns)
    878             (when (null label) (return))
    879             (let* ((id (vinsn-label-id label))
    880                    (node (if (vinsn-attribute-p last :jumpLR)
    881                            (make-returnnode id)
    882                            (let* ((pred (dll-node-pred last)))
    883                              (if (vinsn-attribute-p pred :branch)
    884                                (make-condnode id)
    885                                (if (vinsn-attribute-p pred :call)
    886                                  (make-callnode id pred)
    887                                  (make-jumpnode id)))))))
    888               (declare (fixnum id))
    889               (insert-dll-node-after label node last)
    890              
    891               (push node nodes))))
     877        (multiple-value-bind (label last) (remove-last-basic-block vinsns)
     878          (when (null label) (return))
     879          (let* ((id (vinsn-label-id label))
     880                 (node (if (vinsn-attribute-p last :jumpLR)
     881                         (make-returnnode id)
     882                         (let* ((pred (dll-node-pred last)))
     883                           (if (vinsn-attribute-p pred :branch)
     884                             (make-condnode id)
     885                             (if (vinsn-attribute-p pred :call)
     886                               (make-callnode id pred)
     887                               (make-jumpnode id)))))))
     888            (declare (fixnum id))
     889            (insert-dll-node-after label node last)
     890            (do-dll-nodes (v node) (if (vinsn-attribute-p v :call)
     891                                     (push v (fgn-call-vinsns node))))
     892            (push node nodes))))
    892893     
    893894      (dolist (node nodes)
     
    912913           ((or (null first) (null second)) (setq nodes (delete nil nodes)))
    913914        (when (and (null (cdr (fgn-inedges second))) (eq first (car (fgn-inedges second)))
    914                    (null (cdr (fgn-outedges first))) (eq second (car (fgn-outedges first)))
    915                    (not (typep first 'callnode)))
     915                   (null (cdr (fgn-outedges first))) (eq second (car (fgn-outedges first))))
    916916          (setf (fgn-extended-pred second) first
    917                 (fgn-extended-succ first) second)))
     917                (fgn-extended-succ first) second)
     918                   
     919
     920
     921          (unless (typep first 'callnode)
     922          (dolist (ref (fgn-inedges first))
     923            (nsubstitute second first (fgn-outedges ref))
     924            (when (typep ref 'jumpnode)
     925              (when (eq first (jumpnode-outedge ref))
     926                (setf (jumpnode-outedge ref) second))
     927              (when (typep ref 'condnode)
     928                (when (eq first (condnode-branchedge ref))
     929                  (setf (condnode-branchedge ref) second)))))
     930
     931          (if (setf (fgn-extended-pred second) (fgn-extended-pred first))
     932            (setf (fgn-extended-succ (fgn-extended-pred first)) second))
     933          (setf (fgn-inedges second) (fgn-inedges first))
     934          (multiple-value-bind (label1 jump) (detach-dll-nodes first)
     935            (let* ((label2 (dll-header-succ second)))
     936              (insert-dll-node-before label1 label2 jump)
     937              (when (null (delete jump (vinsn-label-refs label2)))
     938                (remove-dll-node label2))
     939              (remove-dll-node jump)
     940              (setf (fgn-id second) (fgn-id first))))
     941         
     942          (setf (car nodes1) nil))))
     943
     944       
    918945
    919946     
     
    10821109         (fg (vinsn-list-flow-graph seg)))
    10831110         
    1084    
     1111
    10851112    (dolist (block fg)
    1086       (when (typep block 'callnode)
    1087         (let* ((end-vinsn (dll-header-last block))
    1088                (start-vinsn (vinsn-pred end-vinsn))
     1113      (dolist (v (fgn-call-vinsns block))
     1114        (let* ((end-vinsn v)
     1115               (start-vinsn v)
    10891116               (low (vinsn-sequence start-vinsn))
    10901117               (high (vinsn-sequence end-vinsn))
    10911118               (killed (make-array 4)))
    10921119          (declare (simple-vector killed) )
    1093           (unless (eq start-vinsn (callnode-mycall block))
    1094             (break "bad callnode ~s" block))
     1120
    10951121          (when (vinsn-attribute-p start-vinsn :extended-call)
    10961122            (setq high (vinsn-sequence (find-end-of-extended-call seg start-vinsn))))
     
    11301156                    use-positions)
    11311157              (when (logbitp lreg-pre-spill-bit (lreg-flags lreg))
     1158                (when (interval-parent interval) (break))
    11321159                (process-pre-spilled-interval seg interval lreg (lreg-spill-offset lreg)))
    11331160              (vector-push-extend
     
    12321259(defun process-pre-spilled-interval (seg interval lreg offset)
    12331260  (setf (interval-lreg interval) lreg
     1261       
     1262                                               
    12341263        (interval-spill-offset interval) offset)
     1264  (let* ((used (vinsn-list-spill-area-used seg))
     1265        (id (lreg-id lreg)))
     1266    (setf (sbit used id) 1))
    12351267  (let* ((next-offset (1+ offset)))
    12361268    (when (> next-offset (vinsn-list-spill-base seg))
     
    12381270    (setf (interval-flags interval) interval-flag-pre-spilled)
    12391271   
    1240 
    12411272    (dolist (ref (lreg-refs lreg))
    12421273      (note-reload interval ref)
    12431274      )
    12441275    (dolist (def (lreg-defs lreg))
    1245       (unless (eql (vinsn-sequence def) (interval-begin interval))
    1246         (note-spill interval def)))))
     1276      (note-spill interval def)
     1277      )))
    12471278                 
    12481279
     
    13261357        (declare (fixnum nregs))
    13271358        (let* ((offset (or (interval-spill-offset parent)
    1328                            (setf (interval-spill-offset parent)
     1359                           (setf (interval-spill-offset parent) 
    13291360                                 (if (eql (interval-regtype parent) interval-regtype-node)
    13301361                                   (dotimes (i nregs)
    13311362                                     (when (eql 0 (sbit used i))
    13321363                                       (setf (sbit used i) 1)
     1364                                       (break "before")
    13331365                                       (incf (vinsn-list-spill-depth seg))
    13341366                                       (when (> (vinsn-list-spill-depth seg)
     
    13361368                                         (setf  (vinsn-list-max-spill-depth seg)
    13371369                                                (vinsn-list-spill-depth seg)))
     1370                                       (break)
    13381371                                       (return (+ i base))))
    13391372                                   (prog1 (vinsn-list-nfp-spill-offset seg)
     
    16251658          (destructuring-bind (i . defs) s
    16261659            (dolist (def defs)
    1627               (let* ((preg (interval-preg (or (interval-containing-vinsn i def) (error "no interval contains ~s" def))))
     1660              (let* ((preg (interval-preg i))
    16281661                     (offset (interval-spill-offset i))
    16291662                     (spill-vinsn (select-vinsn (spill-vinsn-for-interval i) templates (list preg offset))))
     
    16321665          (destructuring-bind (i . refs) r
    16331666            (dolist (ref refs)
    1634               (let* ((preg (interval-preg (or (interval-containing-vinsn i ref) (error "no interval contains ~s" ref))))
     1667              (let* ((preg (interval-preg i))
    16351668                     (offset (interval-spill-offset i))
    16361669                     (reload-vinsn (select-vinsn (reload-vinsn-for-interval i) templates (list preg offset))))
    16371670                (insert-vinsn-before reload-vinsn ref)))))))))
    16381671
     1672
    16391673(defun resolve-split-intervals (seg)
    1640   (let* ((templates (backend-p2-vinsn-templates *target-backend*))
     1674  (let* (
    16411675         (lregs (vinsn-list-lregs seg))
    16421676         (nregs (length lregs)))
     
    16491683               ((null child))
    16501684            (let* ((parent (interval-parent child))
    1651                    (child-preg (interval-preg child))
    1652                    (parent-preg (interval-preg parent))
     1685
    16531686                   (parent-end-vinsn (find-vinsn seg (interval-end parent)))
    16541687                   (child-start-vinsn (find-vinsn seg (interval-begin child))))
    1655               (insert-vinsn-before (select-vinsn (reload-vinsn-for-interval child) templates (list child-preg offset)) child-start-vinsn)
    1656                
    1657               (insert-vinsn-after (select-vinsn (spill-vinsn-for-interval parent) templates (list parent-preg offset))  parent-end-vinsn))))))
    1658     #+no
     1688              (note-reload child child-start-vinsn)
     1689              (note-spill parent parent-end-vinsn))))))
     1690
     1691   
    16591692    (dolist (from (vinsn-list-flow-graph seg))
    16601693      (dolist (to (fgn-outedges from))
     1694        (unless (eq to (fgn-extended-succ from))
     1695
    16611696        (let* ((live-in (fgn-live-in to)))
    16621697          (declare (simple-bit-vector live-in))
     
    16721707                    (multiple-value-bind (from-interval from-vinsn)
    16731708                        (last-use-of-interval-in-block seg interval from)
    1674                       (when (null from-interval)
    1675                         (let* ((*linear-scan-verbose* t))
    1676                         (show-fgn from lregs nil))
    1677                         (break))
    1678                    
    1679                       (unless (eq from-interval to-interval)
    1680                         (let* ((spill-vinsn (if from-interval (select-vinsn (spill-vinsn-for-interval interval) templates (list (interval-preg from-interval) offset))))
    1681                                (reload-vinsn (if to-interval (select-vinsn (reload-vinsn-for-interval interval) templates (list (interval-preg to-interval) offset)))))
    1682                           (when spill-vinsn (insert-vinsn-after spill-vinsn from-vinsn))
    1683                           ;; unless defined before used in "to".  Check for that
    1684                           (when reload-vinsn(insert-vinsn-before reload-vinsn to-vinsn)))))))))))))))
     1709
     1710                      (or from-interval (break "no interval for ~s" from))
     1711                      (or to-interval (break "no interval for ~s" to))
     1712                      (note-spill from-interval from-vinsn)
     1713                      (note-reload to-interval to-vinsn)))))))))))))
    16851714                             
    16861715                         
     
    17491778               (linear-scan-bailout "register allocation failed"))
    17501779             (resolve-split-intervals header)
    1751              ;;(process-spills-and-reloads fg)
     1780             (process-spills-and-reloads fg)
    17521781             (when *linear-scan-verbose*
    17531782               (dolist (n fg )
     
    17621791  (flet ((find-vinsn-in-node (node seq)
    17631792           (do-tail-dll-nodes (v node)
    1764              (let*  ((vseq (vinsn-sequence v)))
    1765                (if (eq vseq seq)
    1766                  (return v))))))
     1793             (when (typep v 'vinsn)
     1794               (let*  ((vseq (vinsn-sequence v)))
     1795                 (if (eq vseq seq)
     1796                   (return v)))))))
    17671797    (dolist (node (vinsn-list-flow-graph seg))
    17681798      (let* ((lastv (dll-header-last node)))
Note: See TracChangeset for help on using the changeset viewer.