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

starting recursive value inference; add hack to (uncrossref) so that it does not decompile alien words

cvs
Slava Pestov 2005-08-04 21:39:39 +00:00
parent 13df2fe3e8
commit 9bc39d1421
10 changed files with 106 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -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

10
library/alien/compiler.factor
View File

@ -151,3 +151,13 @@ M: alien-node linearize-node* ( node -- )
global [
"libraries" get [ <namespace> "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 ;

8
library/compiler/compiler.factor
View File

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

9
library/compiler/linearizer.factor
View File

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

15
library/inference/branches.factor
View File

@ -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 ] [ <meet> ] 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? ;

23
library/inference/dataflow.factor
View File

@ -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

47
library/inference/optimizer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: #<unknown> 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 ;

13
library/inference/print-dataflow.factor
View File

@ -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)

31
library/inference/recursive-values.factor Normal file
View File

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

6
library/inference/words.factor
View File

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