Debugging new optimizer
Slava Pestov
parent
a61e13f7be
commit
e1987d4af9
|
|
@ -15,4 +15,4 @@ M: column length seq>> length ;
|
|||
INSTANCE: column virtual-sequence
|
||||
|
||||
: <flipped> ( seq -- seq' )
|
||||
dup empty? [ first length [ <column> ] with map ] unless ;
|
||||
dup empty? [ dup first length [ <column> ] with map ] unless ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces arrays sequences io debugger words
|
||||
USING: kernel namespaces arrays sequences io debugger words fry
|
||||
compiler.units continuations vocabs assocs dlists definitions
|
||||
math threads graphs generic combinators dequeues search-dequeues
|
||||
stack-checker stack-checker.state compiler.generator
|
||||
|
|
@ -47,10 +47,10 @@ SYMBOL: +failed+
|
|||
|
||||
: (compile) ( word -- )
|
||||
USE: prettyprint dup .
|
||||
[
|
||||
'[
|
||||
H{ } clone dependencies set
|
||||
|
||||
{
|
||||
, {
|
||||
[ compile-begins ]
|
||||
[
|
||||
[ build-tree-from-word ] [ compile-failed return ] recover
|
||||
|
|
@ -59,7 +59,7 @@ SYMBOL: +failed+
|
|||
[ dup generate ]
|
||||
[ compile-succeeded ]
|
||||
} cleave
|
||||
] curry with-return ;
|
||||
] with-return ;
|
||||
|
||||
: compile-loop ( dequeue -- )
|
||||
[ (compile) yield ] slurp-dequeue ;
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
|
|||
%jump-label ;
|
||||
|
||||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
! dup maybe-compile
|
||||
end-basic-block
|
||||
dup compiling-loops get at [
|
||||
%jump-label f
|
||||
|
|
@ -107,7 +107,7 @@ M: node generate-node drop iterate-next ;
|
|||
] ?if ;
|
||||
|
||||
! #recursive
|
||||
: compile-recursive ( node -- )
|
||||
: compile-recursive ( node -- next )
|
||||
dup label>> id>> generate-call >r
|
||||
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
|
||||
r> ;
|
||||
|
|
@ -115,7 +115,7 @@ M: node generate-node drop iterate-next ;
|
|||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
: compile-loop ( node -- )
|
||||
: compile-loop ( node -- next )
|
||||
end-basic-block
|
||||
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
|
||||
iterate-next ;
|
||||
|
|
@ -232,7 +232,7 @@ M: #dispatch generate-node
|
|||
] if ;
|
||||
|
||||
M: #call generate-node
|
||||
dup node-input-infos [ class>> ] map set-operand-classes
|
||||
! dup node-input-infos [ class>> ] map set-operand-classes
|
||||
dup find-if-intrinsic [
|
||||
do-if-intrinsic
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,11 @@
|
|||
IN: compiler.tree.builder.tests
|
||||
USING: compiler.tree.builder tools.test ;
|
||||
USING: compiler.tree.builder tools.test sequences kernel
|
||||
compiler.tree ;
|
||||
|
||||
\ build-tree must-infer
|
||||
\ build-tree-with must-infer
|
||||
\ build-tree-from-word must-infer
|
||||
|
||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
||||
|
||||
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
|
||||
|
|
|
|||
|
|
@ -22,10 +22,15 @@ IN: compiler.tree.builder
|
|||
] with-tree-builder nip
|
||||
unclip-last in-d>> ;
|
||||
|
||||
: ends-with-terminate? ( nodes -- ? )
|
||||
dup empty? [ drop f ] [ peek #terminate? ] if ;
|
||||
|
||||
: build-sub-tree ( #call quot -- nodes )
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip
|
||||
build-tree-with
|
||||
rot #copy suffix ;
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
|
||||
over ends-with-terminate?
|
||||
[ drop swap [ f swap #push ] map append ]
|
||||
[ rot #copy suffix ]
|
||||
if ;
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
|
@ -70,13 +75,31 @@ IN: compiler.tree.builder
|
|||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: (build-tree-from-word) ( word -- )
|
||||
dup
|
||||
[ "inline" word-prop ]
|
||||
[ "recursive" word-prop ] bi and [
|
||||
1quotation f infer-quot
|
||||
] [
|
||||
[ specialized-def ]
|
||||
[ dup 2array 1array ] bi infer-quot
|
||||
] if ;
|
||||
|
||||
: check-cannot-infer ( word -- )
|
||||
dup +cannot-infer+ word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
: check-no-compile ( word -- )
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
|
||||
|
||||
: build-tree-from-word ( word -- effect nodes )
|
||||
[
|
||||
[
|
||||
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
|
||||
dup "no-compile" word-prop [ cannot-infer-effect ] when
|
||||
dup specialized-def over dup 2array 1array infer-quot
|
||||
finish-word
|
||||
{
|
||||
[ check-cannot-infer ]
|
||||
[ check-no-compile ]
|
||||
[ (build-tree-from-word) ]
|
||||
[ finish-word ]
|
||||
} cleave
|
||||
] maybe-cannot-infer
|
||||
] with-tree-builder ;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,14 +13,30 @@ IN: compiler.tree.cleanup
|
|||
! A phase run after propagation to finish the job, so to speak.
|
||||
! Codifies speculative inlining decisions, deletes branches
|
||||
! marked as never taken, and flattens local recursive blocks
|
||||
! that do not call themselves.
|
||||
! that do not call themselves. Finally, if inlining inserts a
|
||||
! #terminate, we delete all nodes after that.
|
||||
|
||||
GENERIC: delete-node ( node -- )
|
||||
|
||||
M: #call-recursive delete-node
|
||||
dup label>> [ [ eq? not ] with filter ] change-calls drop ;
|
||||
|
||||
M: #return-recursive delete-node
|
||||
label>> f >>return drop ;
|
||||
|
||||
M: node delete-node drop ;
|
||||
|
||||
: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
|
||||
|
||||
GENERIC: cleanup* ( node -- node/nodes )
|
||||
|
||||
: termination-cleanup ( nodes -- nodes' )
|
||||
dup [ #terminate? ] find drop [ 1+ cut delete-nodes ] when* ;
|
||||
|
||||
: cleanup ( nodes -- nodes' )
|
||||
#! We don't recurse into children here, instead the methods
|
||||
#! do it since the logic is a bit more involved
|
||||
[ cleanup* ] map flatten ;
|
||||
[ cleanup* ] map flatten ; ! termination-cleanup ;
|
||||
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos dup empty?
|
||||
|
|
@ -74,18 +90,6 @@ M: #call cleanup*
|
|||
|
||||
M: #declare cleanup* drop f ;
|
||||
|
||||
GENERIC: delete-node ( node -- )
|
||||
|
||||
M: #call-recursive delete-node
|
||||
dup label>> [ [ eq? not ] with filter ] change-calls drop ;
|
||||
|
||||
M: #return-recursive delete-node
|
||||
label>> f >>return drop ;
|
||||
|
||||
M: node delete-node drop ;
|
||||
|
||||
: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
|
||||
|
||||
: delete-unreachable-branches ( #branch -- )
|
||||
dup live-branches>> '[
|
||||
,
|
||||
|
|
|
|||
|
|
@ -20,48 +20,47 @@ M: #phi compute-live-values*
|
|||
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
|
||||
2bi ;
|
||||
|
||||
SYMBOL: if-node
|
||||
|
||||
M: #if remove-dead-code*
|
||||
[ [ (remove-dead-code) ] map ] change-children
|
||||
dup if-node set ;
|
||||
M: #branch remove-dead-code*
|
||||
[ [ (remove-dead-code) ] map ] change-children ;
|
||||
|
||||
: remove-phi-inputs ( #phi -- )
|
||||
dup [ out-d>> ] [ phi-in-d>> ] bi filter-corresponding >>phi-in-d
|
||||
dup [ out-r>> ] [ phi-in-r>> ] bi filter-corresponding >>phi-in-r
|
||||
dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d
|
||||
dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r
|
||||
drop ;
|
||||
|
||||
: dead-value-indices ( values -- indices )
|
||||
[ length ] keep live-values get
|
||||
'[ , nth , key? not ] filter ; inline
|
||||
|
||||
: drop-d-values ( values indices -- node )
|
||||
[ drop filter-live ] [ nths filter-live ] 2bi
|
||||
[ make-values ] keep
|
||||
[ drop ] [ zip ] 2bi
|
||||
#shuffle ;
|
||||
|
||||
: drop-r-values ( values indices -- nodes )
|
||||
[ dup make-values [ #r> ] keep ] dip
|
||||
drop-d-values dup out-d>> dup make-values #>r
|
||||
3array ;
|
||||
|
||||
: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
|
||||
'[
|
||||
[ , drop-d-values 1array ]
|
||||
[ , drop-r-values ]
|
||||
bi* 3append
|
||||
] 3map ;
|
||||
|
||||
: hoist-drops ( #phi -- )
|
||||
if-node get swap
|
||||
{
|
||||
[ phi-in-d>> ]
|
||||
[ phi-in-r>> ]
|
||||
[ out-d>> dead-value-indices ]
|
||||
[ out-r>> dead-value-indices ]
|
||||
} cleave
|
||||
'[ , , , , insert-drops ] change-children drop ;
|
||||
! SYMBOL: if-node
|
||||
!
|
||||
! : dead-value-indices ( values -- indices )
|
||||
! [ length ] keep live-values get
|
||||
! '[ , nth , key? not ] filter ; inline
|
||||
!
|
||||
! : drop-d-values ( values indices -- node )
|
||||
! [ drop filter-live ] [ nths filter-live ] 2bi
|
||||
! [ make-values ] keep
|
||||
! [ drop ] [ zip ] 2bi
|
||||
! #shuffle ;
|
||||
!
|
||||
! : drop-r-values ( values indices -- nodes )
|
||||
! [ dup make-values [ #r> ] keep ] dip
|
||||
! drop-d-values dup out-d>> dup make-values #>r
|
||||
! 3array ;
|
||||
!
|
||||
! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
|
||||
! '[
|
||||
! [ , drop-d-values 1array ]
|
||||
! [ , drop-r-values ]
|
||||
! bi* 3append
|
||||
! ] 3map ;
|
||||
!
|
||||
! : hoist-drops ( #phi -- )
|
||||
! if-node get swap
|
||||
! {
|
||||
! [ phi-in-d>> ]
|
||||
! [ phi-in-r>> ]
|
||||
! [ out-d>> dead-value-indices ]
|
||||
! [ out-r>> dead-value-indices ]
|
||||
! } cleave
|
||||
! '[ , , , , insert-drops ] change-children drop ;
|
||||
|
||||
: remove-phi-outputs ( #phi -- )
|
||||
[ filter-live ] change-out-d
|
||||
|
|
@ -70,7 +69,7 @@ M: #if remove-dead-code*
|
|||
|
||||
M: #phi remove-dead-code*
|
||||
{
|
||||
[ hoist-drops ]
|
||||
! [ hoist-drops ]
|
||||
[ remove-phi-inputs ]
|
||||
[ remove-phi-outputs ]
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
USING: namespaces assocs sequences compiler.tree.builder
|
||||
compiler.tree.dead-code compiler.tree.def-use compiler.tree
|
||||
compiler.tree.combinators compiler.tree.debugger
|
||||
compiler.tree.combinators compiler.tree.propagation
|
||||
compiler.tree.cleanup compiler.tree.escape-analysis
|
||||
compiler.tree.tuple-unboxing compiler.tree.debugger
|
||||
compiler.tree.normalization compiler.tree.checker tools.test
|
||||
kernel math stack-checker.state accessors combinators io ;
|
||||
IN: compiler.tree.dead-code.tests
|
||||
|
|
@ -10,6 +12,10 @@ IN: compiler.tree.dead-code.tests
|
|||
: count-live-values ( quot -- n )
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
0 swap [
|
||||
|
|
@ -32,11 +38,11 @@ IN: compiler.tree.dead-code.tests
|
|||
|
||||
[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
|
||||
|
||||
[ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
|
||||
[ 2 ] [ [ 1 + ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 3 ] [ [ 1 2 + 3 + ] count-live-values ] unit-test
|
||||
[ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
|
||||
|
||||
|
|
@ -52,9 +58,18 @@ IN: compiler.tree.dead-code.tests
|
|||
|
||||
[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
|
||||
|
||||
[ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
|
||||
|
||||
: optimize-quot ( quot -- quot' )
|
||||
build-tree normalize compute-def-use remove-dead-code
|
||||
dup check-nodes nodes>quot ;
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
"no-check" get [ dup check-nodes ] unless nodes>quot ;
|
||||
|
||||
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
|
||||
|
||||
|
|
@ -76,3 +91,14 @@ IN: compiler.tree.dead-code.tests
|
|||
[ [ [ drop drop ] [ non-flushable-3 drop ] if ] ] [
|
||||
[ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
|
||||
] unit-test
|
||||
|
||||
[ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
|
||||
|
||||
[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
|
||||
|
||||
: non-flushable-4 ( a -- b ) drop f ;
|
||||
|
||||
: recursive-test-1 ( a b -- )
|
||||
dup 10 < [
|
||||
>r drop 5 non-flushable-4 r> 1 + recursive-test-1
|
||||
] [ 2drop ] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -15,8 +15,14 @@ M: #enter-recursive compute-live-values*
|
|||
M: #return-recursive compute-live-values*
|
||||
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
|
||||
|
||||
M: #call-recursive compute-live-values*
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! inputs to #return nodes are live also.
|
||||
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
|
||||
|
||||
M: #recursive remove-dead-code*
|
||||
[ filter-live ] change-in-d ;
|
||||
[ filter-live ] change-in-d
|
||||
[ (remove-dead-code) ] change-child ;
|
||||
|
||||
M: #call-recursive remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
|
|
|
|||
|
|
@ -25,11 +25,6 @@ M: #copy compute-live-values*
|
|||
|
||||
M: #call compute-live-values* nip look-at-inputs ;
|
||||
|
||||
M: #call-recursive compute-live-values*
|
||||
#! If the output of a copy is live, then the corresponding
|
||||
#! inputs to #return nodes are live also.
|
||||
[ out-d>> ] [ label>> return>> ] bi look-at-mapping ;
|
||||
|
||||
M: #>r compute-live-values*
|
||||
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
|
||||
|
||||
|
|
@ -108,3 +103,7 @@ M: #copy remove-dead-code*
|
|||
[ in-d>> ] [ out-d>> ] bi
|
||||
2dup swap zip #shuffle
|
||||
remove-dead-code* ;
|
||||
|
||||
M: #terminate remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-in-r ;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ MACRO: match-choose ( alist -- )
|
|||
MATCH-VARS: ?a ?b ?c ;
|
||||
|
||||
: pretty-shuffle ( effect -- word/f )
|
||||
[ in>> ] [ out>> ] bi drop-prefix [ >array ] bi@ 2array {
|
||||
[ in>> ] [ out>> ] bi 2array {
|
||||
{ { { } { } } [ ] }
|
||||
{ { { ?a } { ?a } } [ ] }
|
||||
{ { { ?a ?b } { ?a ?b } } [ ] }
|
||||
|
|
@ -84,6 +84,12 @@ M: #r> node>quot
|
|||
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
|
||||
<repetition> % ;
|
||||
|
||||
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
|
||||
|
||||
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
|
||||
|
||||
M: #alien-callback node>quot params>> , \ #alien-callback , ;
|
||||
|
||||
M: node node>quot drop ;
|
||||
|
||||
: nodes>quot ( node -- quot )
|
||||
|
|
|
|||
|
|
@ -43,6 +43,8 @@ M: #phi node-uses-values
|
|||
[ phi-in-d>> ] [ phi-in-r>> ] bi
|
||||
append concat remove-bottom prune ;
|
||||
M: #declare node-uses-values declaration>> keys ;
|
||||
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
|
||||
M: #alien-callback node-uses-values drop f ;
|
||||
M: node node-uses-values in-d>> ;
|
||||
|
||||
GENERIC: node-defs-values ( node -- values )
|
||||
|
|
@ -54,6 +56,7 @@ M: #declare node-defs-values drop f ;
|
|||
M: #return node-defs-values drop f ;
|
||||
M: #recursive node-defs-values drop f ;
|
||||
M: #terminate node-defs-values drop f ;
|
||||
M: #alien-callback node-defs-values drop f ;
|
||||
M: node node-defs-values out-d>> ;
|
||||
|
||||
: node-def-use ( node -- )
|
||||
|
|
|
|||
|
|
@ -81,10 +81,10 @@ M: #return escape-analysis*
|
|||
|
||||
M: #alien-invoke escape-analysis*
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocation ]
|
||||
[ out-d>> unknown-allocations ]
|
||||
bi ;
|
||||
|
||||
M: #alien-indirect escape-analysis*
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocation ]
|
||||
[ out-d>> unknown-allocations ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ compiler.tree.dead-code
|
|||
compiler.tree.strength-reduction
|
||||
compiler.tree.loop.detection
|
||||
compiler.tree.loop.inversion
|
||||
compiler.tree.branch-fusion ;
|
||||
compiler.tree.branch-fusion
|
||||
compiler.tree.checker ;
|
||||
IN: compiler.tree.optimizer
|
||||
|
||||
: optimize-tree ( nodes -- nodes' )
|
||||
|
|
@ -18,10 +19,12 @@ IN: compiler.tree.optimizer
|
|||
propagate
|
||||
cleanup
|
||||
detect-loops
|
||||
invert-loops
|
||||
fuse-branches
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
strength-reduce ;
|
||||
! invert-loops
|
||||
! fuse-branches
|
||||
! escape-analysis
|
||||
! unbox-tuples
|
||||
! compute-def-use
|
||||
! remove-dead-code
|
||||
! strength-reduce
|
||||
compute-def-use USE: kernel
|
||||
dup check-nodes ;
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@ DEFER: (flat-length)
|
|||
SYMBOL: history
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
history get [ swap suffix ] change ;
|
||||
history [ swap suffix ] change ;
|
||||
|
||||
: inline-word ( #call word -- )
|
||||
dup history get memq? [
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@ generic-comparison-ops [
|
|||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
|
||||
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
|
||||
[ clear ] dip
|
||||
] +outputs+ set-word-prop
|
||||
] each
|
||||
|
|
@ -273,10 +273,10 @@ generic-comparison-ops [
|
|||
\ instance? [
|
||||
[ value-info ] dip over literal>> class? [
|
||||
[ literal>> ] dip predicate-constraints
|
||||
] [ 2drop f ] if
|
||||
] [ 3drop f ] if
|
||||
] +constraints+ set-word-prop
|
||||
|
||||
\ instance? [
|
||||
dup literal>> class?
|
||||
[ literal>> predicate-output-infos ] [ 2drop f ] if
|
||||
[ literal>> predicate-output-infos ] [ 2drop object-info ] if
|
||||
] +outputs+ set-word-prop
|
||||
|
|
|
|||
|
|
@ -557,3 +557,12 @@ M: fixnum bad-generic 1 fixnum+fast ;
|
|||
0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
GENERIC: infinite-loop ( a -- b )
|
||||
M: integer infinite-loop infinite-loop ;
|
||||
|
||||
[ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
|
||||
|
||||
[ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
|
||||
|
||||
[ ] [ [ instance? ] final-classes drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -52,6 +52,7 @@ IN: compiler.tree.propagation.recursive
|
|||
3bi ;
|
||||
|
||||
M: #recursive propagate-around ( #recursive -- )
|
||||
"blah" USE: io print
|
||||
{ 0 } clone [ USE: math
|
||||
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
|
||||
constraints [ clone ] change
|
||||
|
|
|
|||
|
|
@ -66,10 +66,11 @@ TUPLE: #r> < #renaming in-r out-d ;
|
|||
swap >>out-d
|
||||
swap >>in-r ;
|
||||
|
||||
TUPLE: #terminate < node in-d ;
|
||||
TUPLE: #terminate < node in-d in-r ;
|
||||
|
||||
: #terminate ( stack -- node )
|
||||
: #terminate ( in-d in-r -- node )
|
||||
\ #terminate new
|
||||
swap >>in-r
|
||||
swap >>in-d ;
|
||||
|
||||
TUPLE: #branch < node in-d children live-branches ;
|
||||
|
|
|
|||
|
|
@ -93,7 +93,8 @@ M: #shuffle unbox-tuples*
|
|||
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
|
||||
|
||||
M: #terminate unbox-tuples*
|
||||
[ flatten-values ] change-in-d ;
|
||||
[ flatten-values ] change-in-d
|
||||
[ flatten-values ] change-in-r ;
|
||||
|
||||
M: #phi unbox-tuples*
|
||||
[ [ flatten-values ] map pad-with-bottom ] change-phi-in-d
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ M:: disjoint-set equate ( a b disjoint-set -- )
|
|||
'[ , , equate ] each ;
|
||||
|
||||
: equate-all ( seq disjoint-set -- )
|
||||
over dup empty? [ 2drop ] [
|
||||
over empty? [ 2drop ] [
|
||||
[ unclip-slice ] dip equate-all-with
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -288,7 +288,7 @@ M: wlet local-rewrite*
|
|||
CREATE-METHOD
|
||||
[ parse-locals-definition ] with-method-definition ;
|
||||
|
||||
: parsed-lambda ( form -- )
|
||||
: parsed-lambda ( accum form -- accum )
|
||||
in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@ M: wrapper apply-object
|
|||
M: object apply-object push-literal ;
|
||||
|
||||
: terminate ( -- )
|
||||
terminated? on meta-d get clone #terminate, ;
|
||||
terminated? on meta-d get clone meta-r get clone #terminate, ;
|
||||
|
||||
: infer-quot ( quot rstate -- )
|
||||
recursive-state get [
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces assocs kernel sequences words accessors
|
||||
definitions math effects classes arrays combinators vectors
|
||||
arrays
|
||||
definitions math math.order effects classes arrays combinators
|
||||
vectors arrays
|
||||
stack-checker.state
|
||||
stack-checker.visitor
|
||||
stack-checker.backend
|
||||
|
|
@ -115,8 +115,8 @@ SYMBOL: enter-out
|
|||
|
||||
: adjust-stack-effect ( effect -- effect' )
|
||||
[ in>> ] [ out>> ] bi
|
||||
meta-d get length pick length - object <repetition>
|
||||
'[ , prepend ] bi@
|
||||
meta-d get length pick length - 0 max
|
||||
object <repetition> '[ , prepend ] bi@
|
||||
<effect> ;
|
||||
|
||||
: call-recursive-inline-word ( word -- )
|
||||
|
|
|
|||
|
|
@ -563,3 +563,9 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
|
|||
|
||||
{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
|
||||
{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
|
||||
|
||||
: unbalanced-retain-usage ( a b -- )
|
||||
dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
|
||||
inline recursive
|
||||
|
||||
[ unbalanced-retain-usage ] [ inference-error? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ M: f #r>, 2drop ;
|
|||
M: f #return, drop ;
|
||||
M: f #enter-recursive, 3drop ;
|
||||
M: f #return-recursive, 3drop ;
|
||||
M: f #terminate, drop ;
|
||||
M: f #terminate, 2drop ;
|
||||
M: f #if, 3drop ;
|
||||
M: f #dispatch, 2drop ;
|
||||
M: f #phi, drop drop drop drop drop ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
|
|||
HOOK: #drop, stack-visitor ( values -- )
|
||||
HOOK: #>r, stack-visitor ( inputs outputs -- )
|
||||
HOOK: #r>, stack-visitor ( inputs outputs -- )
|
||||
HOOK: #terminate, stack-visitor ( stack -- )
|
||||
HOOK: #terminate, stack-visitor ( in-d in-r -- )
|
||||
HOOK: #if, stack-visitor ( ? true false -- )
|
||||
HOOK: #dispatch, stack-visitor ( n branches -- )
|
||||
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue