104 lines
3.1 KiB
Factor
104 lines
3.1 KiB
Factor
|
! Copyright (C) 2006 Slava Pestov.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
IN: compiler-frontend
|
||
|
|
USING: arrays compiler-backend generic inference kernel math
|
||
|
|
namespaces sequences vectors words ;
|
||
|
|
|
||
|
|
! SYMBOL: d-height
|
||
|
|
! SYMBOL: r-height
|
||
|
|
!
|
||
|
|
! : adjust-stacks ( inc-d inc-r -- )
|
||
|
|
! r-height [ + ] change d-height [ + ] change ;
|
||
|
|
!
|
||
|
|
! : finalize-stack ( quot symbol -- )
|
||
|
|
! [
|
||
|
|
! get dup zero? [ 2drop ] [ swap execute , ] if 0
|
||
|
|
! ] keep set ; inline
|
||
|
|
!
|
||
|
|
! : end-basic-block ( -- )
|
||
|
|
! \ %inc-r r-height finalize-stack
|
||
|
|
! \ %inc-d d-height finalize-stack ;
|
||
|
|
|
||
|
|
: immediate? ( obj -- ? )
|
||
|
|
#! fixnums and f have a pointerless representation, and
|
||
|
|
#! are compiled immediately. Everything else can be moved
|
||
|
|
#! by GC, and is indexed through a table.
|
||
|
|
dup fixnum? swap f eq? or ;
|
||
|
|
|
||
|
|
: load-literal ( obj vreg -- )
|
||
|
|
over immediate? [ %immediate ] [ %indirect ] if , ;
|
||
|
|
|
||
|
|
GENERIC: stack>vreg* ( vreg loc value -- operand )
|
||
|
|
|
||
|
|
M: object stack>vreg* ( vreg loc value -- operand )
|
||
|
|
drop >r <vreg> dup r> %peek , ;
|
||
|
|
|
||
|
|
M: value stack>vreg* ( vreg loc value -- operand )
|
||
|
|
nip value-literal swap <vreg> [ load-literal ] keep ;
|
||
|
|
|
||
|
|
SYMBOL: vreg-allocator
|
||
|
|
|
||
|
|
SYMBOL: any-reg
|
||
|
|
|
||
|
|
: alloc-value ( loc value -- operand )
|
||
|
|
vreg-allocator [ inc ] keep get -rot stack>vreg* ;
|
||
|
|
|
||
|
|
: stack>vreg ( vreg loc value -- operand )
|
||
|
|
{
|
||
|
|
{ [ dup not ] [ 3drop f ] }
|
||
|
|
{ [ pick any-reg eq? ] [ alloc-value nip ] }
|
||
|
|
{ [ pick not ] [ 2nip value-literal ] }
|
||
|
|
{ [ t ] [ stack>vreg* ] }
|
||
|
|
} cond ;
|
||
|
|
|
||
|
|
: (stack>vregs) ( names values template quot -- inputs )
|
||
|
|
>r dup length reverse r> map 3array flip
|
||
|
|
[ first3 rot stack>vreg ] map swap [ set ] 2each ; inline
|
||
|
|
|
||
|
|
: stack>vregs ( stack template quot -- )
|
||
|
|
>r unpair -rot r> (stack>vregs) ; inline
|
||
|
|
|
||
|
|
: template-inputs ( stack template stack template -- )
|
||
|
|
[ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
|
||
|
|
|
||
|
|
: literal>stack ( value stack-pos -- )
|
||
|
|
swap value-literal fixnum-imm? over immediate? and
|
||
|
|
[ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
|
||
|
|
swap %replace , ; inline
|
||
|
|
|
||
|
|
: vreg>stack ( value stack-pos -- )
|
||
|
|
{
|
||
|
|
{ [ over not ] [ 2drop ] }
|
||
|
|
{ [ over value? ] [ literal>stack ] }
|
||
|
|
{ [ t ] [ >r get r> %replace , ] }
|
||
|
|
} cond ;
|
||
|
|
|
||
|
|
: vregs>stack ( values quot -- )
|
||
|
|
>r dup reverse-slice swap length r> map
|
||
|
|
[ vreg>stack ] 2each ; inline
|
||
|
|
|
||
|
|
: template-outputs ( stack stack -- )
|
||
|
|
[ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
|
||
|
|
|
||
|
|
SYMBOL: template-height
|
||
|
|
|
||
|
|
: with-template ( node in out quot -- )
|
||
|
|
[
|
||
|
|
0 vreg-allocator set
|
||
|
|
pick length pick length swap - template-height set
|
||
|
|
swap >r >r
|
||
|
|
>r dup node-in-d r> { } { } template-inputs
|
||
|
|
template-height get %inc-d ,
|
||
|
|
node set r> call r> { } template-outputs
|
||
|
|
] with-scope ; inline
|
||
|
|
|
||
|
|
: literals/computed ( stack -- literals computed )
|
||
|
|
dup [ dup value? [ drop f ] unless ] map
|
||
|
|
swap [ dup value? [ drop f ] when ] map ;
|
||
|
|
|
||
|
|
: vregs>stacks ( ds cs -- )
|
||
|
|
#! We store literals last because storing a literal to a
|
||
|
|
#! stack slot actually clobbers a vreg.
|
||
|
|
>r literals/computed r> literals/computed swapd
|
||
|
|
template-outputs template-outputs ;
|