 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators compiler.cfg
-compiler.cfg.builder.blocks compiler.cfg.comparisons
-compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.intrinsics compiler.cfg.registers
+compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
 compiler.cfg.stacks compiler.cfg.stacks.local compiler.tree
 compiler.cfg.utilities cpu.architecture fry kernel locals make math
 namespaces sequences words ;

    [ over length stack-locs zip ] 2bi@ append ;

: height-changes ( #shuffle -- height-changes )
    { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave
    4array [ length ] map first4 [ - ] 2bi@ 2array ;

: store-height-changes ( #shuffle -- )
    height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;

: extract-outputs ( #shuffle -- seq )
    [ out-d>> ds-loc 2array ] [ out-r>> rs-loc 2array ] bi 2array ;

: out-vregs/stack ( #shuffle -- seq )
    [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
    [ first2 [ [ of of peek-loc ] 2with map ] dip 2array ] 2with map ;

M: #shuffle emit-node ( block node -- block )
    [ out-vregs/stack ] keep store-height-changes
    [ first2 store-vregs ] each ;

! #return
: end-word ( block -- block' )

M: #call-recursive emit-node ( block node -- block' )
    [ label>> id>> ] [ call-height ] bi emit-call ;

M: #push emit-node ( block node -- block )
    literal>> ^^load-literal ds-push ;

! #shuffle
