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

Debugging new optimizer

db4
Slava Pestov 2008-08-14 23:35:19 -05:00
parent a61e13f7be
commit e1987d4af9
27 changed files with 200 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/columns/columns.factor
View File

@ -15,4 +15,4 @@ M: column length seq>> length ;
INSTANCE: column virtual-sequence INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' ) : <flipped> ( seq -- seq' )
dup empty? [ first length [ <column> ] with map ] unless ; dup empty? [ dup first length [ <column> ] with map ] unless ;

8
basis/compiler/compiler.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 compiler.units continuations vocabs assocs dlists definitions
math threads graphs generic combinators dequeues search-dequeues math threads graphs generic combinators dequeues search-dequeues
stack-checker stack-checker.state compiler.generator stack-checker stack-checker.state compiler.generator
@ -47,10 +47,10 @@ SYMBOL: +failed+
: (compile) ( word -- ) : (compile) ( word -- )
USE: prettyprint dup . USE: prettyprint dup .
[ '[
H{ } clone dependencies set H{ } clone dependencies set
{ , {
[ compile-begins ] [ compile-begins ]
[ [
[ build-tree-from-word ] [ compile-failed return ] recover [ build-tree-from-word ] [ compile-failed return ] recover
@ -59,7 +59,7 @@ SYMBOL: +failed+
[ dup generate ] [ dup generate ]
[ compile-succeeded ] [ compile-succeeded ]
} cleave } cleave
] curry with-return ; ] with-return ;
: compile-loop ( dequeue -- ) : compile-loop ( dequeue -- )
[ (compile) yield ] slurp-dequeue ; [ (compile) yield ] slurp-dequeue ;

8
basis/compiler/generator/generator.factor
View File

@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
%jump-label ; %jump-label ;
: generate-call ( label -- next ) : generate-call ( label -- next )
dup maybe-compile ! dup maybe-compile
end-basic-block end-basic-block
dup compiling-loops get at [ dup compiling-loops get at [
%jump-label f %jump-label f
@ -107,7 +107,7 @@ M: node generate-node drop iterate-next ;
] ?if ; ] ?if ;
! #recursive ! #recursive
: compile-recursive ( node -- ) : compile-recursive ( node -- next )
dup label>> id>> generate-call >r dup label>> id>> generate-call >r
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
r> ; r> ;
@ -115,7 +115,7 @@ M: node generate-node drop iterate-next ;
: compiling-loop ( word -- ) : compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ; <label> dup resolve-label swap compiling-loops get set-at ;
: compile-loop ( node -- ) : compile-loop ( node -- next )
end-basic-block end-basic-block
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
iterate-next ; iterate-next ;
@ -232,7 +232,7 @@ M: #dispatch generate-node
] if ; ] if ;
M: #call generate-node 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 [ dup find-if-intrinsic [
do-if-intrinsic do-if-intrinsic
] [ ] [

7
basis/compiler/tree/builder/builder-tests.factor
View File

@ -1,6 +1,11 @@
IN: compiler.tree.builder.tests 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 must-infer
\ build-tree-with must-infer \ build-tree-with must-infer
\ build-tree-from-word 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

37
basis/compiler/tree/builder/builder.factor
View File

@ -22,10 +22,15 @@ IN: compiler.tree.builder
] with-tree-builder nip ] with-tree-builder nip
unclip-last in-d>> ; unclip-last in-d>> ;
: ends-with-terminate? ( nodes -- ? )
dup empty? [ drop f ] [ peek #terminate? ] if ;
: build-sub-tree ( #call quot -- nodes ) : build-sub-tree ( #call quot -- nodes )
[ [ out-d>> ] [ in-d>> ] bi ] dip [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
build-tree-with over ends-with-terminate?
rot #copy suffix ; [ drop swap [ f swap #push ] map append ]
[ rot #copy suffix ]
if ;
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ; swap "predicate" word-prop append ;
@ -70,13 +75,31 @@ IN: compiler.tree.builder
[ drop ] [ drop ]
} cond ; } 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 ) : 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 [ check-cannot-infer ]
dup specialized-def over dup 2array 1array infer-quot [ check-no-compile ]
finish-word [ (build-tree-from-word) ]
[ finish-word ]
} cleave
] maybe-cannot-infer ] maybe-cannot-infer
] with-tree-builder ; ] with-tree-builder ;

