Working on stricter retain stack usage
parent
1f89f9bd86
commit
705054b567
|
@ -61,10 +61,10 @@ SYMBOL: quotations
|
||||||
unify-branches
|
unify-branches
|
||||||
[ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
|
[ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
|
||||||
|
|
||||||
: retainstack-phi ( seq -- phi-in phi-out )
|
! : retainstack-phi ( seq -- phi-in phi-out )
|
||||||
[ length 0 <repetition> ] [ meta-r active-variable ] bi
|
! [ length 0 <repetition> ] [ meta-r active-variable ] bi
|
||||||
unify-branches
|
! unify-branches
|
||||||
[ drop ] [ ] [ dup >vector meta-r set ] tri* ;
|
! [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
|
||||||
|
|
||||||
: terminated-phi ( seq -- terminated )
|
: terminated-phi ( seq -- terminated )
|
||||||
terminated? branch-variable ;
|
terminated? branch-variable ;
|
||||||
|
@ -73,18 +73,25 @@ SYMBOL: quotations
|
||||||
[ quotation active-variable sift quotations set ]
|
[ quotation active-variable sift quotations set ]
|
||||||
[
|
[
|
||||||
[ datastack-phi ]
|
[ datastack-phi ]
|
||||||
[ retainstack-phi ]
|
! [ retainstack-phi ]
|
||||||
|
[ drop f f ]
|
||||||
[ terminated-phi ]
|
[ terminated-phi ]
|
||||||
tri #phi,
|
tri #phi,
|
||||||
]
|
]
|
||||||
[ [ terminated? swap at ] all? terminated? set ]
|
[ [ terminated? swap at ] all? terminated? set ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
|
: copy-inference ( -- )
|
||||||
|
meta-d [ clone ] change
|
||||||
|
V{ } clone meta-r set
|
||||||
|
d-in [ ] change ;
|
||||||
|
|
||||||
: infer-branch ( literal -- namespace )
|
: infer-branch ( literal -- namespace )
|
||||||
[
|
[
|
||||||
copy-inference
|
copy-inference
|
||||||
nest-visitor
|
nest-visitor
|
||||||
[ value>> quotation set ] [ infer-literal-quot ] bi
|
[ value>> quotation set ] [ infer-literal-quot ] bi
|
||||||
|
check->r
|
||||||
] H{ } make-assoc ; inline
|
] H{ } make-assoc ; inline
|
||||||
|
|
||||||
: infer-branches ( branches -- input children data )
|
: infer-branches ( branches -- input children data )
|
||||||
|
|
|
@ -21,3 +21,7 @@ M: callable infer ( quot -- effect )
|
||||||
dup subwords [ f +cannot-infer+ set-word-prop ] each
|
dup subwords [ f +cannot-infer+ set-word-prop ] each
|
||||||
f +cannot-infer+ set-word-prop
|
f +cannot-infer+ set-word-prop
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
|
: forget-effects ( -- )
|
||||||
|
forget-errors
|
||||||
|
all-words [ f +inferred-effect+ set-word-prop ] each ;
|
||||||
|
|
|
@ -70,11 +70,6 @@ SYMBOL: meta-r
|
||||||
: init-known-values ( -- )
|
: init-known-values ( -- )
|
||||||
H{ } clone known-values set ;
|
H{ } clone known-values set ;
|
||||||
|
|
||||||
: copy-inference ( -- )
|
|
||||||
meta-d [ clone ] change
|
|
||||||
meta-r [ clone ] change
|
|
||||||
d-in [ ] change ;
|
|
||||||
|
|
||||||
: recursive-label ( word -- label/f )
|
: recursive-label ( word -- label/f )
|
||||||
recursive-state get at ;
|
recursive-state get at ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue