Changes to templating system, re-enabled shuffle optimizations
slava
parent
8eb75c89e4
commit
940d3307f5
|
|
@ -29,7 +29,7 @@ namespaces sequences words ;
|
|||
|
||||
\ slot [
|
||||
dup slot@ [
|
||||
{ { 0 "obj" } { f "slot" } } { "obj" } [
|
||||
{ { 0 "obj" } { value "slot" } } { "obj" } [
|
||||
node get slot@ "obj" get %fast-slot ,
|
||||
] with-template
|
||||
] [
|
||||
|
|
@ -42,7 +42,7 @@ namespaces sequences words ;
|
|||
|
||||
\ set-slot [
|
||||
dup slot@ [
|
||||
{ { 0 "val" } { 1 "obj" } { f "slot" } } { } [
|
||||
{ { 0 "val" } { 1 "obj" } { value "slot" } } { } [
|
||||
"val" get "obj" get node get slot@ %fast-set-slot ,
|
||||
] with-template
|
||||
] [
|
||||
|
|
@ -77,14 +77,14 @@ namespaces sequences words ;
|
|||
] "intrinsic" set-word-prop
|
||||
|
||||
\ getenv [
|
||||
{ { f "env" } } { "out" } [
|
||||
{ { value "env" } } { "out" } [
|
||||
T{ vreg f 0 } "out" set
|
||||
"env" get "out" get %getenv ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
||||
\ setenv [
|
||||
{ { 0 "value" } { f "env" } } { } [
|
||||
{ { 0 "value" } { value "env" } } { } [
|
||||
"value" get "env" get %setenv ,
|
||||
] with-template
|
||||
] "intrinsic" set-word-prop
|
||||
|
|
@ -95,7 +95,7 @@ namespaces sequences words ;
|
|||
|
||||
: binary-in ( node -- in )
|
||||
literal-immediate? fixnum-imm? and
|
||||
{ { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
|
||||
{ { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
|
||||
|
||||
: (binary-op) ( node in -- )
|
||||
{ "x" } [
|
||||
|
|
@ -172,7 +172,7 @@ namespaces sequences words ;
|
|||
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
||||
|
||||
: negative-shift ( n node -- )
|
||||
{ { 0 "x" } { f "n" } } { "out" } [
|
||||
{ { 0 "x" } { value "n" } } { "out" } [
|
||||
dup cell-bits neg <= [
|
||||
drop
|
||||
T{ vreg f 2 } "out" set
|
||||
|
|
@ -185,7 +185,7 @@ namespaces sequences words ;
|
|||
|
||||
: fast-shift ( n node -- )
|
||||
over zero? [
|
||||
-1 0 adjust-stacks end-basic-block 2drop
|
||||
end-basic-block -1 0 adjust-stacks 2drop
|
||||
] [
|
||||
over 0 < [
|
||||
negative-shift
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ SYMBOL: renamed-labels
|
|||
|
||||
: make-linear ( word quot -- )
|
||||
[
|
||||
0 { d-height r-height } [ set ] each-with
|
||||
init-templates
|
||||
swap >r { } make r> linearized get set-hash
|
||||
] with-node-iterator ; inline
|
||||
|
||||
|
|
@ -125,17 +125,11 @@ SYMBOL: live-r
|
|||
#! Avoid storing a value into its former position.
|
||||
dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
|
||||
|
||||
: shuffle-height ( node -- )
|
||||
[ dup node-out-d length swap node-in-d length - ] keep
|
||||
dup node-out-r length swap node-in-r length -
|
||||
adjust-stacks ;
|
||||
|
||||
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 do-inputs
|
||||
shuffle-height
|
||||
do-inputs
|
||||
live-d get live-r get template-outputs
|
||||
iterate-next ;
|
||||
|
||||
|
|
@ -145,7 +139,7 @@ M: #shuffle linearize* ( #shuffle -- )
|
|||
|
||||
M: #if linearize* ( node -- next )
|
||||
dup ?static-branch [
|
||||
-1 0 adjust-stacks
|
||||
end-basic-block -1 0 adjust-stacks
|
||||
swap node-children nth linearize-child iterate-next
|
||||
] [
|
||||
dup { { 0 "flag" } } { } [
|
||||
|
|
|
|||
|
|
@ -7,30 +7,25 @@ namespaces sequences vectors words ;
|
|||
SYMBOL: d-height
|
||||
SYMBOL: r-height
|
||||
|
||||
! Uncomitted values
|
||||
SYMBOL: phantom-d
|
||||
SYMBOL: phantom-r
|
||||
|
||||
: init-templates
|
||||
0 d-height set 0 r-height set
|
||||
V{ } clone phantom-d set V{ } clone phantom-r set ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
|
||||
C: ds-loc ( n -- ds-loc )
|
||||
[ >r d-height get - r> set-ds-loc-n ] keep ;
|
||||
C: ds-loc [ >r d-height get - r> set-ds-loc-n ] keep ;
|
||||
|
||||
! A call stack location.
|
||||
TUPLE: cs-loc n ;
|
||||
|
||||
C: cs-loc ( n -- ds-loc )
|
||||
[ >r r-height get - r> set-cs-loc-n ] keep ;
|
||||
C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
|
||||
|
||||
: 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
|
||||
|
|
@ -40,73 +35,86 @@ C: cs-loc ( n -- ds-loc )
|
|||
: load-literal ( obj vreg -- )
|
||||
over immediate? [ %immediate ] [ %indirect ] if , ;
|
||||
|
||||
GENERIC: stack>vreg* ( vreg loc value -- operand )
|
||||
: literal>stack ( value loc -- )
|
||||
swap value-literal fixnum-imm? over immediate? and
|
||||
[ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
|
||||
swap %replace , ; inline
|
||||
|
||||
M: object stack>vreg* ( vreg loc value -- operand )
|
||||
drop >r <vreg> dup r> %peek , ;
|
||||
G: vreg>stack ( value loc -- ) 1 standard-combination ;
|
||||
|
||||
M: value stack>vreg* ( vreg loc value -- operand )
|
||||
nip value-literal swap <vreg> [ load-literal ] keep ;
|
||||
M: f vreg>stack ( value loc -- ) 2drop ;
|
||||
|
||||
M: value vreg>stack ( value loc -- )
|
||||
swap value-literal fixnum-imm? over immediate? and
|
||||
[ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
|
||||
swap %replace , ;
|
||||
|
||||
M: object vreg>stack ( value loc -- )
|
||||
%replace , ;
|
||||
|
||||
: vregs>stack ( values quot literals -- )
|
||||
-rot >r [ dup value? rot eq? [ drop f ] unless ] map-with
|
||||
dup reverse-slice swap length r> map
|
||||
[ vreg>stack ] 2each ; inline
|
||||
|
||||
: finalize-height ( word symbol -- )
|
||||
[ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
|
||||
inline
|
||||
|
||||
: end-basic-block ( -- )
|
||||
\ %inc-d d-height finalize-height
|
||||
\ %inc-r r-height finalize-height
|
||||
phantom-d get [ <ds-loc> ] f vregs>stack
|
||||
phantom-r get [ <cs-loc> ] f vregs>stack
|
||||
phantom-d get [ <ds-loc> ] t vregs>stack
|
||||
phantom-r get [ <cs-loc> ] t vregs>stack
|
||||
0 phantom-d get set-length
|
||||
0 phantom-r get set-length ;
|
||||
|
||||
G: stack>vreg ( value vreg loc -- operand )
|
||||
2 standard-combination ;
|
||||
|
||||
M: f stack>vreg ( value vreg loc -- operand ) 2drop ;
|
||||
|
||||
M: object stack>vreg ( value vreg loc -- operand )
|
||||
>r <vreg> dup r> %peek , nip ;
|
||||
|
||||
M: value stack>vreg ( value vreg loc -- operand )
|
||||
drop >r value-literal r> dup value eq?
|
||||
[ drop ] [ <vreg> [ load-literal ] keep ] if ;
|
||||
|
||||
SYMBOL: vreg-allocator
|
||||
|
||||
SYMBOL: any-reg
|
||||
|
||||
: alloc-value ( loc value -- operand )
|
||||
vreg-allocator [ inc ] keep get -rot stack>vreg* ;
|
||||
: alloc-reg ( template -- template )
|
||||
dup any-reg eq? [
|
||||
drop vreg-allocator dup get swap inc
|
||||
] when ;
|
||||
|
||||
: 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 ;
|
||||
: alloc-regs ( template -- template ) [ alloc-reg ] map ;
|
||||
|
||||
: (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) ( values template locs -- inputs )
|
||||
3array flip
|
||||
[ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
|
||||
|
||||
: stack>vregs ( stack template quot -- )
|
||||
>r unpair -rot r> (stack>vregs) ; inline
|
||||
>r unpair -rot alloc-regs dup length reverse r> map
|
||||
(stack>vregs) swap [ set ] 2each ; inline
|
||||
|
||||
: template-inputs ( stack template stack template -- )
|
||||
[ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
|
||||
end-basic-block
|
||||
over >r [ <cs-loc> ] stack>vregs
|
||||
over >r [ <ds-loc> ] stack>vregs
|
||||
r> r> [ length neg ] 2apply adjust-stacks ;
|
||||
|
||||
: 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
|
||||
: >phantom ( seq stack -- )
|
||||
get swap [ dup value? [ get ] unless ] map nappend ;
|
||||
|
||||
: template-outputs ( stack stack -- )
|
||||
[ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
|
||||
|
||||
SYMBOL: template-height
|
||||
2dup [ length ] 2apply adjust-stacks
|
||||
phantom-r >phantom phantom-d >phantom ;
|
||||
|
||||
: with-template ( node in out quot -- )
|
||||
pick length pick length swap - template-height set
|
||||
swap >r >r
|
||||
>r dup node-in-d r> { } { } template-inputs
|
||||
template-height get 0 adjust-stacks
|
||||
swap >r >r >r dup node-in-d r> { } { } template-inputs
|
||||
node set r> call r> { } template-outputs ; 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 ;
|
||||
|
|
|
|||
|
|
@ -54,6 +54,8 @@ math-internals sequences strings test words ;
|
|||
[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
|
||||
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
|
||||
|
||||
[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test
|
||||
|
||||
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
|
||||
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
|
||||
[ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue