Changeset 16487


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

Change handling of split intervals significantly.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/lscan/source/compiler/vinsn.lisp

    r16483 r16487  
    646646  spills                                ; alist of intervals spilled here
    647647  reloads                               ; same as above
     648  extended-pred
     649  extended-succ
    648650)
     651
     652(defmethod print-object (( node fgn) stream)
     653  (print-unreadable-object (node stream :type t :identity t)
     654    (format stream "(~s)" (fgn-id node))))
     655
     656
     657
     658(defconstant interval-pre-spilled-bit 1)
     659(defconstant interval-flag-pre-spilled (ash 1 interval-pre-spilled-bit))
     660
    649661
    650662
     
    655667;;; jumps when linearizing the program.
    656668(defstruct (jumpnode (:include fgn)
    657                      (:constructor %make-jumpnode (id)))
     669                               (:constructor %make-jumpnode (id)))
    658670  (outedge)                             ; the FGN we jump/fall in to.
     671                              ; true if outedge is next in emit order
    659672)
    660673
     
    667680(defstruct (condnode (:include jumpnode)
    668681                     (:constructor %make-condnode (id)))
    669   (condbranch)                          ; the :branch vinsn
    670   (branchedge)                          ; the FGN it targets
     682                                        ; the FGN it targets
     683  condbranch
     684  branchedge
    671685)
    672686
     
    678692(defstruct (callnode (:include jumpnode)
    679693                     (:constructor %make-callnode (id mycall)))
    680   (mycall))
     694  mycall
     695
     696)
    681697                             
    682698(defun make-callnode (id mycall)
     
    692708  (init-dll-header (%make-returnnode id)))
    693709
     710
     711(defun find-extended-block-bounds (fgn)
     712  (let* ((first (do* ((first fgn pred)
     713                      (pred (fgn-extended-pred first) (fgn-extended-pred first)))
     714                     ((null pred) first)))
     715         (last  (do* ((last fgn succ)
     716                      (succ (fgn-extended-succ last) (fgn-extended-succ last)))
     717                     ((null succ) last))))
     718    (unless (and (eq first fgn) (eq last fgn)) (break))
     719    (values (vinsn-sequence (dll-node-succ (dll-header-first first)))
     720              (vinsn-sequence (dll-header-last last)))))
     721         
    694722;;; Some specified attribute is true.
    695723(defun %vinsn-attribute-p (vinsn mask)
     
    862890             
    863891              (push node nodes))))
     892     
    864893      (dolist (node nodes)
    865894        (if (typep node 'jumpnode)
     
    868897            (setf (jumpnode-outedge node) jmptarget)
    869898            (pushnew node (fgn-inedges jmptarget))
     899            (pushnew jmptarget (fgn-outedges node))
    870900            (if (typep node 'condnode)  ; a subtype of jumpnode
    871901              (let* ((branch (dll-node-pred jump))
    872902                     (branchtarget (branch-target-node branch)))
    873                 (setf (condnode-condbranch node) branch)
     903                (setf (condnode-condbranch node) branch
     904                      (condnode-branchedge node) branchtarget)
     905               
     906                (pushnew branchtarget (fgn-outedges node))
    874907                (pushnew node (fgn-inedges branchtarget)))))))
     908      ;; Merge adjacent nodes where the first "falls into" the second
     909      (do* ((nodes1 nodes (cdr nodes1))
     910            (first (car nodes1) (car nodes1))
     911            (second (cadr nodes1) (cadr nodes1)))
     912           ((or (null first) (null second)) (setq nodes (delete nil nodes)))
     913        (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)))
     916          (setf (fgn-extended-pred second) first
     917                (fgn-extended-succ first) second)))
     918
     919     
    875920      (setf (vinsn-list-flow-graph vinsns) nodes))))
    876921
     
    9781023  child
    9791024  (flags 0 :type fixnum)
     1025  (use-positions () :type list) ; sequence numbers of lreg-refs and defs
    9801026 
    9811027)
     
    10601106    (dovector (lreg (vinsn-list-lregs seg))
    10611107             
    1062       (let* ((max -1)
    1063              (min (vinsn-list-max-seq seg))
    1064              (all (append (lreg-defs lreg) (lreg-refs lreg))))
     1108      (let* ((all (append (lreg-defs lreg) (lreg-refs lreg))))
    10651109       
    10661110        (when all
    1067           (dolist (p all)
    1068             (let* ((seq (vinsn-sequence p)))
    1069               (if (< seq min)
    1070                 (setq min seq))
    1071               (if (> seq max)
    1072                (setq max seq))))
    1073           (let* ((class (lreg-class lreg))
     1111         
     1112          (let* ((use-positions (sort (mapcar #'vinsn-sequence all) #'<))
     1113                 (min (car use-positions))
     1114                 (max (car (last use-positions)))
     1115                 (class (lreg-class lreg))
    10741116                 (regtype (cond ((eql class hard-reg-class-fpr)
    10751117                                 interval-regtype-float)
     
    10811123                                   interval-regtype-imm)))))
    10821124           
    1083             (let* ((interval (make-interval lreg min max regtype nil)))
     1125            (let* ((interval (make-interval lreg min max regtype nil))
     1126                   )
     1127             
    10841128              (setf (lreg-interval lreg) interval)
     1129              (setf (interval-use-positions interval)
     1130                    use-positions)
    10851131              (when (logbitp lreg-pre-spill-bit (lreg-flags lreg))
    10861132                (process-pre-spilled-interval seg interval lreg (lreg-spill-offset lreg)))
     
    11901236    (when (> next-offset (vinsn-list-spill-base seg))
    11911237      (setf (vinsn-list-spill-base seg) next-offset))
     1238    (setf (interval-flags interval) interval-flag-pre-spilled)
    11921239   
    11931240
     
    12321279        (if child (interval-containing-vinsn child vinsn))))))
    12331280
     1281         
     1282         
     1283;;; Return the first use of INTERVAL within BLOCK and the spanning interval
     1284(defun first-use-of-interval-in-block (seg interval block)
     1285  (multiple-value-bind (start end) (find-extended-block-bounds block)
     1286    (declare (fixnum start end))
     1287    (do* ((i interval (interval-child i)))
     1288         ((null i) (values nil nil))
     1289      (dolist (use (interval-use-positions i))
     1290        (declare (fixnum use))
     1291        (if (and (>= use start)
     1292                 (< use end))
     1293          (return-from first-use-of-interval-in-block (values i (find-vinsn seg use))))))))
     1294
     1295;; Harder
     1296(defun last-use-of-interval-in-block (seg interval block)
     1297  (multiple-value-bind (start end) (find-extended-block-bounds block)
     1298    (declare (fixnum start end))
     1299    (let* ((child nil)
     1300           (last-use))
     1301      (do* ((i interval (interval-child i)))
     1302           ((null i) (values child (if last-use (find-vinsn seg last-use))))
     1303        (dolist (use (interval-use-positions i))
     1304          (declare (fixnum use))
     1305          (if (and (>= use start)
     1306                   (< use end))
     1307            (setq child i last-use use)))))))
     1308 
     1309         
     1310   
     1311(defun end-of-fgn-containing (vinsn)
     1312  (let* ((fgn (vinsn-fgn vinsn)))
     1313    (vinsn-sequence (dll-header-last fgn))))
     1314
    12341315(defun spill-and-split-interval (seg why parent new-end vector list)
    12351316  (declare (ignorable why))
     
    12391320   
    12401321    (let* ((used (vinsn-list-spill-area-used seg))
    1241            (base (vinsn-list-spill-base seg))
    1242            (parent-is-child (not (null (interval-parent parent)))))
     1322           (base (vinsn-list-spill-base seg)))
    12431323      (declare (simple-bit-vector used)
    12441324               (fixnum base))
     
    12621342                                              (vinsn-list-max-nfp-spill-depth seg))
    12631343                                       (setf (vinsn-list-max-nfp-spill-depth seg)
    1264                                              (vinsn-list-nfp-spill-offset seg)))))))))
    1265           (dolist (def (lreg-defs lreg))
    1266             (note-spill parent  def))
    1267             (let* ((min (vinsn-list-max-seq seg))
    1268                    (max (interval-end parent)))
    1269                      
    1270              
    1271              
    1272               (dolist (ref (lreg-refs lreg))
    1273                 (let*  ((seq (vinsn-sequence ref)))
    1274                   (when (> seq new-end)
    1275                    
    1276                     (if (< seq min) (setq min seq))
    1277                     (unless parent-is-child
    1278                       (let* ()
    1279                         (ls-format t "~&reload before ~a"  ref)
    1280                         (note-reload parent ref)
    1281                         )()))))
    1282               (dolist (def (lreg-defs lreg))
    1283                 (let*  ((seq (vinsn-sequence def))
    1284                         )
    1285  
    1286                   (when (> seq new-end)
    1287                     (if (< seq min) (setq min seq))
    1288                     (unless (or parent-is-child )
    1289                       (let* ()
    1290                         (note-spill parent  def))))))
    1291               (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"))
     1344                                             (vinsn-list-nfp-spill-offset seg))))))))
     1345               (child-used (member-if (lambda (pos) (> pos new-end)) (interval-use-positions parent)))
     1346               (ncu (length child-used)))
     1347
     1348            (let* ((min (car child-used))
     1349                   (max (car (last child-used))))
    12921350              (let* ((child (make-interval  lreg min max (interval-regtype parent) nil  )))
    12931351                (setf (interval-parent child) parent
    12941352                      (interval-child parent) child
    1295                       (interval-spill-offset child) offset)
     1353                      (interval-spill-offset child) offset
     1354                      (interval-flags child) (interval-flags parent)
     1355                      (interval-use-positions child) child-used
     1356                      (interval-use-positions parent) (butlast (interval-use-positions parent) ncu))
    12961357                (do-dll-nodes (r list (error "no next interval"))
    12971358                  (when (> (interval-begin r) min)
     
    13031364
    13041365                ;; Ready to expire
    1305                 (setf (interval-end parent) (1-  new-end)))))))))
     1366                (setf (interval-end parent) (car (last (interval-use-positions parent)))))))))))
    13061367
    13071368(defun assign-interval-indices (vector)
     
    14341495                (begin (if i (interval-begin I) limit) (if i (interval-begin I) limit)))
    14351496               ((= begin limit) (progn (do-dll-nodes (a active ) (expire-interval seg a )) t   ))
    1436             (ls-format t  "~&i=~s" i)
     1497            ;;(ls-format t  "~&i=~s" i)
    14371498
    14381499
     
    15751636                     (reload-vinsn (select-vinsn (reload-vinsn-for-interval i) templates (list preg offset))))
    15761637                (insert-vinsn-before reload-vinsn ref)))))))))
     1638
     1639(defun resolve-split-intervals (seg)
     1640  (let* ((templates (backend-p2-vinsn-templates *target-backend*))
     1641         (lregs (vinsn-list-lregs seg))
     1642         (nregs (length lregs)))
     1643             
     1644    (dovector (lreg lregs )
     1645      (let* ((interval (lreg-interval lreg))
     1646             (offset (if interval (interval-spill-offset interval))))
     1647        (when offset
     1648          (do* ((child (interval-child interval) (interval-child child)))
     1649               ((null child))
     1650            (let* ((parent (interval-parent child))
     1651                   (child-preg (interval-preg child))
     1652                   (parent-preg (interval-preg parent))
     1653                   (parent-end-vinsn (find-vinsn seg (interval-end parent)))
     1654                   (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
     1659    (dolist (from (vinsn-list-flow-graph seg))
     1660      (dolist (to (fgn-outedges from))
     1661        (let* ((live-in (fgn-live-in to)))
     1662          (declare (simple-bit-vector live-in))
     1663          (dotimes (i nregs)
     1664            (when (= (sbit live-in i) 1)
     1665              (let* ((interval (lreg-interval (aref lregs i)))
     1666                     (offset (interval-spill-offset interval)))
     1667                     
     1668                (when offset
     1669
     1670                  (multiple-value-bind (to-interval to-vinsn)
     1671                      (first-use-of-interval-in-block seg interval to)
     1672                    (multiple-value-bind (from-interval from-vinsn)
     1673                        (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)))))))))))))))
     1685                             
     1686                         
     1687                           
     1688                       
     1689           
     1690                   
     1691                 
     1692           
    15771693
    15781694                           
     
    16111727           (normalize-vinsns header)
    16121728           (let* ((fg (create-flow-graph header))
    1613                   (seq -100))
     1729                  (seq 0))
    16141730             (declare (fixnum seq))
    16151731             (dolist (node fg (setf (vinsn-list-max-seq header) seq))
     
    16171733                 (when (typep v 'vinsn)
    16181734                   (setf (vinsn-fgn v) node
    1619                          (vinsn-sequence v) (incf seq 100)))))
     1735                         (vinsn-sequence v) (incf seq 5)))))
    16201736             (compute-live-sets fg header)
    16211737             (setf (vinsn-list-available-physical-registers header)
     
    16321748             (unless (linear-scan header )
    16331749               (linear-scan-bailout "register allocation failed"))
    1634              (process-spills-and-reloads fg)
     1750             (resolve-split-intervals header)
     1751             ;;(process-spills-and-reloads fg)
    16351752             (when *linear-scan-verbose*
    16361753               (dolist (n fg )
     
    16641781
    16651782
    1666 (defun show-fgn (node regs)
     1783(defun show-fgn (node regs &optional (show-live-sets t))
    16671784  (declare (ignorable regs))
    1668  (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node)))
    1669  (show-vinsns node 2)
    1670 ; (show-live-set "live-kill" (fgn-live-kill node) regs)
    1671 ; (show-live-set "live-gen " (fgn-live-gen node) regs)
    1672 ; (show-live-set "live-in " (fgn-live-in node) regs)
    1673 ; (show-live-set "live-out " (fgn-live-out node) regs)
    1674  (terpri)
    1675  (terpri))
     1785  (format t "~&~s (~d) {~a}" (type-of node) (fgn-id node) (mapcar #'fgn-id (fgn-inedges node)))
     1786  (show-vinsns node 2)
     1787  (when show-live-sets
     1788    (show-live-set "live-kill" (fgn-live-kill node) regs)
     1789    (show-live-set "live-gen " (fgn-live-gen node) regs)
     1790    (show-live-set "live-in " (fgn-live-in node) regs)
     1791    (show-live-set "live-out " (fgn-live-out node) regs))
     1792 
     1793  (terpri)
     1794  (terpri))
    16761795
    16771796(defun show-live-set (herald bits regs)
Note: See TracChangeset for help on using the changeset viewer.