factor/basis/compiler/tree/tree.factor

! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel namespaces sequences
stack-checker.visitor vectors ;
IN: compiler.tree

TUPLE: node < identity-tuple ;

TUPLE: #introduce < node out-d ;

: <#introduce> ( out-d -- node )
    #introduce new swap >>out-d ;

TUPLE: #call < node word in-d out-d body method class info ;

: <#call> ( inputs outputs word -- node )
    #call new
        swap >>word
        swap >>out-d
        swap >>in-d ;

TUPLE: #call-recursive < node label in-d out-d info ;

: <#call-recursive> ( inputs outputs label -- node )
    #call-recursive new
        swap >>label
        swap >>out-d
        swap >>in-d ;

TUPLE: #push < node literal out-d ;

: <#push> ( literal value -- node )
    #push new
        swap 1array >>out-d
        swap >>literal ;

TUPLE: #renaming < node ;

TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;

: <#shuffle> ( in-d out-d in-r out-r mapping -- node )
    #shuffle new
        swap >>mapping
        swap >>out-r
        swap >>in-r
        swap >>out-d
        swap >>in-d ;

: <#data-shuffle> ( in-d out-d mapping -- node )
    [ f f ] dip <#shuffle> ; inline

: <#drop> ( inputs -- node )
    { } { } <#data-shuffle> ;

TUPLE: #terminate < node in-d in-r ;

: <#terminate> ( in-d in-r -- node )
    #terminate new
        swap >>in-r
        swap >>in-d ;

TUPLE: #branch < node in-d children live-branches ;

: new-branch ( value children class -- node )
    new
        swap >>children
        swap 1array >>in-d ; inline

TUPLE: #if < #branch ;

: <#if> ( ? true false -- node )
    2array #if new-branch ;

TUPLE: #dispatch < #branch ;

: <#dispatch> ( n branches -- node )
    #dispatch new-branch ;

TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;

: <#phi> ( d-phi-in d-phi-out terminated -- node )
    #phi new
        swap >>terminated
        swap >>out-d
        swap >>phi-in-d ;

TUPLE: #declare < node declaration ;

: <#declare> ( declaration -- node )
    #declare new
        swap >>declaration ;

TUPLE: #return < node in-d info ;

: <#return> ( stack -- node )
    #return new
        swap >>in-d ;

TUPLE: #recursive < node in-d word label loop? child ;

: <#recursive> ( label inputs child -- node )
    #recursive new
        swap >>child
        swap >>in-d
        swap >>label ;

TUPLE: #enter-recursive < node in-d out-d label info ;

: <#enter-recursive> ( label inputs outputs -- node )
    #enter-recursive new
        swap >>out-d
        swap >>in-d
        swap >>label ;

TUPLE: #return-recursive < #renaming in-d out-d label info ;

: <#return-recursive> ( label inputs outputs -- node )
    #return-recursive new
        swap >>out-d
        swap >>in-d
        swap >>label ;

TUPLE: #copy < #renaming in-d out-d ;

: <#copy> ( inputs outputs -- node )
    #copy new
        swap >>out-d
        swap >>in-d ;

TUPLE: #alien-node < node params ;

: new-alien-node ( params class -- node )
    new
        over in-d>> >>in-d
        over out-d>> >>out-d
        swap >>params ; inline

TUPLE: #alien-invoke < #alien-node in-d out-d ;

: <#alien-invoke> ( params -- node )
    #alien-invoke new-alien-node ;

TUPLE: #alien-indirect < #alien-node in-d out-d ;

: <#alien-indirect> ( params -- node )
    #alien-indirect new-alien-node ;

TUPLE: #alien-assembly < #alien-node in-d out-d ;

: <#alien-assembly> ( params -- node )
    #alien-assembly new-alien-node ;

TUPLE: #alien-callback < node params child ;

: <#alien-callback> ( params child -- node )
    #alien-callback new
        swap >>child
        swap >>params ;

: node, ( node -- ) stack-visitor get push ;

GENERIC: inputs/outputs ( #renaming -- inputs outputs )

M: #shuffle inputs/outputs mapping>> unzip swap ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;

: ends-with-terminate? ( nodes -- ? )
    [ f ] [ last #terminate? ] if-empty ;

M: vector child-visitor V{ } clone ;
M: vector #introduce, <#introduce> node, ;
M: vector #call, <#call> node, ;
M: vector #push, <#push> node, ;
M: vector #shuffle, <#shuffle> node, ;
M: vector #drop, <#drop> node, ;
M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
M: vector #return, <#return> node, ;
M: vector #enter-recursive, <#enter-recursive> node, ;
M: vector #return-recursive, <#return-recursive> node, ;
M: vector #call-recursive, <#call-recursive> node, ;
M: vector #terminate, <#terminate> node, ;
M: vector #if, <#if> node, ;
M: vector #dispatch, <#dispatch> node, ;
M: vector #phi, <#phi> node, ;
M: vector #declare, <#declare> node, ;
M: vector #recursive, <#recursive> node, ;
M: vector #copy, <#copy> node, ;
M: vector #alien-invoke, <#alien-invoke> node, ;
M: vector #alien-indirect, <#alien-indirect> node, ;
M: vector #alien-assembly, <#alien-assembly> node, ;
M: vector #alien-callback, <#alien-callback> node, ;