Changeset 16490


Ignore:
Timestamp:
Aug 2, 2015, 4:22:23 PM (4 years ago)
Author:
gb
Message:

Working, for some value of that term. Bail out on lambda-list complexity.

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

Legend:

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

    r16488 r16490  
    187187
    188188(defvar *x862-popreg-labels* nil)
    189 (defvar *x862-popj-labels* nil)
    190189(defvar *x862-valret-labels* nil)
    191190(defvar *x862-nilret-labels* nil)
     
    716715           (bits 0)
    717716           (*logical-register-counter* -1)
    718            (*x862-popj-labels* nil)
     717
    719718           (*x862-popreg-labels* nil)
    720719           (*x862-valret-labels* nil)
     
    12541253                (let* ((spreg (var-lreg spvar))
    12551254                       (var-reg (var-lreg var)))
     1255               
    12561256                  (with-crf-target () crf
    12571257                     (x862-compare-register-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) spreg x86::x86-e-bits t)
     
    12601260                (t
    12611261                  (with-crf-target () crf
     1262
    12621263                                   (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc)  x86::x86-e-bits t))
    12631264                  (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc))
     
    13291330            (! default-2-args min)
    13301331            (! default-3-args min))))
    1331       (setq *x862-incoming-args-on-stack* (- max *x862-target-num-arg-regs*))
     1332      (setq *x862-incoming-args-on-stack* (max (- max *x862-target-num-arg-regs*) 0))
    13321333      (let*  ((nspilled *x862-incoming-args-on-stack*))
    13331334        (declare (fixnum nspilled))
     
    13631364          (if fixed (push var *x862-tail-arg-vars*))
    13641365          (setf (var-lreg var) reg)))
     1366
    13651367      )))
    13661368
     
    15411543           (label (if labelno (aref *backend-labels* labelno))))
    15421544      (! cbranch-false (or label (aref *backend-labels* no-overflow)) x86::x86-o-bits)
    1543       (if *x862-open-code-inline*
     1545      (if (or *x862-open-code-inline* *backend-use-linear-scan*)
    15441546        (! handle-fixnum-overflow-inline target)
    15451547        (let* ((target-other (not (eql (hard-regspec-value target)
     
    32613263                                  (backend-get-next-label))))
    32623264          (unless simple-case
     3265            (linear-scan-bailout "funcall of non-constant")
    32633266            (x862-vpush-register seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*))
    32643267            (setq fn (x862-vloc-ea vstack)))
     
    58505853  (with-x86-local-vinsn-macros (seg)
    58515854    (cond ((and *backend-use-linear-scan*)
    5852      
    5853            (let*  ((rval (x862-one-untargeted-reg-form seg value (?)))
     5855           (let*  ((rval (?))
    58545856                   (rsym (?)))
    5855              (x862-store-immediate seg (x862-symbol-value-cell sym) rsym)
    5856              (! bind-inline rsym rval)
    5857              (x862-open-undo $undospecial)))
    5858           (t
     5857           (if (typep value 'fixnum)
     5858             (x862-stack-to-register seg value rval)
     5859             (x862-one-untargeted-reg-form seg value rval))
     5860           (x862-store-immediate seg (x862-symbol-value-cell sym) rsym)
     5861           (! bind-inline rsym rval)
     5862           (x862-open-undo $undospecial)))
     5863    (t
    58595864
    58605865
    58615866   
    5862     (let* ((ea-p (x862-load-ea-p value))
    5863            (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value)))))
    5864            (self-p (unless ea-p (and (or
    5865                                       (eq (acode-operator value) (%nx1-operator bound-special-ref))
    5866                                       (eq (acode-operator value) (%nx1-operator special-ref)))
    5867                                      (eq (car (acode-operands value)) sym)))))
    5868       (cond ((eq sym '*interrupt-level*)
    5869              (let* ((fixval (acode-fixnum-form-p value)))
    5870                (cond ((eql fixval 0)
    5871                       (if *x862-open-code-inline*
    5872                         (! bind-interrupt-level-0-inline)
    5873                         (! bind-interrupt-level-0)))
    5874                      ((eql fixval -1)
    5875                       (if *x862-open-code-inline*
    5876                         (! bind-interrupt-level-m1-inline)
    5877                         (! bind-interrupt-level-m1)))
    5878                      (t
    5879                       (if ea-p
    5880                         (x862-store-ea seg value *x862-arg-z*)
    5881                         (x862-one-targeted-reg-form seg value ($ *x862-arg-z*)))
    5882                       (! bind-interrupt-level))))
    5883              (x862-open-undo $undointerruptlevel))
    5884             (t
    5885              (if (or nil-p self-p)
    5886                (progn
    5887                  (x862-store-immediate seg (x862-symbol-value-cell sym) *x862-arg-z*)
    5888                  (if nil-p
    5889                    (! bind-nil)
    5890                    (if (or *x862-reckless* (eq (acode-operator value) (%nx1-operator special-ref)))
    5891                      (! bind-self)
    5892                      (! bind-self-boundp-check))))
    5893                (progn
    5894                  (if ea-p
    5895                    (x862-store-ea seg value *x862-arg-z*)
    5896                    (x862-one-targeted-reg-form seg value ($ *x862-arg-z*)))
    5897                  (x862-store-immediate seg (x862-symbol-value-cell sym) ($ *x862-arg-y*))
    5898                  (! bind)))
    5899              (x862-open-undo $undospecial)))
    5900       (x862-adjust-vstack (* 3 *x862-target-node-size*)))))))
     5867     (let* ((ea-p (x862-load-ea-p value))
     5868            (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value)))))
     5869            (self-p (unless ea-p (and (or
     5870                                       (eq (acode-operator value) (%nx1-operator bound-special-ref))
     5871                                       (eq (acode-operator value) (%nx1-operator special-ref)))
     5872                                      (eq (car (acode-operands value)) sym)))))
     5873       (cond ((eq sym '*interrupt-level*)
     5874              (let* ((fixval (acode-fixnum-form-p value)))
     5875                (cond ((eql fixval 0)
     5876                       (if *x862-open-code-inline*
     5877                         (! bind-interrupt-level-0-inline)
     5878                         (! bind-interrupt-level-0)))
     5879                      ((eql fixval -1)
     5880                       (if *x862-open-code-inline*
     5881                         (! bind-interrupt-level-m1-inline)
     5882                         (! bind-interrupt-level-m1)))
     5883                      (t
     5884                       (if ea-p
     5885                         (x862-store-ea seg value *x862-arg-z*)
     5886                         (x862-one-targeted-reg-form seg value ($ *x862-arg-z*)))
     5887                       (! bind-interrupt-level))))
     5888              (x862-open-undo $undointerruptlevel))
     5889             (t
     5890              (if (or nil-p self-p)
     5891                (progn
     5892                  (x862-store-immediate seg (x862-symbol-value-cell sym) *x862-arg-z*)
     5893                  (if nil-p
     5894                    (! bind-nil)
     5895                    (if (or *x862-reckless* (eq (acode-operator value) (%nx1-operator special-ref)))
     5896                      (! bind-self)
     5897                      (! bind-self-boundp-check))))
     5898                (progn
     5899                  (if ea-p
     5900                    (x862-store-ea seg value *x862-arg-z*)
     5901                    (x862-one-targeted-reg-form seg value ($ *x862-arg-z*)))
     5902                  (x862-store-immediate seg (x862-symbol-value-cell sym) ($ *x862-arg-y*))
     5903                  (! bind)))
     5904              (x862-open-undo $undospecial)))
     5905       (x862-adjust-vstack (* 3 *x862-target-node-size*)))))))
    59015906
    59025907;;; Store the contents of EA - which denotes either a vframe location
     
    63156320        (let* ((n (length initforms))
    63166321               (npushed (- n 3))
     6322               (*x862-vstack* *x862-vstack*)
    63176323
    63186324               (arch (backend-target-arch *target-backend*)))
     
    67126718            (progn
    67136719              (! restore-nfp)
    6714               (! popj))
    6715             (if (and foldp (setq label (assq *x862-vstack* *x862-popreg-labels*)))
    6716               (! popj-via-jump (aref *backend-labels* (cdr label)))
    6717               (let* ((new-label (backend-get-next-label)))
    6718                 (@ new-label)
    6719                 (push (cons *x862-vstack* new-label) *x862-popreg-labels*)
    6720                 (x862-set-vstack (x862-restore-nvrs seg ea mask))
    6721                 (! restore-nfp)
    6722                 (! popj)))))))
     6720              (! restore-full-lisp-context)
     6721              (! jump-return-pc))
     6722            (break "nvr mask")))))
    67236723    nil))
    67246724
     
    69906990;;; it's likely that branching will be smaller.
    69916991(defun x862-fold-popj ()
    6992   (unless *x862-open-code-inline* ;  never fold if speed>space
    6993     *x862-register-restore-ea*))  ;  fold if we'll need to restore nvrs.
     6992  ())  ;  fold if we'll need to restore nvrs.
    69946993 
    69956994
     
    75137512              (progn
    75147513                (setq handled-lambda t)
    7515                 (x862-simple-args-entry seg rev-fixed num-fixed num-fixed))
     7514                (x862-simple-args-entry seg rev-fixed num-fixed num-fixed ))
    75167515              (setq arg-regs (x862-req-nargs-entry seg rev-fixed)))
    75177516            (if (and (not (or hardopt rest keys))
     
    75207519                (progn
    75217520                  (setq handled-lambda t)
    7522                   (x862-simple-args-entry seg (append rev-opt rev-fixed) num-fixed max-args))
     7521                  (x862-simple-args-entry seg (append rev-opt rev-fixed) num-fixed max-args ))
    75237522                (setq arg-regs (x862-simple-opt-entry seg rev-opt rev-fixed)))
    75247523              (progn
    7525                 '(when *backend-use-linear-scan*
    7526                   (warn "lambda-list too complex for now? handled = ~s" handled-lambda))
     7524
     7525                (when (and *backend-use-linear-scan* (not handled-lambda))
     7526                  (linear-scan-bailout))
    75277527                ;; From now on, the runtime assumes that all
    75287528                ;; incoming arguments are on the stack, either because
     
    92919291                   (ensuring-node-target (target vreg)
    92929292                     (multiple-value-bind (r1 r2) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*)
    9293                        (cond ((= (hard-regspec-value target)
    9294                                  (hard-regspec-value r1))
     9293                       (cond ((and (not *backend-use-linear-scan*)
     9294                                   (= (hard-regspec-value target)
     9295                                      (hard-regspec-value r1)))
    92959296                              (! fixnum-add2 target r2))
    9296                              ((= (hard-regspec-value target)
    9297                                  (hard-regspec-value r2))
     9297                             ((and (not *backend-use-linear-scan*)
     9298                                   (= (hard-regspec-value target)
     9299                                      (hard-regspec-value r2)))
    92989300                              (! fixnum-add2 target r1))
    92999301                             (t
  • branches/lscan/source/compiler/vinsn.lisp

    r16488 r16490  
    10571057(defmethod print-object ((i interval) stream)
    10581058  (print-unreadable-object (i stream :type t)
    1059     (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))))
     1059    (format stream "~d:(~d) ~s ~s/~s ~s (~s)" (interval-idx i) (interval-flags i) (interval-lreg i) (interval-begin i) (interval-end i) (interval-regtype i) (interval-preg i))))
    10601060
    10611061
     
    11131113      (dolist (v (fgn-call-vinsns block))
    11141114        (let* ((end-vinsn v)
    1115                (start-vinsn v)
    1116                (low (vinsn-sequence start-vinsn))
    1117                (high (vinsn-sequence end-vinsn))
     1115               (start-vinsn end-vinsn)
     1116               (low (1+ (vinsn-sequence start-vinsn)))
     1117               (high low)
    11181118               (killed (make-array 4)))
    11191119          (declare (simple-vector killed) )
    11201120
    1121           (when (vinsn-attribute-p start-vinsn :extended-call)
    1122             (setq high (vinsn-sequence (find-end-of-extended-call seg start-vinsn))))
    1123           (registers-killed-by-call start-vinsn killed)
     1121          (when (vinsn-attribute-p v :extended-call)
     1122            (setq high (vinsn-sequence (find-end-of-extended-call seg v))))
     1123          (registers-killed-by-call v killed)
    11241124          (let* ((interval (make-interval nil low high nil nil)))
    11251125            (setf (interval-killed interval) killed)
     
    12591259(defun process-pre-spilled-interval (seg interval lreg offset)
    12601260  (setf (interval-lreg interval) lreg
    1261        
    1262                                                
    12631261        (interval-spill-offset interval) offset)
    12641262  (let* ((used (vinsn-list-spill-area-used seg))
     
    12701268    (setf (interval-flags interval) interval-flag-pre-spilled)
    12711269   
    1272     (dolist (ref (lreg-refs lreg))
     1270
     1271    '(dolist (ref (lreg-refs lreg))
    12731272      (note-reload interval ref)
    12741273      )
    1275     (dolist (def (lreg-defs lreg))
     1274    '(dolist (def (lreg-defs lreg))
    12761275      (note-spill interval def)
    12771276      )))
     
    13621361                                     (when (eql 0 (sbit used i))
    13631362                                       (setf (sbit used i) 1)
    1364                                        (break "before")
    13651363                                       (incf (vinsn-list-spill-depth seg))
    13661364                                       (when (> (vinsn-list-spill-depth seg)
     
    13681366                                         (setf  (vinsn-list-max-spill-depth seg)
    13691367                                                (vinsn-list-spill-depth seg)))
    1370                                        (break)
    13711368                                       (return (+ i base))))
    13721369                                   (prog1 (vinsn-list-nfp-spill-offset seg)
     
    13781375               (child-used (member-if (lambda (pos) (> pos new-end)) (interval-use-positions parent)))
    13791376               (ncu (length child-used)))
    1380 
    1381             (let* ((min (car child-used))
    1382                    (max (car (last child-used))))
    1383               (let* ((child (make-interval  lreg min max (interval-regtype parent) nil  )))
    1384                 (setf (interval-parent child) parent
    1385                       (interval-child parent) child
    1386                       (interval-spill-offset child) offset
    1387                       (interval-flags child) (interval-flags parent)
    1388                       (interval-use-positions child) child-used
    1389                       (interval-use-positions parent) (butlast (interval-use-positions parent) ncu))
    1390                 (do-dll-nodes (r list (error "no next interval"))
    1391                   (when (> (interval-begin r) min)
    1392                     (insert-dll-node-before child r)
    1393                     (rebuild-interval-vector seg vector  child r)   
    1394                     (return)))
     1377          (let* ((defs (lreg-defs lreg)))
     1378            (when (cdr defs) (linear-scan-bailout "not yet - assignment in spilled interval")))
     1379         
     1380
     1381          (let* ((min (car child-used))
     1382                 (max (car (last child-used))))
     1383            (let* ((child (make-interval  lreg min max (interval-regtype parent) nil  )))
     1384              (setf (interval-parent child) parent
     1385                    (interval-child parent) child
     1386                    (interval-spill-offset child) offset
     1387                    (interval-flags child) (interval-flags parent)
     1388                    (interval-use-positions child) child-used
     1389                    (interval-use-positions parent) (butlast (interval-use-positions parent) ncu))
     1390              (do-dll-nodes (r list (error "no next interval"))
     1391                (when (> (interval-begin r) min)
     1392                  (insert-dll-node-before child r)
     1393                  (rebuild-interval-vector seg vector  child r)   
     1394                  (return)))
    13951395               
    13961396
    13971397
    1398                 ;; Ready to expire
    1399                 (setf (interval-end parent) (car (last (interval-use-positions parent)))))))))))
     1398              ;; Ready to expire
     1399              (setf (interval-end parent) (car (last (interval-use-positions parent)))))))))))
    14001400
    14011401(defun assign-interval-indices (vector)
     
    14851485(defun find-spill-candidate (intervals regtype  at)
    14861486  (let* ((max at) (best nil))
    1487     (do-dll-nodes (x intervals (or best (error "no interval to spill")))
    1488       (let* ((lreg (interval-lreg x)))
    1489         (unless (or (lreg-wired lreg) (lreg-local-p lreg) (not (eql regtype (interval-regtype x))))
    1490 
     1487    (do-dll-nodes (interval intervals (or best (error "no interval to spill")))
     1488      (let* ((lreg (interval-lreg interval)))
     1489        (unless (or (lreg-wired lreg) (lreg-local-p lreg) (not (eql regtype (interval-regtype interval))))
     1490          (let*  ((nextuse (member-if  (lambda (x) (> x at)) (interval-use-positions interval))))
     1491            (when (and nextuse (> (car nextuse) max))
     1492              (setq max (car nextuse) best interval))))))
     1493    best))
    14911494       
    1492           (let* ((all (append (lreg-refs lreg) (lreg-refs lreg))))
    1493             (when (> (vinsn-sequence (car (sort  (copy-list all) #'< :key (lambda (vinsn) (let* ((seq (vinsn-sequence vinsn))) (if (>= seq at) seq most-positive-fixnum)))))) max) (setq best x))))))))
     1495
     1496
    14941497
    14951498
     
    15391542            (if (null (interval-lreg i))
    15401543              (let* ((caller-save ())
    1541                      (call-vinsn (find-vinsn seg begin))
    15421544                     )
    15431545                (do-dll-nodes (a active)
     
    15451547                    ;; should see if preg is in the killed set
    15461548                    (push a caller-save)))
    1547                 (ls-note "caller-save = ~s, call = ~s" caller-save call-vinsn)
     1549                (ls-note "caller-save = ~s call @ ~s" caller-save begin)
    15481550                (dolist (cs caller-save)
    15491551                  (spill-and-split-interval    seg 'call cs begin intervals unhandled)
     
    16651667          (destructuring-bind (i . refs) r
    16661668            (dolist (ref refs)
     1669
    16671670              (let* ((preg (interval-preg i))
    16681671                     (offset (interval-spill-offset i))
     
    16751678         (lregs (vinsn-list-lregs seg))
    16761679         (nregs (length lregs)))
    1677              
     1680
     1681   
     1682               
     1683               
    16781684    (dovector (lreg lregs )
    16791685      (let* ((interval (lreg-interval lreg))
    16801686             (offset (if interval (interval-spill-offset interval))))
    1681         (when offset
     1687       (when offset
     1688         (if (eql 0 (interval-flags interval))
    16821689          (do* ((child (interval-child interval) (interval-child child)))
    16831690               ((null child))
     
    16871694                   (child-start-vinsn (find-vinsn seg (interval-begin child))))
    16881695              (note-reload child child-start-vinsn)
    1689               (note-spill parent parent-end-vinsn))))))
     1696              (note-spill parent parent-end-vinsn)))
     1697           (let* ((family ()))
     1698             (push interval family)
     1699             (do* ((child (interval-child interval) (interval-child child)))
     1700                  ((null child))
     1701               (push child family))
     1702             (dolist (x family)
     1703               (dolist (use (interval-use-positions x))
     1704                 (let* ((v (find-vinsn seg use)))
     1705                   (note-reload x v)))))
     1706           ))))
    16901707
    16911708   
     
    16941711        (unless (eq to (fgn-extended-succ from))
    16951712
    1696         (let* ((live-in (fgn-live-in to)))
    1697           (declare (simple-bit-vector live-in))
    1698           (dotimes (i nregs)
    1699             (when (= (sbit live-in i) 1)
    1700               (let* ((interval (lreg-interval (aref lregs i)))
    1701                      (offset (interval-spill-offset interval)))
     1713          (let* ((live-in (fgn-live-in to)))
     1714            (declare (simple-bit-vector live-in))
     1715            (dotimes (i nregs)
     1716              (when (= (sbit live-in i) 1)
     1717                (let* ((interval (lreg-interval (aref lregs i)))
     1718                       (offset (interval-spill-offset interval)))
    17021719                     
    1703                 (when offset
    1704 
    1705                   (multiple-value-bind (to-interval to-vinsn)
    1706                       (first-use-of-interval-in-block seg interval to)
    1707                     (multiple-value-bind (from-interval from-vinsn)
    1708                         (last-use-of-interval-in-block seg interval from)
    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)))))))))))))
     1720                  (when offset
     1721
     1722                    (multiple-value-bind (to-interval to-vinsn)
     1723                        (first-use-of-interval-in-block seg interval to)
     1724                      (multiple-value-bind (from-interval from-vinsn)
     1725                          (last-use-of-interval-in-block seg interval from)
     1726
     1727                        (or from-interval (ls-note "no frominterval for ~s" from))
     1728                        (or to-interval (break "no to interval for ~s" to))
     1729                        (when (and from-interval to-interval (not (eq from-interval to-interval)))
     1730                          (when (eql 0 (interval-flags from-interval))(note-spill from-interval from-vinsn))
     1731                     
     1732                          (note-reload to-interval to-vinsn))))))))))))))
    17141733                             
    17151734                         
     
    17231742                           
    17241743
    1725 (defun linear-scan-bailout (&optional (reason "generic failure"))
     1744(defun linear-scan-bailout (&optional (reason "generic failure" reason-p))
    17261745  (when *backend-use-linear-scan*
    1727     (format *error-output* "~%~%bailing-out of linear-scan:~&~&~a" reason)
     1746    (when (or reason-p *linear-scan-verbose*)
     1747      (format *error-output* "~%~%bailing-out of linear-scan:~&~&~a" reason))
    17281748    (signal 'linear-scan-bailout)))
     1749
     1750(defun try-to-omit-frame-pointer (seg)
     1751  (let* ((uses ()))
     1752    (when
     1753      (do-dll-nodes (v seg t)
     1754        (when (vinsn-attribute-p v :needs-frame-pointer)
     1755          (return nil))
     1756        (if (vinsn-attribute-p v :uses-frame-pointer)
     1757          (push v uses)))
     1758      (dolist (v uses t) (elide-vinsn v)))))
    17291759
    17301760(defun optimize-vinsns (header)
     
    17851815
    17861816             (linearize-flow-graph fg header)
     1817             (try-to-omit-frame-pointer header)
    17871818             t))
    17881819          (t t))))
Note: See TracChangeset for help on using the changeset viewer.