95 lines
2.8 KiB
Factor
95 lines
2.8 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: compiler-frontend
|
|
USING: compiler-backend generic inference kernel math namespaces
|
|
sequences vectors words ;
|
|
|
|
: 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 ;
|
|
|
|
GENERIC: load-value ( vreg n value -- )
|
|
|
|
M: object load-value ( vreg n value -- )
|
|
drop %peek-d , ;
|
|
|
|
: load-literal ( vreg obj -- )
|
|
dup immediate? [ %immediate ] [ %indirect ] if , ;
|
|
|
|
M: literal load-value ( vreg n value -- )
|
|
nip literal-value load-literal ;
|
|
|
|
SYMBOL: vreg-allocator
|
|
SYMBOL: live-d
|
|
SYMBOL: live-r
|
|
|
|
: value-dropped? ( value -- ? )
|
|
dup literal?
|
|
over live-d get member? not
|
|
rot live-r get member? not and
|
|
or ;
|
|
|
|
: stack>vreg ( value stack-pos loader -- )
|
|
pick >r vreg-allocator get r> set
|
|
pick value-dropped? [ pick get pick pick execute , ] unless
|
|
3drop vreg-allocator inc ; inline
|
|
|
|
: (stacks>vregs) ( stack loader -- )
|
|
swap reverse-slice dup length
|
|
[ pick stack>vreg ] 2each drop ; inline
|
|
|
|
: stacks>vregs ( #shuffle -- )
|
|
dup
|
|
node-in-d \ %peek-d (stacks>vregs)
|
|
node-in-r \ %peek-r (stacks>vregs) ;
|
|
|
|
: shuffle-height ( #shuffle -- )
|
|
dup node-out-d length over node-in-d length - %inc-d ,
|
|
dup node-out-r length swap node-in-r length - %inc-r , ;
|
|
|
|
: literal>stack ( stack-pos value storer -- )
|
|
>r literal-value r> fixnum-imm? pick immediate? and [
|
|
>r 0 swap load-literal 0 <vreg> r>
|
|
] unless swapd execute , ; inline
|
|
|
|
: computed>stack >r get <vreg> swap r> execute , ;
|
|
|
|
: vreg>stack ( stack-pos value storer -- )
|
|
{
|
|
{ [ over not ] [ 3drop ] }
|
|
{ [ over literal? ] [ literal>stack ] }
|
|
{ [ t ] [ computed>stack ] }
|
|
} cond ; inline
|
|
|
|
: (vregs>stack) ( stack storer -- )
|
|
swap reverse-slice [ length ] keep
|
|
[ pick vreg>stack ] 2each drop ; inline
|
|
|
|
: (vregs>stacks) ( stack stack -- )
|
|
\ %replace-r (vregs>stack) \ %replace-d (vregs>stack) ;
|
|
|
|
: literals/computed ( stack -- literals computed )
|
|
dup [ dup literal? [ drop f ] unless ] map
|
|
swap [ dup literal? [ drop f ] when ] map ;
|
|
|
|
: vregs>stacks ( -- )
|
|
live-d get literals/computed
|
|
live-r get literals/computed
|
|
swapd (vregs>stacks) (vregs>stacks) ;
|
|
|
|
: live-stores ( instack outstack -- stack )
|
|
#! Avoid storing a value into its former position.
|
|
dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
|
|
|
|
M: #shuffle linearize* ( #shuffle -- )
|
|
[
|
|
0 vreg-allocator set
|
|
dup node-in-d over node-out-d live-stores live-d set
|
|
dup node-in-r over node-out-r live-stores live-r set
|
|
dup stacks>vregs
|
|
dup shuffle-height
|
|
vregs>stacks
|
|
] with-scope linearize-next ;
|