steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.tree.propagation.call-effect: fix case where quotation inlining could enter an infinite loop: [ dup call( quot -- ) ] dup call( quot -- ) etc

db4
Slava Pestov 2009-08-01 23:34:14 -05:00
parent 1ef9cd27d3
commit e01fc93812
3 changed files with 16 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
View File

@ -49,3 +49,7 @@ IN: compiler.tree.propagation.call-effect.tests
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test [ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test [ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test [ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test

10
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -3,7 +3,8 @@
USING: accessors combinators combinators.private effects fry USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations kernel kernel.private make sequences continuations quotations
words math stack-checker stack-checker.transforms words math stack-checker stack-checker.transforms
compiler.tree.propagation.info slots.private ; compiler.tree.propagation.info
compiler.tree.propagation.inlining ;
IN: compiler.tree.propagation.call-effect IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions. ! call( and execute( have complex expansions.
@ -130,8 +131,9 @@ ERROR: uninferable ;
: (infer-value) ( value-info -- effect ) : (infer-value) ( value-info -- effect )
dup class>> { dup class>> {
{ \ quotation [ { \ quotation [
literal>> [ uninferable ] unless* cached-effect literal>> [ uninferable ] unless*
dup +unknown+ = [ uninferable ] when dup already-inlined? [ uninferable ] when
cached-effect dup +unknown+ = [ uninferable ] when
] } ] }
{ \ curry [ { \ curry [
slots>> third (infer-value) slots>> third (infer-value)
@ -151,7 +153,7 @@ ERROR: uninferable ;
: (value>quot) ( value-info -- quot ) : (value>quot) ( value-info -- quot )
dup class>> { dup class>> {
{ \ quotation [ literal>> '[ drop @ ] ] } { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
{ \ curry [ { \ curry [
slots>> third (value>quot) slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ] '[ [ obj>> ] [ quot>> @ ] bi ]

8
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -163,13 +163,17 @@ DEFER: (flat-length)
SYMBOL: history SYMBOL: history
: already-inlined? ( obj -- ? ) history get memq? ;
: add-to-history ( obj -- ) history [ swap suffix ] change ;
: remember-inlining ( word -- ) : remember-inlining ( word -- )
[ inlining-count get inc-at ] [ inlining-count get inc-at ]
[ history [ swap suffix ] change ] [ add-to-history ]
bi ; bi ;
:: inline-word ( #call word -- ? ) :: inline-word ( #call word -- ? )
word history get memq? [ f ] [ word already-inlined? [ f ] [
#call word splicing-body [ #call word splicing-body [
[ [
word remember-inlining word remember-inlining