diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 2608aab543..e723de8e65 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -89,8 +89,9 @@ parser prettyprint sequences io vectors words ; "/library/inference/kill-literals.factor" "/library/inference/optimizer.factor" "/library/inference/inline-methods.factor" - "/library/inference/print-dataflow.factor" "/library/inference/known-words.factor" + "/library/inference/call-optimizers.factor" + "/library/inference/print-dataflow.factor" "/library/compiler/assembler.factor" "/library/compiler/relocate.factor" diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 28fb32170d..782934d4ba 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: sequences USING: generic kernel kernel-internals lists math strings -vectors ; +vectors words ; ! Combinators M: object each ( seq quot -- ) @@ -225,3 +225,14 @@ IN: kernel : depth ( -- n ) #! Push the number of elements on the datastack. datastack length ; + +: cond ( conditions -- ) + #! Conditions is a sequence of quotation pairs. + #! { { [ X ] [ Y ] } { [ Z ] [ T ] } + #! => X [ Y ] [ Z [ T ] [ ] ifte ] ifte + #! The last condition should be a catch-all 't'. + [ first call ] find nip second call ; + +: with-datastack ( stack word -- stack ) + datastack >r >r set-datastack r> execute + datastack r> [ push ] keep set-datastack 2nip ; diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index fa00f69942..852d086020 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -221,9 +221,7 @@ M: %call-label simplify-node ( linear vop -- ? ) pick next-logical? [ >r dup dup car next-logical car vop-label r> execute swap cdr cons t - ] [ - drop f - ] ifte ; inline + ] [ drop f ] ifte ; inline : useless-jump ( linear -- linear ? ) #! A jump to a label immediately following is not needed. @@ -233,38 +231,21 @@ M: %call-label simplify-node ( linear vop -- ? ) : (dead-code) ( linear -- linear ? ) #! Remove all nodes until the next #label. dup [ - dup car %label? [ - f - ] [ - cdr (dead-code) t or - ] ifte - ] [ - f - ] ifte ; + dup car %label? + [ f ] [ cdr (dead-code) t or ] ifte + ] [ f ] ifte ; : dead-code ( linear -- linear ? ) uncons (dead-code) >r cons r> ; M: %jump-label simplify-node ( linear vop -- linear ? ) - drop - \ %return dup double-jump [ - t - ] [ - \ %jump-label dup double-jump [ - t - ] [ - \ %jump dup double-jump - [ - t - ] [ - useless-jump [ - t - ] [ - dead-code - ] ifte - ] ifte - ] ifte - ] ifte ; + drop { + { [ \ %return dup double-jump ] [ t ] } + { [ \ %jump-label dup double-jump ] [ t ] } + { [ \ %jump dup double-jump ] [ t ] } + { [ useless-jump ] [ t ] } + { [ t ] [ dead-code ] } + } cond ; M: %target-label simplify-node ( linear vop -- linear ? ) drop diff --git a/library/inference/call-optimizers.factor b/library/inference/call-optimizers.factor new file mode 100644 index 0000000000..2fb24c27dd --- /dev/null +++ b/library/inference/call-optimizers.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: inference +USING: errors generic hashtables inference kernel +kernel-internals lists math math-internals strings vectors words ; + +! A system for associating dataflow optimizers with words. + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimize-hooks ( node -- node/t ) + dup optimizer-hooks cond ; + +: define-optimizers ( word optimizers -- ) + { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ; + +: partial-eval? ( #call -- ? ) + dup node-param "stateless" word-prop [ + dup node-in-d [ + dup literal? + [ 2drop t ] [ swap node-literals hash* ] ifte + ] all-with? + ] [ + drop f + ] ifte ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ + dup literal? + [ nip literal-value ] [ swap node-literals hash ] ifte + ] map-with ; + +: partial-eval ( #call -- node ) + dup literal-in-d over node-param + [ with-datastack ] [ + [ + 2drop t + ] [ + inline-literals + ] ifte + ] catch ; + +M: #call optimize-node* ( node -- node/t ) + { + { [ dup node-param not ] [ node-successor ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup optimizer-hooks ] [ optimize-hooks ] } + { [ dup inlining-class ] [ inline-method ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ t ] [ drop t ] } + } cond ; diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index eed9b4357a..11a431a564 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -175,6 +175,21 @@ SYMBOL: current-node : drop-inputs ( node -- #drop ) node-in-d clone in-d-node <#drop> ; +: post-inline ( #return #call -- node ) + [ >r node-in-d r> node-out-d ] keep + node-successor [ subst-values ] keep ; + +: subst-literals ( successor literals -- #push ) + #! Make #push -> #return -> successor + [ literalize ] map dataflow + dup last-node rot post-inline swap + [ set-node-successor ] keep ; + +: inline-literals ( node literals -- node ) + #! See the #return optimizer. + over drop-inputs + [ >r subst-literals r> set-node-successor ] keep ; + : each-node ( node quot -- ) over [ [ call ] 2keep swap diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index 4e2d55ea03..0e2bf8a693 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -59,7 +59,8 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; [ set-node-successor drop ] keep ] ifte ; -: inline-method ( node class -- node ) +: inline-method ( node -- node ) + dup inlining-class over node-param "methods" word-prop hash over node-in-d dataflow-with dup solve-recursion >r [ node-param ] keep r> subst-node ; @@ -76,42 +77,10 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; 2drop f ] ifte ; -: subst-literal ( successor literal -- #push ) - #! Make #push -> #return -> successor - literalize unit dataflow - [ last-node set-node-successor ] keep ; - -: inline-literal ( node literal -- node ) - over drop-inputs - [ >r subst-literal r> set-node-successor ] keep ; - : optimize-predicate ( #call -- node ) dup node-param "predicating" word-prop >r dup dup node-in-d node-classes* first r> class< - inline-literal ; - -M: #call optimize-node* ( node -- node/t ) - dup node-param [ - dup inlining-class dup [ - inline-method - ] [ - drop dup optimize-predicate? [ - optimize-predicate - ] [ - dup optimize-not? [ - node-successor dup flip-branches - ] [ - drop t - ] ifte - ] ifte - ] ifte - ] [ - node-successor - ] ifte ; - -: post-inline ( #return #call -- node ) - [ >r node-in-d r> node-out-d ] keep - node-successor [ subst-values ] keep ; + unit inline-literals ; M: #return optimize-node* ( node -- node/t ) #! A #return followed by another node is a result of diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index 8c17c96f2b..0cfd5003fa 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -44,6 +44,17 @@ math math-internals parser sequences vectors words ; \ over [ \ over infer-shuffle ] "infer" set-word-prop \ pick [ \ pick infer-shuffle ] "infer" set-word-prop +! Flipping branches +\ not { + { [ dup node-successor #ifte? ] [ node-successor dup flip-branches ] } +} define-optimizers + +! Partial evaluation. Most stateless words are colon defs, and +! so are marked as 'stateless'. However primitives are set here. +{ + eq? +} [ t "stateless" set-word-prop ] each + ! These hacks will go away soon \ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop \ no-method t "terminator" set-word-prop diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index 1aaaa86064..c549afad80 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -60,10 +60,6 @@ M: #drop optimize-node* ( node -- node/t ) [ node-in-d empty? ] prune-if ; ! #call -: optimize-not? ( #call -- ? ) - dup node-param \ not = - [ node-successor #ifte? ] [ drop f ] ifte ; - : flip-branches ( #ifte -- ) dup node-children 2unseq swap 2vector swap set-node-children ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 4c570ac3b0..fe8d9c6fce 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -143,15 +143,8 @@ M: compound apply-object ( word -- ) ] ifte ] ifte* ; -: with-datastack ( stack word -- stack ) - datastack >r >r set-datastack r> execute - datastack r> [ push ] keep set-datastack 2nip ; - -: apply-datastack ( word -- ) - meta-d [ swap with-datastack ] change ; - : infer-shuffle ( word -- ) dup #call [ over "infer-effect" word-prop - [ apply-datastack ] hairy-node + [ meta-d [ swap with-datastack ] change ] hairy-node ] keep node, ; diff --git a/library/math/arc-trig-hyp.factor b/library/math/arc-trig-hyp.factor index 3467a7d8d1..f983320d8c 100644 --- a/library/math/arc-trig-hyp.factor +++ b/library/math/arc-trig-hyp.factor @@ -9,16 +9,16 @@ USING: kernel math math-internals ; ! Inverse hyperbolic functions: ! acosh asech asinh acosech atanh acoth -: acosh dup sq 1 - sqrt + log ; -: asech recip acosh ; -: asinh dup sq 1 + sqrt + log ; -: acosech recip asinh ; -: atanh dup 1 + swap 1 - neg / log 2 / ; -: acoth recip atanh ; -: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; -: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; -: acos dup <=1 [ facos ] [ asin pi/2 swap - ] ifte ; -: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; -: asec recip acos ; -: acosec recip asin ; -: acot recip atan ; +: acosh dup sq 1 - sqrt + log ; stateless +: asech recip acosh ; stateless +: asinh dup sq 1 + sqrt + log ; stateless +: acosech recip asinh ; stateless +: atanh dup 1 + swap 1 - neg / log 2 / ; stateless +: acoth recip atanh ; stateless +: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; stateless +: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; stateless +: acos dup <=1 [ facos ] [ asin pi/2 swap - ] ifte ; stateless +: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; stateless +: asec recip acos ; stateless +: acosec recip asin ; stateless +: acot recip atan ; stateless diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 388130691e..295fa24cb3 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -17,6 +17,11 @@ words ; #! Mark the last word to be inlined. word t "inline" set-word-prop ; parsing +: stateless ( -- ) + #! Mark the last word to be evaluated at compile time if + #! all inputs are literals. + word t "stateless" set-word-prop ; parsing + ! The variable "in-definition" is set inside a : ... ;. ! ( and #! then add "stack-effect" and "documentation" ! properties to the current word if it is set. diff --git a/library/test/combinators.factor b/library/test/combinators.factor index 4ed848bd37..1f2310cd46 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -1,4 +1,5 @@ IN: temporary +USING: alien strings ; USE: kernel USE: math USE: test @@ -33,3 +34,26 @@ USE: namespaces [ [ 9 8 7 6 5 4 3 2 1 ] ] [ [ 10 [ , ] [ 1 - dup dup 0 = [ drop f ] when ] while ] make-list nip ] unit-test + +[ "even" ] [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond +] unit-test + +[ "odd" ] [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond +] unit-test + +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond +] unit-test diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor index 5ff9e133a3..9484bee494 100644 --- a/library/tools/annotations.factor +++ b/library/tools/annotations.factor @@ -6,16 +6,21 @@ IN: words ! or single-stepping. Note that currently, words referring to ! annotated words cannot be compiled; and annotating a word has ! no effect of compiled calls to that word. -USING: interpreter kernel lists prettyprint sequences -io strings test ; +USING: interpreter io kernel lists namespaces prettyprint +sequences strings test ; : annotate ( word quot -- | quot: word def -- def ) over >r >r dup word-def r> call r> swap (define-compound) ; inline : (watch) ( word def -- def ) - >r "==> " swap word-name append \ print \ .s r> - cons cons cons ; + [ + "===> Entering: " pick word-name append , \ print , + \ .s , + % + "===> Leaving: " swap word-name append , \ print , + \ .s , + ] make-list ; : watch ( word -- ) #! Cause a message to be printed out when the word is