common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Allow a TN to be used more than once in :more.

Browse source 
When the number of more arguments overflow local-tn-limit they are
assigned the same number. Avoid doing that twice for a duplicate TN.

Reported by Qian Yun.
This commit is contained in:
Stas Boukarev 2022-08-05 16:27:01 +03:00
parent 3bfea7ffd3
commit 45fa5691bf
2 changed files with 40 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
src/compiler/life.lisp
View file

@ -305,20 +305,11 @@
((null op))
(let ((tn (tn-ref-tn op)))
(unless (member (tn-kind tn) '(:unused :constant))
(assert
(flet ((frob (refs)
(do ((ref refs (tn-ref-next ref)))
((null ref) t)
(when (and (eq (vop-block (tn-ref-vop ref)) block)
(not (eq ref op)))
(return nil)))))
(and (frob (tn-reads tn)) (frob (tn-writes tn))))
() "More operand ~S used more than once in its VOP." op)
(aver (not (find-in #'global-conflicts-next-blockwise tn
(ir2-block-global-tns block)
:key #'global-conflicts-tn)))
(add-global-conflict :read-only tn block num)
;; A TN could be used more than once in :more.
(unless (find-in #'global-conflicts-next-blockwise tn
(ir2-block-global-tns block)
:key #'global-conflicts-tn)
(add-global-conflict :read-only tn block num))
(setf (tn-local tn) block)
(setf (tn-local-number tn) num)))))
(values))
@ -363,27 +354,27 @@
(clear-lifetime-info 2block)
(cond
((vop-next lose)
(aver (not (eq last-lose lose)))
(let ((new (split-ir2-blocks 2block lose (incf counter))))
(aver (not (find-local-references new)))
(init-global-conflict-kind new)))
(t
(aver (not (eq lose coalesced)))
(setq coalesced lose)
(event coalesce-more-ltn-numbers (vop-node lose))
(let ((info (vop-info lose))
(new (if (vop-prev lose)
(split-ir2-blocks 2block (vop-prev lose)
(incf counter))
2block)))
(coalesce-more-ltn-numbers new (vop-args lose)
(vop-info-arg-types info))
(coalesce-more-ltn-numbers new (vop-results lose)
(vop-info-result-types info))
(let ((lose (find-local-references new)))
(aver (not lose)))
(init-global-conflict-kind new))))))))
((vop-next lose)
(aver (not (eq last-lose lose)))
(let ((new (split-ir2-blocks 2block lose (incf counter))))
(aver (not (find-local-references new)))
(init-global-conflict-kind new)))
(t
(aver (not (eq lose coalesced)))
(setq coalesced lose)
(event coalesce-more-ltn-numbers (vop-node lose))
(let ((info (vop-info lose))
(new (if (vop-prev lose)
(split-ir2-blocks 2block (vop-prev lose)
(incf counter))
2block)))
(coalesce-more-ltn-numbers new (vop-args lose)
(vop-info-arg-types info))
(coalesce-more-ltn-numbers new (vop-results lose)
(vop-info-result-types info))
(let ((lose (find-local-references new)))
(aver (not lose)))
(init-global-conflict-kind new))))))))
(values))

14
tests/compiler-2.pure.lisp
View file

@ -3709,3 +3709,17 @@
(f a)))
((() 1) 1)
(('(2) 1) 2)))
(with-test (:name :duplicate-more-local-tn-overflow)
(let ((vars (loop repeat 200 collect (gensym)))
(args (loop repeat 201 for i from (random 30000)
collect i)))
(assert
(equal
(apply
(compile
()
`(lambda (a ,@vars)
(list a a ,@vars)))
args)
(cons (car args) args)))))