2005-07-27 01:46:06 -04:00
|
|
|
IN: inference
|
2005-07-28 15:17:31 -04:00
|
|
|
USING: generic hashtables inference io kernel kernel-internals
|
|
|
|
math namespaces prettyprint sequences vectors words ;
|
2005-07-27 01:46:06 -04:00
|
|
|
|
|
|
|
! A simple tool for turning dataflow IR into quotations, for
|
|
|
|
! debugging purposes.
|
|
|
|
|
|
|
|
GENERIC: node>quot ( node -- )
|
|
|
|
|
|
|
|
TUPLE: annotation node text ;
|
|
|
|
|
|
|
|
M: annotation prettyprint* ( ann -- )
|
|
|
|
"( " over annotation-text " )" append3
|
|
|
|
swap annotation-node object. ;
|
|
|
|
|
2005-07-28 15:17:31 -04:00
|
|
|
: value-str ( classes values -- str )
|
2005-07-28 18:20:31 -04:00
|
|
|
[ swap ?hash [ object ] unless* ] map-with
|
2005-07-28 15:17:31 -04:00
|
|
|
[ word-name ] map
|
|
|
|
" " join ;
|
2005-07-27 01:46:06 -04:00
|
|
|
|
|
|
|
: effect-str ( node -- str )
|
|
|
|
[
|
2005-07-28 15:17:31 -04:00
|
|
|
dup node-classes swap
|
|
|
|
2dup node-in-d value-str %
|
|
|
|
"--" %
|
2005-07-27 01:46:06 -04:00
|
|
|
node-out-d value-str %
|
|
|
|
] make-string ;
|
|
|
|
|
|
|
|
M: #push node>quot ( node -- )
|
2005-08-02 02:03:36 -04:00
|
|
|
node-out-d [ literal-value literalize ] map concat % ;
|
2005-07-27 01:46:06 -04:00
|
|
|
|
|
|
|
M: #drop node>quot ( node -- )
|
|
|
|
node-in-d length dup 3 > [
|
2005-07-27 20:13:11 -04:00
|
|
|
\ drop <repeated>
|
2005-07-27 01:46:06 -04:00
|
|
|
] [
|
2005-07-27 20:13:11 -04:00
|
|
|
{ f [ drop ] [ 2drop ] [ 3drop ] } nth
|
|
|
|
] ifte % ;
|
2005-07-27 01:46:06 -04:00
|
|
|
|
|
|
|
DEFER: dataflow>quot
|
|
|
|
|
|
|
|
M: #call node>quot ( node -- )
|
|
|
|
dup node-param , dup effect-str <annotation> , ;
|
|
|
|
|
|
|
|
M: #call-label node>quot ( node -- )
|
|
|
|
"#call-label: " over node-param word-name append <annotation> , ;
|
|
|
|
|
|
|
|
M: #label node>quot ( node -- )
|
|
|
|
dup "#label: " over node-param word-name append <annotation> ,
|
|
|
|
node-children first dataflow>quot , \ call , ;
|
|
|
|
|
|
|
|
M: #ifte node>quot ( node -- )
|
|
|
|
dup "#ifte" <annotation> ,
|
|
|
|
node-children [ dataflow>quot ] map % \ ifte , ;
|
|
|
|
|
|
|
|
M: #dispatch node>quot ( node -- )
|
|
|
|
dup "#dispatch" <annotation> ,
|
|
|
|
node-children [ dataflow>quot ] map >vector % \ dispatch , ;
|
|
|
|
|
|
|
|
M: #return node>quot ( node -- ) "#return" <annotation> , ;
|
|
|
|
|
|
|
|
M: #values node>quot ( node -- ) "#values" <annotation> , ;
|
|
|
|
|
|
|
|
M: #merge node>quot ( node -- ) "#merge" <annotation> , ;
|
|
|
|
|
|
|
|
: (dataflow>quot) ( node -- )
|
|
|
|
[ dup node>quot node-successor (dataflow>quot) ] when* ;
|
|
|
|
|
|
|
|
: dataflow>quot ( node -- quot )
|
|
|
|
[ (dataflow>quot) ] make-list ;
|
|
|
|
|
|
|
|
: dataflow. ( quot -- )
|
|
|
|
#! Print dataflow IR for a word.
|
|
|
|
dataflow>quot prettyprint ;
|