working on partial evaluation

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"

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 ;

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? [
+        dup car %label?
-            f
+        [ f ] [ cdr (dead-code) t or ] ifte
-        ] [
+    ] [ f ] ifte ;
-            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
+    drop {
-    \ %return dup double-jump [
+        { [ \ %return dup double-jump ] [ t ] }
-        t
+        { [ \ %jump-label dup double-jump ] [ t ] }
-    ] [
+        { [ \ %jump dup double-jump ] [ t ] }
-        \ %jump-label dup double-jump [
+        { [ useless-jump ] [ t ] }
-            t
+        { [ t ] [ dead-code ] }
-        ] [
+    } cond ;
-            \ %jump dup double-jump
-            [
-                t
-            ] [
-                useless-jump [
-                    t
-                ] [
-                    dead-code
-                ] ifte
-            ] ifte
-        ] ifte
-    ] ifte ;
 
 M: %target-label simplify-node ( linear vop -- linear ? )
     drop

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 ;

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

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 ;
+    unit inline-literals ;
-
-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 ;
 
 M: #return optimize-node* ( node -- node/t )
     #! A #return followed by another node is a result of

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

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 ;
 

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, ;

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 ;
+: acosh dup sq 1 - sqrt + log ; stateless
-: asech recip acosh ;
+: asech recip acosh ; stateless
-: asinh dup sq 1 + sqrt + log ;
+: asinh dup sq 1 + sqrt + log ; stateless
-: acosech recip asinh ;
+: acosech recip asinh ; stateless
-: atanh dup 1 + swap 1 - neg / log 2 / ;
+: atanh dup 1 + swap 1 - neg / log 2 / ; stateless
-: acoth recip atanh ;
+: acoth recip atanh ; stateless
-: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ;
+: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; stateless
-: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ;
+: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; stateless
-: acos dup <=1 [ facos ] [ asin pi/2 swap - ] ifte ;
+: acos dup <=1 [ facos ] [ asin pi/2 swap - ] ifte ; stateless
-: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ;
+: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; stateless
-: asec recip acos ;
+: asec recip acos ; stateless
-: acosec recip asin ;
+: acosec recip asin ; stateless
-: acot recip atan ;
+: acot recip atan ; stateless

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.

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

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
+USING: interpreter io kernel lists namespaces prettyprint
-io strings test ;
+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