diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index df05155ba2..1d3ebda4aa 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -56,6 +56,8 @@ + compiler: +- changing a word to be 'inline' after it was already defined doesn't + work properly - inference needs to be more robust with heavily recursive code - powerpc: float ffi parameters - fix fixnum<< and /i overflow on PowerPC diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 0a4afea1db..2d04747589 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -151,3 +151,13 @@ M: alien-node linearize-node* ( node -- ) global [ "libraries" get [ "libraries" set ] unless ] bind + +M: compound (uncrossref) + dup word-def \ alien-invoke swap member? [ + drop + ] [ + dup f "infer-effect" set-word-prop + dup f "base-case" set-word-prop + dup f "no-effect" set-word-prop + decompile + ] ifte ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 70c6a8ddd4..cc34de9ae7 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. IN: compiler USING: compiler-backend compiler-frontend errors inference -kernel lists math namespaces prettyprint io words ; +io kernel lists math namespaces prettyprint words ; : supported-cpu? ( -- ? ) cpu "unknown" = not ; @@ -58,11 +58,5 @@ M: compound (compile) ( word -- ) drop ] ifte ; -M: compound (uncrossref) - dup f "infer-effect" set-word-prop - dup f "base-case" set-word-prop - dup f "no-effect" set-word-prop - decompile ; - : recompile ( word -- ) dup decompile compile ; diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 508d2a90f5..09160ad20a 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -6,8 +6,11 @@ kernel-internals math namespaces prettyprint sequences strings words ; GENERIC: linearize-node* ( node -- ) + M: f linearize-node* ( f -- ) drop ; +M: node linearize-node* ( node -- ) drop ; + : linearize-node ( node -- ) [ dup linearize-node* node-successor linearize-node @@ -101,11 +104,5 @@ M: #dispatch linearize-node* ( vtable -- ) #! take in case the top of stack has that type. node-children dispatch-head dupd dispatch-body %label , ; -M: #values linearize-node* ( node -- ) - drop ; - -M: #merge linearize-node* ( node -- ) - drop ; - M: #return linearize-node* ( node -- ) drop f %return , ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 67e509949e..1c585a6034 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -10,7 +10,18 @@ namespaces prettyprint sequences strings vectors words ; dup max-length swap [ [ required-inputs ] keep append ] map-with ; -: unify-results ( seq -- value ) +: flatten-values ( seq -- seq ) + [ + [ + dup meet? [ + meet-values [ unique, ] each + ] [ + unique, + ] ifte + ] each + ] make-vector ; + +: unify-values ( seq -- value ) #! If all values in list are equal, return the value. #! Otherwise, unify. dup [ eq? ] every? [ first ] [ ] ifte ; @@ -18,7 +29,7 @@ namespaces prettyprint sequences strings vectors words ; : unify-stacks ( seq -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths flip [ unify-results ] map ; + unify-lengths flip [ flatten-values unify-values ] map ; : balanced? ( in out -- ? ) [ swap length swap length - ] 2map [ = ] every? ; diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index c7938c76b7..efc18a35b2 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -31,6 +31,14 @@ TUPLE: #simple-label ; C: #simple-label make-node ; : #simple-label ( label -- node ) param-node <#simple-label> ; +TUPLE: #entry ; +C: #entry make-node ; +: #entry ( -- node ) meta-d get clone in-d-node <#entry> ; + +TUPLE: #split ; +C: #split make-node ; +: #split ( stack -- node ) in-d-node <#split> ; + TUPLE: #call ; C: #call make-node ; : #call ( word -- node ) param-node <#call> ; @@ -124,7 +132,8 @@ SYMBOL: current-node : penultimate-node ( node -- penultimate ) dup node-successor dup [ - dup node-successor [ nip penultimate-node ] [ drop ] ifte + dup node-successor + [ nip penultimate-node ] [ drop ] ifte ] [ 2drop f ] ifte ; @@ -134,3 +143,15 @@ SYMBOL: current-node ! Recursive state. An alist, mapping words to labels. SYMBOL: recursive-state + +: each-node ( node quot -- ) + over [ + [ call ] 2keep swap + [ node-children [ swap each-node ] each-with ] 2keep + node-successor swap each-node + ] [ + 2drop + ] ifte ; inline + +: each-node-with ( obj node quot -- | quot: obj node -- ) + swap [ with ] each-node 2drop ; inline diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index b4ad62acf1..0ac27fc697 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: # generic hashtables inference kernel lists +USING: generic hashtables inference kernel lists matrices namespaces sequences vectors ; ! We use the recursive-state variable here, to track nested @@ -10,11 +10,8 @@ matrices namespaces sequences vectors ; GENERIC: literals* ( node -- ) -: literals, ( node -- ) - [ dup literals* node-successor literals, ] when* ; - -: literals ( node -- list ) - [ literals, ] make-list ; +: literals ( node -- seq ) + [ [ literals* ] each-node ] make-vector ; GENERIC: can-kill* ( literal node -- ? ) @@ -32,7 +29,7 @@ GENERIC: can-kill* ( literal node -- ? ) #! Push a list of literals that may be killed in the IR. dup literals [ swap can-kill? ] subset-with ; -: remove-value ( value node -- ) +: remove-values ( values node -- ) 2dup [ node-in-d seq-diff ] keep set-node-in-d 2dup [ node-out-d seq-diff ] keep set-node-out-d 2dup [ node-in-r seq-diff ] keep set-node-in-r @@ -42,20 +39,8 @@ GENERIC: kill-node* ( literals node -- ) M: node kill-node* ( literals node -- ) 2drop ; -DEFER: kill-node - -: kill-children ( literals node -- ) - node-children [ kill-node ] each-with ; - : kill-node ( literals node -- ) - dup [ - 2dup kill-children - 2dup kill-node* - 2dup remove-value - node-successor kill-node - ] [ - 2drop - ] ifte ; + [ 2dup kill-node* remove-values ] each-node-with ; GENERIC: optimize-node* ( node -- node ) @@ -68,11 +53,6 @@ M: node optimize-children ( node -- ) node-children [ optimize-node swap >r or r> ] map ] keep set-node-children ; -: optimize-label ( node -- node ) - dup node-param recursive-state [ cons ] change - delegate optimize-children - recursive-state [ cdr ] change ; - : keep-optimizing ( node -- node ? ) dup optimize-node* dup t = [ drop f ] [ nip keep-optimizing t or ] ifte ; @@ -100,17 +80,9 @@ M: node optimize-children ( node -- ) inline ! Generic nodes -M: node literals* ( node -- ) - node-children [ literals, ] each ; +M: node literals* ( node -- ) drop ; -M: f can-kill* ( literal node -- ? ) - 2drop t ; - -M: node can-kill* ( literal node -- ? ) - uses-value? not ; - -M: node kill-node* ( literals node -- ) - 2drop ; +M: node can-kill* ( literal node -- ? ) uses-value? not ; M: f optimize-node* drop t ; @@ -198,6 +170,11 @@ M: #label can-kill* ( literal node -- ? ) M: #simple-label can-kill* ( literal node -- ? ) node-children first can-kill? ; +: optimize-label ( node -- node ) + dup node-param recursive-state [ cons ] change + delegate optimize-children + recursive-state [ cdr ] change ; + M: #label optimize-children optimize-label ; M: #simple-label optimize-children optimize-label ; diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor index 731f62ab94..3859a68333 100644 --- a/library/inference/print-dataflow.factor +++ b/library/inference/print-dataflow.factor @@ -41,13 +41,12 @@ M: #drop node>quot ( ? node -- ) DEFER: dataflow>quot -M: #call node>quot ( ? node -- ) +: #call>quot ( ? node -- ) dup node-param , dup effect-str comment, ; -M: #call-label node>quot ( ? node -- ) - #! Even if the flag is off, we still output the annotation. - >r drop t r> - "#call-label: " over node-param word-name append comment, ; +M: #call node>quot ( ? node -- ) #call>quot ; + +M: #call-label node>quot ( ? node -- ) #call>quot ; M: #label node>quot ( ? node -- ) [ "#label: " over node-param word-name append comment, ] 2keep @@ -70,6 +69,10 @@ M: #values node>quot ( ? node -- ) "#values" comment, ; M: #merge node>quot ( ? node -- ) "#merge" comment, ; +M: #entry node>quot ( ? node -- ) "#entry" comment, ; + +M: #split node>quot ( ? node -- ) "#split" comment, ; + : (dataflow>quot) ( ? node -- ) dup [ 2dup node>quot node-successor (dataflow>quot) diff --git a/library/inference/recursive-values.factor b/library/inference/recursive-values.factor new file mode 100644 index 0000000000..1d27c2d888 --- /dev/null +++ b/library/inference/recursive-values.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: inference +USING: kernel namespaces prettyprint sequences vectors ; + +! Technical detail: need to figure out which values survive +! inner recursions in #labels. + +GENERIC: collect-recursion* ( label node -- ) + +M: node collect-recursion* ( label node -- ) 2drop ; + +M: #call-label collect-recursion* ( label node -- ) + tuck node-param = [ node-in-d , ] [ drop ] ifte ; + +: collect-recursion ( label node -- seq ) + #! Collect the input stacks of all #call-label nodes that + #! call given label. + [ [ collect-recursion* ] each-node-with ] make-vector ; + +: first-child ( child node -- ) + [ node-children first over set-node-successor 1vector ] keep + set-node-children ; + +M: #label optimize-node* ( node -- node/t ) + dup dup node-param over collect-recursion >r + node-children first node-in-d r> swap add + unify-stacks #split swap first-child t ; + +M: #split optimize-node* ( node -- node/t ) + node-successor ; diff --git a/library/inference/words.factor b/library/inference/words.factor index e781ce3366..23d5a2e0c9 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -39,7 +39,7 @@ hashtables parser prettyprint ; : inline-block ( word -- node-block ) gensym over word-def cons [ - inhibit-parital word-def infer-quot + #entry node, inhibit-parital word-def infer-quot ] with-block ; : inline-compound ( word -- ) @@ -99,8 +99,10 @@ M: symbol apply-object ( word -- ) : (base-case) ( word label -- ) over "inline" word-prop [ + meta-d get clone >r over inline-block drop - [ #call-label ] [ #call ] ?ifte node, + [ #call-label ] [ #call ] ?ifte + r> over set-node-in-d node, ] [ drop dup t infer-compound "base-case" set-word-prop ] ifte ;