diff --git a/core/generator/generator.factor b/core/generator/generator.factor index f417869715..7d3cbf9330 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -62,7 +62,7 @@ GENERIC: generate-node ( node -- next ) %prologue-later current-label-start define-label current-label-start resolve-label ; - + : generate ( word label node -- ) [ init-generate-nodes @@ -107,6 +107,20 @@ M: #label generate-node dup #label-word over node-param rot node-child generate r> ; +! #loop +SYMBOL: compiling-loop? + +M: #loop generate-node + end-basic-block + [ + dup node-param compiling-label set + current-label-start define-label + current-label-start resolve-label + compiling-loop? on + node-child generate-nodes + ] with-scope + end-basic-block ; + ! #if : end-false-branch ( label -- ) tail-call? [ %return drop ] [ %jump-label ] if ; @@ -256,4 +270,6 @@ M: #r> generate-node iterate-next ; ! #return -M: #return generate-node drop end-basic-block %return f ; +M: #return generate-node + node-param compiling-label get eq? compiling-loop? get and + [ end-basic-block %return ] unless f ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index d76ab031f2..58094f584f 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -97,11 +97,13 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label word ; +TUPLE: #label word loop? ; : #label ( word label -- node ) \ #label param-node [ set-#label-word ] keep ; +PREDICATE: #label #loop #label-loop? ; + TUPLE: #entry ; : #entry ( -- node ) \ #entry all-out-node ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index c64d1fd010..1ae3b4388c 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -367,6 +367,10 @@ DEFER: (flat-length) dup node-param dup +inlined+ depends-on word-def splice-quot ; +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 8 <= ] [ drop f ] if ; + M: #call optimize-node* { { [ dup flush-eval? ] [ flush-eval ] } @@ -375,5 +379,6 @@ M: #call optimize-node* { [ dup optimizer-hook ] [ optimize-hook ] } { [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } { [ t ] [ inline-method ] } } cond dup not ; diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor new file mode 100644 index 0000000000..2d52e6f45a --- /dev/null +++ b/core/optimizer/control/control-tests.factor @@ -0,0 +1,62 @@ +IN: temporary +USING: tools.test optimizer.control combinators kernel +sequences inference.dataflow math inference ; + +: label-is-loop? ( node word -- ? ) + [ + { + { [ over #label? not ] [ 2drop f ] } + { [ over #label-word over eq? not ] [ 2drop f ] } + { [ over #label-loop? not ] [ 2drop f ] } + { [ t ] [ 2drop t ] } + } cond + ] curry node-exists? ; + +: label-is-not-loop? ( node word -- ? ) + [ + { + { [ over #label? not ] [ 2drop f ] } + { [ over #label-word over eq? not ] [ 2drop f ] } + { [ over #label-loop? ] [ 2drop f ] } + { [ t ] [ 2drop t ] } + } cond + ] curry node-exists? ; + +: loop-test-1 ( a -- ) + dup [ 1+ loop-test-1 ] [ drop ] if ; inline + +[ t ] [ + [ loop-test-1 ] dataflow dup detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ loop-test-1 1 2 3 ] dataflow dup detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ [ loop-test-1 ] each ] dataflow dup detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ [ loop-test-1 ] each ] dataflow dup detect-loops + \ (each-integer) label-is-loop? +] unit-test + +: loop-test-2 ( a -- ) + dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline + +[ t ] [ + [ loop-test-2 ] dataflow dup detect-loops + \ loop-test-2 label-is-not-loop? +] unit-test + +: loop-test-3 ( a -- ) + dup [ [ loop-test-3 ] each ] [ drop ] if ; inline + +[ t ] [ + [ loop-test-3 ] dataflow dup detect-loops + \ loop-test-3 label-is-not-loop? +] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor new file mode 100644 index 0000000000..02df55216c --- /dev/null +++ b/core/optimizer/control/control.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel inference.dataflow combinators sequences +namespaces math ; +IN: optimizer.control + +GENERIC: detect-loops* ( node -- ) + +M: node detect-loops* drop ; + +M: #label detect-loops* t swap set-#label-loop? ; + +: not-a-loop ( #label -- ) + f swap set-#label-loop? ; + +: tail-call? ( -- ? ) + node-stack get + dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail + [ node-successor #tail? ] all? ; + +: detect-loop ( seen-other? label node -- seen-other? continue? ) + #! seen-other?: have we seen another label? + { + { [ dup #label? not ] [ 2drop t ] } + { [ 2dup node-param eq? not ] [ 3drop t t ] } + { [ tail-call? not ] [ not-a-loop drop f ] } + { [ pick ] [ not-a-loop drop f ] } + { [ t ] [ 2drop f ] } + } cond ; + +M: #call-label detect-loops* + f swap node-param node-stack get + [ detect-loop ] with all? 2drop ; + +: detect-loops ( node -- ) + [ detect-loops* ] each-node ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 1debf6c8cc..1ef10a926e 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math inference.class ; +optimizer.known-words optimizer.math optimizer.control +inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -11,6 +12,7 @@ IN: optimizer H{ } clone value-substitutions set dup compute-def-use kill-values + "detect-loops" get [ dup detect-loops ] when dup infer-classes optimizer-changed off optimize-nodes