Working on stricter retain stack usage

db4
Slava Pestov 2008-08-18 20:08:45 -05:00
parent 1f89f9bd86
commit 705054b567
3 changed files with 16 additions and 10 deletions

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;