compiler.tree sequences accessors tools.test kernel math ;
\ count-introductions must-infer
-\ fixup-enter-recursive must-infer
-\ eliminate-introductions must-infer
\ normalize must-infer
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
+
+DEFER: bbb
+: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
+: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
+
+[ ] [ [ bbb ] build-tree normalize drop ] unit-test
+
+: ccc ( -- ) ccc drop 1 ; inline recursive
+
+[ ] [ [ ccc ] build-tree normalize drop ] unit-test
+
+DEFER: eee
+: ddd ( -- ) eee ; inline recursive
+: eee ( -- ) swap ddd ; inline recursive
+
+[ ] [ [ eee ] build-tree normalize drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
+combinators sequences.deep assocs
stack-checker.backend
stack-checker.branches
stack-checker.inlining
M: #recursive count-introductions*
[ label>> ] [ child>> count-introductions ] bi
- >>introductions drop ;
+ >>introductions
+ drop ;
M: node count-introductions* drop ;
M: node collect-label-info drop ;
-! Eliminate introductions
-SYMBOL: introduction-stack
-
-: fixup-enter-recursive ( introductions recursive -- )
- [ child>> first ] [ in-d>> ] bi >>in-d
- [ append ] change-out-d
- drop ;
+! Normalize
+GENERIC: normalize* ( node -- node' )
-GENERIC: eliminate-introductions* ( node -- node' )
+SYMBOL: introduction-stack
: pop-introduction ( -- value )
introduction-stack [ unclip-last swap ] change ;
: pop-introductions ( n -- values )
introduction-stack [ swap cut* swap ] change ;
-M: #introduce eliminate-introductions*
+M: #introduce normalize*
out-d>> [ length pop-introductions ] keep #copy ;
SYMBOL: remaining-introductions
-M: #branch eliminate-introductions*
- dup children>> [
+M: #branch normalize*
+ [
[
- [ eliminate-introductions* ] change-each
- introduction-stack get
- ] with-scope
- ] map
+ [
+ [ normalize* ] map flatten
+ introduction-stack get
+ 2array
+ ] with-scope
+ ] map unzip swap
+ ] change-children swap
[ remaining-introductions set ]
[ [ length ] map infimum introduction-stack [ swap head ] change ]
bi ;
] if
] 3map ;
-M: #phi eliminate-introductions*
+M: #phi normalize*
remaining-introductions get swap dup terminated>>
'[ , eliminate-phi-introductions ] change-phi-in-d ;
-M: node eliminate-introductions* ;
-
-: eliminate-introductions ( nodes introductions -- nodes )
+: (normalize) ( nodes introductions -- nodes )
introduction-stack [
- [ eliminate-introductions* ] map
+ [ normalize* ] map flatten
] with-variable ;
-: eliminate-toplevel-introductions ( nodes -- nodes' )
- dup count-introductions make-values
- [ eliminate-introductions ] [ nip #introduce ] 2bi
- prefix ;
-
-: eliminate-recursive-introductions ( recursive n -- )
- make-values
- [ swap fixup-enter-recursive ]
- [ '[ , eliminate-introductions ] change-child drop ]
- 2bi ;
-
-! Normalize
-GENERIC: normalize* ( node -- node' )
-
M: #recursive normalize*
- dup dup label>> introductions>>
- eliminate-recursive-introductions ;
+ dup label>> introductions>>
+ [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
+ [ make-values '[ , (normalize) ] change-child ]
+ 2bi ;
M: #enter-recursive normalize*
+ [ introduction-stack get prepend ] change-out-d
dup [ label>> ] keep >>enter-recursive drop
dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
: unchanged-underneath ( #call-recursive -- n )
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
-M: #call-recursive normalize*
- dup unchanged-underneath
+: call<return ( #call-recursive n -- nodes )
+ neg dup make-values [
+ [ pop-introductions '[ , prepend ] change-in-d ]
+ [ '[ , prepend ] change-out-d ]
+ bi*
+ ] [ introduction-stack [ prepend ] change ] bi ;
+
+: call>return ( #call-recursive n -- nodes )
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
[ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
2bi 2array ;
+M: #call-recursive normalize*
+ dup unchanged-underneath {
+ { [ dup 0 < ] [ call<return ] }
+ { [ dup 0 = ] [ drop ] }
+ { [ dup 0 > ] [ call>return ] }
+ } cond ;
+
M: node normalize* ;
: normalize ( nodes -- nodes' )
dup [ collect-label-info ] each-node
- eliminate-toplevel-introductions
- [ normalize* ] map-nodes ;
+ dup count-introductions make-values
+ [ (normalize) ] [ nip #introduce ] 2bi
+ prefix ;
\ #return new
swap >>in-d ;
-TUPLE: #recursive < node in-d word label loop? returns calls child ;
+TUPLE: #recursive < node in-d word label loop? child ;
-: #recursive ( word label inputs child -- node )
+: #recursive ( label inputs child -- node )
\ #recursive new
swap >>child
swap >>in-d
- swap >>label
- swap >>word ;
+ swap >>label ;
TUPLE: #enter-recursive < node in-d out-d label ;
dup pair? [ second effect? ] [ drop f ] if ;
: make-copies ( values effect-in -- values' )
- [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
+ [ length cut* ] keep
+ [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
+ append ;
SYMBOL: enter-in
SYMBOL: enter-out
: prepare-stack ( word -- )
- required-stack-effect in>> [ length ensure-d ] keep
- [ drop enter-in set ] [ make-copies enter-out set ] 2bi ;
+ required-stack-effect in>>
+ [ length ensure-d drop ] [
+ meta-d get clone enter-in set
+ meta-d get swap make-copies enter-out set
+ ] bi ;
: emit-enter-recursive ( label -- )
enter-out get >>enter-out
: recursive-word-inputs ( label -- n )
entry-stack-height d-in get + ;
-: (inline-recursive-word) ( word -- word label in out visitor )
+: (inline-recursive-word) ( word -- label in out visitor )
dup prepare-stack
[
init-inference
dup <inline-recursive>
[ dup emit-enter-recursive (inline-word) ]
[ end-recursive-word ]
- [ ]
+ [ nip ]
2tri
check->r
(inline-recursive-word)
[ consume-d ] [ output-d ] [ ] tri* #recursive, ;
-: check-call-height ( word label -- )
- entry-stack-height current-stack-height >
- [ diverging-recursion-error inference-error ] [ drop ] if ;
+: check-call-height ( label -- )
+ dup entry-stack-height current-stack-height >
+ [ word>> diverging-recursion-error inference-error ] [ drop ] if ;
+
+: trim-stack ( label seq -- stack )
+ swap word>> required-stack-effect in>> length tail* ;
: call-site-stack ( label -- stack )
- required-stack-effect in>> length meta-d get swap tail* ;
+ meta-d get trim-stack ;
+
+: trimmed-enter-out ( label -- stack )
+ dup enter-out>> trim-stack ;
-: check-call-site-stack ( stack label -- )
- tuck enter-out>>
+: check-call-site-stack ( label -- )
+ [ ] [ call-site-stack ] [ trimmed-enter-out ] tri
[ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
-: add-call ( word label -- )
- [ check-call-height ]
- [ [ call-site-stack ] dip check-call-site-stack ] 2bi ;
+: check-call ( label -- )
+ [ check-call-height ] [ check-call-site-stack ] bi ;
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi
: call-recursive-inline-word ( word -- )
dup "recursive" word-prop [
[ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
- [ add-call drop ]
- [ nip '[ , #call-recursive, ] consume/produce ]
- 3bi
+ [ 2nip check-call ] [ nip '[ , #call-recursive, ] consume/produce ] 3bi
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
inline recursive
-[ unbalanced-retain-usage ] [ inference-error? ] must-fail-with
+[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
+
+DEFER: eee'
+: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
+: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
+
+[ [ eee' ] infer ] [ inference-error? ] must-fail-with
M: f #dispatch, 2drop ;
M: f #phi, drop drop drop drop drop ;
M: f #declare, drop ;
-M: f #recursive, 2drop 2drop ;
+M: f #recursive, 3drop ;
M: f #copy, 2drop ;
M: f #drop, drop ;
M: f #alien-invoke, drop ;
HOOK: #return, stack-visitor ( stack -- )
HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
-HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
+HOOK: #recursive, stack-visitor ( label inputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- )
HOOK: #alien-invoke, stack-visitor ( params -- )
HOOK: #alien-indirect, stack-visitor ( params -- )
projects / factor.git / commitdiff