32
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -13,14 +13,30 @@ IN: compiler.tree.cleanup
! A phase run after propagation to finish the job, so to speak. ! A phase run after propagation to finish the job, so to speak.
! Codifies speculative inlining decisions, deletes branches ! Codifies speculative inlining decisions, deletes branches
! marked as never taken, and flattens local recursive blocks ! 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 ) GENERIC: cleanup* ( node -- node/nodes )
: termination-cleanup ( nodes -- nodes' )
dup [ #terminate? ] find drop [ 1+ cut delete-nodes ] when* ;
: cleanup ( nodes -- nodes' ) : cleanup ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods #! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved #! do it since the logic is a bit more involved
[ cleanup* ] map flatten ; [ cleanup* ] map flatten ; ! termination-cleanup ;
: cleanup-folding? ( #call -- ? ) : cleanup-folding? ( #call -- ? )
node-output-infos dup empty? node-output-infos dup empty?
@ -74,18 +90,6 @@ M: #call cleanup*
M: #declare cleanup* drop f ; 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 -- ) : delete-unreachable-branches ( #branch -- )
dup live-branches>> '[ dup live-branches>> '[
, ,

77
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -20,48 +20,47 @@ M: #phi compute-live-values*
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ] [ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
2bi ; 2bi ;
SYMBOL: if-node M: #branch remove-dead-code*
[ [ (remove-dead-code) ] map ] change-children ;
M: #if remove-dead-code*
[ [ (remove-dead-code) ] map ] change-children
dup if-node set ;
: remove-phi-inputs ( #phi -- ) : remove-phi-inputs ( #phi -- )
dup [ out-d>> ] [ phi-in-d>> ] bi filter-corresponding >>phi-in-d dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d
dup [ out-r>> ] [ phi-in-r>> ] bi filter-corresponding >>phi-in-r dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r
drop ; drop ;
: dead-value-indices ( values -- indices ) ! SYMBOL: if-node
[ length ] keep live-values get !
'[ , nth , key? not ] filter ; inline ! : dead-value-indices ( values -- indices )
! [ length ] keep live-values get
: drop-d-values ( values indices -- node ) ! '[ , nth , key? not ] filter ; inline
[ drop filter-live ] [ nths filter-live ] 2bi !
[ make-values ] keep ! : drop-d-values ( values indices -- node )
[ drop ] [ zip ] 2bi ! [ drop filter-live ] [ nths filter-live ] 2bi
#shuffle ; ! [ make-values ] keep
! [ drop ] [ zip ] 2bi
: drop-r-values ( values indices -- nodes ) ! #shuffle ;
[ dup make-values [ #r> ] keep ] dip !
drop-d-values dup out-d>> dup make-values #>r ! : drop-r-values ( values indices -- nodes )
3array ; ! [ dup make-values [ #r> ] keep ] dip
! drop-d-values dup out-d>> dup make-values #>r
: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' ) ! 3array ;
'[ !
[ , drop-d-values 1array ] ! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
[ , drop-r-values ] ! '[
bi* 3append ! [ , drop-d-values 1array ]
] 3map ; ! [ , drop-r-values ]
! bi* 3append
: hoist-drops ( #phi -- ) ! ] 3map ;
if-node get swap !
{ ! : hoist-drops ( #phi -- )
[ phi-in-d>> ] ! if-node get swap
[ phi-in-r>> ] ! {
[ out-d>> dead-value-indices ] ! [ phi-in-d>> ]
[ out-r>> dead-value-indices ] ! [ phi-in-r>> ]
} cleave ! [ out-d>> dead-value-indices ]
'[ , , , , insert-drops ] change-children drop ; ! [ out-r>> dead-value-indices ]
! } cleave
! '[ , , , , insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- ) : remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d [ filter-live ] change-out-d
@ -70,7 +69,7 @@ M: #if remove-dead-code*
M: #phi remove-dead-code* M: #phi remove-dead-code*
{ {
[ hoist-drops ] ! [ hoist-drops ]
[ remove-phi-inputs ] [ remove-phi-inputs ]
[ remove-phi-outputs ] [ remove-phi-outputs ]
[ ] [ ]

36
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -1,6 +1,8 @@
USING: namespaces assocs sequences compiler.tree.builder USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree 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 compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io ; kernel math stack-checker.state accessors combinators io ;
IN: compiler.tree.dead-code.tests IN: compiler.tree.dead-code.tests
@ -10,6 +12,10 @@ IN: compiler.tree.dead-code.tests
: count-live-values ( quot -- n ) : count-live-values ( quot -- n )
build-tree build-tree
normalize normalize
propagate
cleanup
escape-analysis
unbox-tuples
compute-def-use compute-def-use
remove-dead-code remove-dead-code
0 swap [ 0 swap [
@ -32,11 +38,11 @@ IN: compiler.tree.dead-code.tests
[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test [ 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 [ 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 [ 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 [ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
[ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
: optimize-quot ( quot -- quot' ) : optimize-quot ( quot -- quot' )
build-tree normalize compute-def-use remove-dead-code build-tree
dup check-nodes nodes>quot ; 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 [ [ 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 ] ] [ [ [ [ drop drop ] [ non-flushable-3 drop ] if ] ] [
[ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
] unit-test ] 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

8
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -15,8 +15,14 @@ M: #enter-recursive compute-live-values*
M: #return-recursive compute-live-values* M: #return-recursive compute-live-values*
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ; [ 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* 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* M: #call-recursive remove-dead-code*
[ filter-live ] change-in-d [ filter-live ] change-in-d

9
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -25,11 +25,6 @@ M: #copy compute-live-values*
M: #call compute-live-values* nip look-at-inputs ; 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* M: #>r compute-live-values*
[ out-r>> ] [ in-d>> ] bi look-at-mapping ; [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
@ -108,3 +103,7 @@ M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi [ in-d>> ] [ out-d>> ] bi
2dup swap zip #shuffle 2dup swap zip #shuffle
remove-dead-code* ; remove-dead-code* ;
M: #terminate remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-in-r ;

8
basis/compiler/tree/debugger/debugger.factor
View File

@ -21,7 +21,7 @@ MACRO: match-choose ( alist -- )
MATCH-VARS: ?a ?b ?c ; MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( effect -- word/f ) : pretty-shuffle ( effect -- word/f )
[ in>> ] [ out>> ] bi drop-prefix [ >array ] bi@ 2array { [ in>> ] [ out>> ] bi 2array {
{ { { } { } } [ ] } { { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] } { { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] } { { { ?a ?b } { ?a ?b } } [ ] }
@ -84,6 +84,12 @@ M: #r> node>quot
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ; <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 ; M: node node>quot drop ;
: nodes>quot ( node -- quot ) : nodes>quot ( node -- quot )

3
basis/compiler/tree/def-use/def-use.factor
View File

@ -43,6 +43,8 @@ M: #phi node-uses-values
[ phi-in-d>> ] [ phi-in-r>> ] bi [ phi-in-d>> ] [ phi-in-r>> ] bi
append concat remove-bottom prune ; append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ; 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>> ; M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values ) 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: #return node-defs-values drop f ;
M: #recursive node-defs-values drop f ; M: #recursive node-defs-values drop f ;
M: #terminate 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>> ; M: node node-defs-values out-d>> ;
: node-def-use ( node -- ) : node-def-use ( node -- )

4
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -81,10 +81,10 @@ M: #return escape-analysis*
M: #alien-invoke escape-analysis* M: #alien-invoke escape-analysis*
[ in-d>> add-escaping-values ] [ in-d>> add-escaping-values ]
[ out-d>> unknown-allocation ] [ out-d>> unknown-allocations ]
bi ; bi ;
M: #alien-indirect escape-analysis* M: #alien-indirect escape-analysis*
[ in-d>> add-escaping-values ] [ in-d>> add-escaping-values ]
[ out-d>> unknown-allocation ] [ out-d>> unknown-allocations ]
bi ; bi ;

19
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -10,7 +10,8 @@ compiler.tree.dead-code
compiler.tree.strength-reduction compiler.tree.strength-reduction
compiler.tree.loop.detection compiler.tree.loop.detection
compiler.tree.loop.inversion compiler.tree.loop.inversion
compiler.tree.branch-fusion ; compiler.tree.branch-fusion
compiler.tree.checker ;
IN: compiler.tree.optimizer IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' ) : optimize-tree ( nodes -- nodes' )
@ -18,10 +19,12 @@ IN: compiler.tree.optimizer
propagate propagate
cleanup cleanup
detect-loops detect-loops
invert-loops ! invert-loops
fuse-branches ! fuse-branches
escape-analysis ! escape-analysis
unbox-tuples ! unbox-tuples
compute-def-use ! compute-def-use
remove-dead-code ! remove-dead-code
strength-reduce ; ! strength-reduce
compute-def-use USE: kernel
dup check-nodes ;

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

@ -123,7 +123,7 @@ DEFER: (flat-length)
SYMBOL: history SYMBOL: history
: remember-inlining ( word -- ) : remember-inlining ( word -- )
history get [ swap suffix ] change ; history [ swap suffix ] change ;
: inline-word ( #call word -- ) : inline-word ( #call word -- )
dup history get memq? [ dup history get memq? [

6
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -253,7 +253,7 @@ generic-comparison-ops [
{ <tuple> <tuple-boa> } [ { <tuple> <tuple-boa> } [
[ [
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
[ clear ] dip [ clear ] dip
] +outputs+ set-word-prop ] +outputs+ set-word-prop
] each ] each
@ -273,10 +273,10 @@ generic-comparison-ops [
\ instance? [ \ instance? [
[ value-info ] dip over literal>> class? [ [ value-info ] dip over literal>> class? [
[ literal>> ] dip predicate-constraints [ literal>> ] dip predicate-constraints
] [ 2drop f ] if ] [ 3drop f ] if
] +constraints+ set-word-prop ] +constraints+ set-word-prop
\ instance? [ \ instance? [
dup literal>> class? dup literal>> class?
[ literal>> predicate-output-infos ] [ 2drop f ] if [ literal>> predicate-output-infos ] [ 2drop object-info ] if
] +outputs+ set-word-prop ] +outputs+ set-word-prop

9
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -557,3 +557,12 @@ M: fixnum bad-generic 1 fixnum+fast ;
0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times 0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
] final-classes ] final-classes
] unit-test ] 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

1
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -52,6 +52,7 @@ IN: compiler.tree.propagation.recursive
3bi ; 3bi ;
M: #recursive propagate-around ( #recursive -- ) M: #recursive propagate-around ( #recursive -- )
"blah" USE: io print
{ 0 } clone [ USE: math { 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change constraints [ clone ] change

5
basis/compiler/tree/tree.factor
View File

@ -66,10 +66,11 @@ TUPLE: #r> < #renaming in-r out-d ;
swap >>out-d swap >>out-d
swap >>in-r ; 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 \ #terminate new
swap >>in-r
swap >>in-d ; swap >>in-d ;
TUPLE: #branch < node in-d children live-branches ; TUPLE: #branch < node in-d children live-branches ;

3
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -93,7 +93,8 @@ M: #shuffle unbox-tuples*
[ unzip [ flatten-values ] bi@ zip ] change-mapping ; [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples* M: #terminate unbox-tuples*
[ flatten-values ] change-in-d ; [ flatten-values ] change-in-d
[ flatten-values ] change-in-r ;
M: #phi unbox-tuples* M: #phi unbox-tuples*
[ [ flatten-values ] map pad-with-bottom ] change-phi-in-d [ [ flatten-values ] map pad-with-bottom ] change-phi-in-d

2
basis/disjoint-sets/disjoint-sets.factor
View File

@ -92,7 +92,7 @@ M:: disjoint-set equate ( a b disjoint-set -- )
'[ , , equate ] each ; '[ , , equate ] each ;
: equate-all ( seq disjoint-set -- ) : equate-all ( seq disjoint-set -- )
over dup empty? [ 2drop ] [ over empty? [ 2drop ] [
[ unclip-slice ] dip equate-all-with [ unclip-slice ] dip equate-all-with
] if ; ] if ;

2
basis/locals/locals.factor
View File

@ -288,7 +288,7 @@ M: wlet local-rewrite*
CREATE-METHOD CREATE-METHOD
[ parse-locals-definition ] with-method-definition ; [ parse-locals-definition ] with-method-definition ;
: parsed-lambda ( form -- ) : parsed-lambda ( accum form -- accum )
in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ; in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
PRIVATE> PRIVATE>

2
basis/stack-checker/backend/backend.factor
View File

@ -85,7 +85,7 @@ M: wrapper apply-object
M: object apply-object push-literal ; M: object apply-object push-literal ;
: terminate ( -- ) : terminate ( -- )
terminated? on meta-d get clone #terminate, ; terminated? on meta-d get clone meta-r get clone #terminate, ;
: infer-quot ( quot rstate -- ) : infer-quot ( quot rstate -- )
recursive-state get [ recursive-state get [

8
basis/stack-checker/inlining/inlining.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors USING: fry namespaces assocs kernel sequences words accessors
definitions math effects classes arrays combinators vectors definitions math math.order effects classes arrays combinators
arrays vectors arrays
stack-checker.state stack-checker.state
stack-checker.visitor stack-checker.visitor
stack-checker.backend stack-checker.backend
@ -115,8 +115,8 @@ SYMBOL: enter-out
: adjust-stack-effect ( effect -- effect' ) : adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi [ in>> ] [ out>> ] bi
meta-d get length pick length - object <repetition> meta-d get length pick length - 0 max
'[ , prepend ] bi@ object <repetition> '[ , prepend ] bi@
<effect> ; <effect> ;
: call-recursive-inline-word ( word -- ) : call-recursive-inline-word ( word -- )

6
basis/stack-checker/stack-checker-tests.factor
View File

@ -563,3 +563,9 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
{ 2 0 } [ drop f f [ 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

2
basis/stack-checker/visitor/dummy/dummy.factor
View File

@ -14,7 +14,7 @@ M: f #r>, 2drop ;
M: f #return, drop ; M: f #return, drop ;
M: f #enter-recursive, 3drop ; M: f #enter-recursive, 3drop ;
M: f #return-recursive, 3drop ; M: f #return-recursive, 3drop ;
M: f #terminate, drop ; M: f #terminate, 2drop ;
M: f #if, 3drop ; M: f #if, 3drop ;
M: f #dispatch, 2drop ; M: f #dispatch, 2drop ;
M: f #phi, drop drop drop drop drop ; M: f #phi, drop drop drop drop drop ;

2
basis/stack-checker/visitor/visitor.factor
View File

@ -17,7 +17,7 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, stack-visitor ( values -- ) HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- ) HOOK: #>r, stack-visitor ( inputs outputs -- )
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: #if, stack-visitor ( ? true false -- )
HOOK: #dispatch, stack-visitor ( n branches -- ) HOOK: #dispatch, stack-visitor ( n branches -- )
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- ) HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- )