2005-05-15 21:17:56 -04:00
|
|
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2004-12-02 22:44:36 -05:00
|
|
|
IN: inference
|
2005-05-17 16:13:08 -04:00
|
|
|
USING: generic interpreter kernel lists namespaces parser
|
|
|
|
sequences vectors words ;
|
2005-05-15 21:17:56 -04:00
|
|
|
|
2005-08-07 00:00:57 -04:00
|
|
|
! Recursive state. An alist, mapping words to labels.
|
|
|
|
SYMBOL: recursive-state
|
|
|
|
|
|
|
|
TUPLE: value recursion uid ;
|
|
|
|
|
|
|
|
C: value ( -- value )
|
|
|
|
gensym over set-value-uid
|
|
|
|
recursive-state get over set-value-recursion ;
|
|
|
|
|
|
|
|
M: value = eq? ;
|
|
|
|
|
|
|
|
TUPLE: computed ;
|
|
|
|
|
|
|
|
C: computed ( -- value ) <value> over set-delegate ;
|
|
|
|
|
|
|
|
TUPLE: literal value ;
|
|
|
|
|
|
|
|
C: literal ( obj -- value )
|
|
|
|
<value> over set-delegate
|
|
|
|
[ set-literal-value ] keep ;
|
|
|
|
|
|
|
|
TUPLE: meet values ;
|
|
|
|
|
|
|
|
C: meet ( values -- value )
|
|
|
|
<value> over set-delegate [ set-meet-values ] keep ;
|
|
|
|
|
|
|
|
: value-refers? ( referee referrer -- ? )
|
|
|
|
2dup eq? [
|
|
|
|
2drop t
|
|
|
|
] [
|
|
|
|
dup meet? [
|
|
|
|
meet-values [ value-refers? ] contains-with?
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte
|
|
|
|
] ifte ;
|
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
! The dataflow IR is the first of the two intermediate
|
|
|
|
! representations used by Factor. It annotates concatenative
|
|
|
|
! code with stack flow information and types.
|
|
|
|
|
2005-09-04 19:24:24 -04:00
|
|
|
TUPLE: node param shuffle
|
2005-08-11 19:08:22 -04:00
|
|
|
classes literals history
|
|
|
|
successor children ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-07-28 15:17:31 -04:00
|
|
|
M: node = eq? ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-07-28 15:17:31 -04:00
|
|
|
: make-node ( param in-d out-d in-r out-r node -- node )
|
2005-08-11 19:08:22 -04:00
|
|
|
[
|
2005-09-04 19:24:24 -04:00
|
|
|
>r
|
|
|
|
swapd <shuffle> {{ }} clone {{ }} clone { } clone f f <node>
|
|
|
|
r>
|
2005-08-25 15:27:38 -04:00
|
|
|
set-delegate
|
2005-08-11 19:08:22 -04:00
|
|
|
] keep ;
|
2005-07-28 15:17:31 -04:00
|
|
|
|
2005-09-04 19:24:24 -04:00
|
|
|
: node-in-d node-shuffle shuffle-in-d ;
|
|
|
|
: node-in-r node-shuffle shuffle-in-r ;
|
|
|
|
: node-out-d node-shuffle shuffle-out-d ;
|
|
|
|
: node-out-r node-shuffle shuffle-out-r ;
|
|
|
|
|
|
|
|
: set-node-in-d node-shuffle set-shuffle-in-d ;
|
|
|
|
: set-node-in-r node-shuffle set-shuffle-in-r ;
|
|
|
|
: set-node-out-d node-shuffle set-shuffle-out-d ;
|
|
|
|
: set-node-out-r node-shuffle set-shuffle-out-r ;
|
|
|
|
|
2005-09-04 17:07:59 -04:00
|
|
|
: empty-node f { } { } { } { } ;
|
2005-08-06 02:44:25 -04:00
|
|
|
: param-node ( label) { } { } { } { } ;
|
|
|
|
: in-d-node ( inputs) >r f r> { } { } { } ;
|
|
|
|
: out-d-node ( outputs) >r f { } r> { } { } ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-09-04 19:24:24 -04:00
|
|
|
: d-tail ( n -- list ) meta-d get tail* ;
|
|
|
|
: r-tail ( n -- list ) meta-r get tail* ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-09-04 01:09:46 -04:00
|
|
|
: node-child node-children first ;
|
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #label ;
|
|
|
|
C: #label make-node ;
|
2005-05-17 16:13:08 -04:00
|
|
|
: #label ( label -- node ) param-node <#label> ;
|
|
|
|
|
2005-08-04 17:39:39 -04:00
|
|
|
TUPLE: #entry ;
|
|
|
|
C: #entry make-node ;
|
|
|
|
: #entry ( -- node ) meta-d get clone in-d-node <#entry> ;
|
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #call ;
|
|
|
|
C: #call make-node ;
|
2005-05-17 16:13:08 -04:00
|
|
|
: #call ( word -- node ) param-node <#call> ;
|
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #call-label ;
|
|
|
|
C: #call-label make-node ;
|
2005-06-08 04:49:05 -04:00
|
|
|
: #call-label ( label -- node ) param-node <#call-label> ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #push ;
|
|
|
|
C: #push make-node ;
|
2005-05-17 16:13:08 -04:00
|
|
|
: #push ( outputs -- node ) d-tail out-d-node <#push> ;
|
|
|
|
|
2005-09-04 17:07:59 -04:00
|
|
|
TUPLE: #shuffle ;
|
|
|
|
C: #shuffle make-node ;
|
|
|
|
: #shuffle ( -- node ) empty-node <#shuffle> ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #values ;
|
|
|
|
C: #values make-node ;
|
2005-08-06 02:44:25 -04:00
|
|
|
: #values ( -- node ) meta-d get clone in-d-node <#values> ;
|
2004-11-27 00:33:17 -05:00
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #return ;
|
|
|
|
C: #return make-node ;
|
2005-08-06 02:44:25 -04:00
|
|
|
: #return ( -- node ) meta-d get clone in-d-node <#return> ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #ifte ;
|
|
|
|
C: #ifte make-node ;
|
2005-05-17 16:13:08 -04:00
|
|
|
: #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
|
|
|
|
|
2005-06-12 03:38:57 -04:00
|
|
|
TUPLE: #dispatch ;
|
|
|
|
C: #dispatch make-node ;
|
2005-05-17 16:13:08 -04:00
|
|
|
: #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
|
|
|
|
|
2005-07-27 01:46:06 -04:00
|
|
|
TUPLE: #merge ;
|
|
|
|
C: #merge make-node ;
|
2005-08-11 19:08:22 -04:00
|
|
|
: #merge ( -- node ) meta-d get clone out-d-node <#merge> ;
|
2005-07-27 01:46:06 -04:00
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
: node-inputs ( d-count r-count node -- )
|
|
|
|
tuck
|
|
|
|
>r r-tail r> set-node-in-r
|
|
|
|
>r d-tail r> set-node-in-d ;
|
|
|
|
|
|
|
|
: node-outputs ( d-count r-count node -- )
|
|
|
|
tuck
|
|
|
|
>r r-tail r> set-node-out-r
|
|
|
|
>r d-tail r> set-node-out-d ;
|
|
|
|
|
|
|
|
! Variable holding dataflow graph being built.
|
2004-11-27 00:33:17 -05:00
|
|
|
SYMBOL: dataflow-graph
|
2005-05-17 16:13:08 -04:00
|
|
|
! The most recently added node.
|
|
|
|
SYMBOL: current-node
|
2004-11-27 00:33:17 -05:00
|
|
|
|
2005-05-17 16:13:08 -04:00
|
|
|
: node, ( node -- )
|
|
|
|
dataflow-graph get [
|
|
|
|
dup current-node [ set-node-successor ] change
|
2004-12-02 22:44:36 -05:00
|
|
|
] [
|
2005-05-17 16:13:08 -04:00
|
|
|
! first node
|
|
|
|
dup dataflow-graph set current-node set
|
2004-12-02 22:44:36 -05:00
|
|
|
] ifte ;
|
2005-05-17 16:13:08 -04:00
|
|
|
|
|
|
|
: nest-node ( -- dataflow current )
|
|
|
|
dataflow-graph get dataflow-graph off
|
|
|
|
current-node get current-node off ;
|
|
|
|
|
|
|
|
: unnest-node ( new-node dataflow current -- new-node )
|
2005-08-06 02:44:25 -04:00
|
|
|
>r >r dataflow-graph get 1vector over set-node-children
|
2005-05-17 16:13:08 -04:00
|
|
|
r> dataflow-graph set
|
|
|
|
r> current-node set ;
|
|
|
|
|
|
|
|
: with-nesting ( quot -- new-node | quot: -- new-node )
|
|
|
|
nest-node 2slip unnest-node ; inline
|
|
|
|
|
2005-05-20 23:52:31 -04:00
|
|
|
: node-effect ( node -- [[ d-in meta-d ]] )
|
|
|
|
dup node-in-d swap node-out-d cons ;
|
|
|
|
|
2005-07-28 15:17:31 -04:00
|
|
|
: node-values ( node -- values )
|
|
|
|
[
|
|
|
|
dup node-in-d % dup node-out-d %
|
|
|
|
dup node-in-r % node-out-r %
|
2005-08-25 15:27:38 -04:00
|
|
|
] { } make ;
|
2005-05-22 02:35:38 -04:00
|
|
|
|
2005-08-07 00:00:57 -04:00
|
|
|
: uses-value? ( value node -- ? )
|
|
|
|
node-values [ value-refers? ] contains-with? ;
|
2005-05-22 02:35:38 -04:00
|
|
|
|
2005-09-04 17:07:59 -04:00
|
|
|
: outputs-value? ( value node -- ? )
|
|
|
|
2dup node-out-d member? >r node-out-r member? r> or ;
|
|
|
|
|
2005-05-22 02:35:38 -04:00
|
|
|
: last-node ( node -- last )
|
|
|
|
dup node-successor [ last-node ] [ ] ?ifte ;
|
|
|
|
|
2005-08-29 21:00:39 -04:00
|
|
|
: penultimate-node ( node -- penultimate )
|
|
|
|
dup node-successor dup [
|
|
|
|
dup node-successor
|
|
|
|
[ nip penultimate-node ] [ drop ] ifte
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte ;
|
|
|
|
|
2005-09-04 17:07:59 -04:00
|
|
|
: drop-inputs ( node -- #shuffle )
|
|
|
|
node-in-d clone in-d-node <#shuffle> ;
|
|
|
|
|
|
|
|
: #drop ( n -- #shuffle )
|
|
|
|
d-tail in-d-node <#shuffle> ;
|
2005-08-02 00:25:05 -04:00
|
|
|
|
2005-08-29 21:00:39 -04:00
|
|
|
: each-node ( node quot -- | quot: node -- )
|
2005-08-04 17:39:39 -04:00
|
|
|
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
|
2005-08-07 00:00:57 -04:00
|
|
|
|
2005-08-29 21:00:39 -04:00
|
|
|
: all-nodes? ( node quot -- ? | quot: node -- ? )
|
|
|
|
over [
|
|
|
|
[ call ] 2keep rot [
|
|
|
|
[
|
|
|
|
swap node-children [ swap all-nodes? ] all-with?
|
|
|
|
] 2keep rot [
|
|
|
|
>r node-successor r> all-nodes?
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
2drop t
|
|
|
|
] ifte ; inline
|
|
|
|
|
|
|
|
: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
|
|
|
|
swap [ with rot ] all-nodes? 2nip ; inline
|
|
|
|
|
2005-08-07 00:00:57 -04:00
|
|
|
SYMBOL: substituted
|
|
|
|
|
|
|
|
DEFER: subst-value
|
|
|
|
|
|
|
|
: subst-meet ( new old meet -- )
|
|
|
|
#! We avoid mutating the same meet more than once, since
|
|
|
|
#! doing so can introduce cycles.
|
|
|
|
dup substituted get memq? [
|
|
|
|
3drop
|
|
|
|
] [
|
|
|
|
dup substituted get push meet-values subst-value
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: (subst-value) ( new old value -- value )
|
|
|
|
2dup eq? [
|
|
|
|
2drop
|
|
|
|
] [
|
|
|
|
dup meet? [
|
2005-08-08 02:38:10 -04:00
|
|
|
pick over swap value-refers? [
|
2005-08-07 00:00:57 -04:00
|
|
|
2nip ! don't substitute a meet into itself
|
|
|
|
] [
|
|
|
|
[ subst-meet ] keep
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
2nip
|
|
|
|
] ifte
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: subst-value ( new old seq -- )
|
|
|
|
pick pick eq? over empty? or [
|
|
|
|
3drop
|
|
|
|
] [
|
|
|
|
[ >r 2dup r> (subst-value) ] nmap 2drop
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: (subst-values) ( newseq oldseq seq -- )
|
|
|
|
#! Mutates seq.
|
|
|
|
-rot [ pick subst-value ] 2each drop ;
|
|
|
|
|
|
|
|
: subst-values ( new old node -- )
|
|
|
|
#! Mutates the node.
|
|
|
|
[
|
2005-08-25 15:27:38 -04:00
|
|
|
{ } clone substituted set [
|
2005-08-07 00:00:57 -04:00
|
|
|
3dup node-in-d (subst-values)
|
|
|
|
3dup node-in-r (subst-values)
|
|
|
|
3dup node-out-d (subst-values)
|
|
|
|
3dup node-out-r (subst-values)
|
|
|
|
drop
|
|
|
|
] each-node 2drop
|
|
|
|
] with-scope ;
|
2005-08-11 19:08:22 -04:00
|
|
|
|
|
|
|
: remember-node ( word node -- )
|
|
|
|
#! Annotate each node with the fact it was inlined from
|
|
|
|
#! 'word'.
|
|
|
|
[
|
|
|
|
dup #call? [ node-history push ] [ 2drop ] ifte
|
|
|
|
] each-node-with ;
|
|
|
|
|
2005-08-13 04:01:21 -04:00
|
|
|
: (clone-node) ( node -- node )
|
2005-09-04 19:24:24 -04:00
|
|
|
clone dup node-shuffle clone over set-node-shuffle ;
|
2005-08-13 04:01:21 -04:00
|
|
|
|
2005-08-11 19:08:22 -04:00
|
|
|
: clone-node ( node -- node )
|
|
|
|
dup [
|
2005-08-13 04:01:21 -04:00
|
|
|
(clone-node)
|
2005-08-11 19:08:22 -04:00
|
|
|
dup node-children [ clone-node ] map over set-node-children
|
|
|
|
dup node-successor clone-node over set-node-successor
|
|
|
|
] when ;
|
2005-09-04 01:09:46 -04:00
|
|
|
|
|
|
|
GENERIC: calls-label* ( label node -- ? )
|
|
|
|
|
|
|
|
M: node calls-label* 2drop f ;
|
|
|
|
|
|
|
|
M: #call-label calls-label* node-param eq? ;
|
|
|
|
|
|
|
|
: calls-label? ( label node -- ? )
|
|
|
|
[ calls-label* not ] all-nodes-with? not ;
|
|
|
|
|
|
|
|
: recursive-label? ( node -- ? )
|
|
|
|
dup node-param swap calls-label? ;
|