compiler: new inline intrinsic for <displaced-alien> where the inputs have known types; value numbering now eliminates unnecessary allocation of displaced aliens if the result is immediately unboxed again
parent
64990eb23d
commit
f662e6403a
|
@ -21,6 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
|
|||
M: ##set-slot temp-vregs temp>> 1array ;
|
||||
M: ##string-nth temp-vregs temp>> 1array ;
|
||||
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
|
||||
M: ##box-displaced-alien temp-vregs temp>> 1array ;
|
||||
M: ##compare temp-vregs temp>> 1array ;
|
||||
M: ##compare-imm temp-vregs temp>> 1array ;
|
||||
M: ##compare-float temp-vregs temp>> 1array ;
|
||||
|
|
|
@ -51,6 +51,7 @@ IN: compiler.cfg.hats
|
|||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
|
||||
: ^^box-displaced-alien ( base displacement -- dst ) ^^r2 next-vreg ##box-displaced-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
|
||||
|
|
|
@ -118,6 +118,7 @@ INSN: ##unbox-float < ##unary ;
|
|||
INSN: ##unbox-any-c-ptr < ##unary/temp ;
|
||||
INSN: ##box-float < ##unary/temp ;
|
||||
INSN: ##box-alien < ##unary/temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp ;
|
||||
|
||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||
|
|
|
@ -1,11 +1,24 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences alien math classes.algebra fry
|
||||
locals combinators cpu.architecture compiler.tree.propagation.info
|
||||
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
|
||||
locals combinators combinators.short-circuit cpu.architecture
|
||||
compiler.tree.propagation.info compiler.cfg.hats
|
||||
compiler.cfg.stacks compiler.cfg.instructions
|
||||
compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
||||
IN: compiler.cfg.intrinsics.alien
|
||||
|
||||
: emit-<displaced-alien>? ( node -- ? )
|
||||
node-input-infos {
|
||||
[ first class>> fixnum class<= ]
|
||||
[ second class>> c-ptr class<= ]
|
||||
} 1&& ;
|
||||
|
||||
: emit-<displaced-alien> ( node -- )
|
||||
dup emit-<displaced-alien>?
|
||||
[ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ]
|
||||
[ emit-primitive ]
|
||||
if ;
|
||||
|
||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
||||
|
||||
|
|
|
@ -10,6 +10,8 @@ compiler.cfg.intrinsics.float
|
|||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.comparisons ;
|
||||
QUALIFIED: alien
|
||||
QUALIFIED: alien.accessors
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
QUALIFIED: byte-arrays
|
||||
|
@ -20,7 +22,6 @@ QUALIFIED: classes.tuple.private
|
|||
QUALIFIED: math.private
|
||||
QUALIFIED: math.integers.private
|
||||
QUALIFIED: math.libm
|
||||
QUALIFIED: alien.accessors
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
{
|
||||
|
@ -54,6 +55,7 @@ IN: compiler.cfg.intrinsics
|
|||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
kernel:<wrapper>
|
||||
alien:<displaced-alien>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
alien.accessors:alien-signed-1
|
||||
|
@ -144,6 +146,7 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot ] }
|
||||
{ \ alien:<displaced-alien> [ emit-<displaced-alien> ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
|
||||
|
|
|
@ -140,6 +140,9 @@ M: ##string-nth rename-insn-temps
|
|||
M: ##set-string-nth-fast rename-insn-temps
|
||||
TEMP-QUOT change-temp drop ;
|
||||
|
||||
M: ##box-displaced-alien rename-insn-temps
|
||||
TEMP-QUOT change-temp drop ;
|
||||
|
||||
M: ##compare rename-insn-temps
|
||||
TEMP-QUOT change-temp drop ;
|
||||
|
||||
|
|
|
@ -25,6 +25,7 @@ M: ##slot temp-vreg-reps drop { int-rep } ;
|
|||
M: ##set-slot temp-vreg-reps drop { int-rep } ;
|
||||
M: ##string-nth temp-vreg-reps drop { int-rep } ;
|
||||
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
|
||||
M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-float temp-vreg-reps drop { int-rep } ;
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators combinators.short-circuit arrays
|
||||
fry kernel layouts math namespaces sequences cpu.architecture
|
||||
math.bitwise math.order classes vectors
|
||||
math.bitwise math.order classes vectors locals make
|
||||
compiler.cfg
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.comparisons
|
||||
|
@ -350,3 +350,24 @@ M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
|
|||
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
|
||||
|
||||
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
|
||||
|
||||
: box-displaced-alien? ( expr -- ? )
|
||||
op>> \ ##box-displaced-alien eq? ;
|
||||
|
||||
! ##box-displaced-alien f 1 2 3
|
||||
! ##unbox-any-c-ptr 4 1
|
||||
! =>
|
||||
! ##box-displaced-alien f 1 2 3
|
||||
! ##unbox-any-c-ptr 5 3
|
||||
! ##add 4 5 2
|
||||
|
||||
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
|
||||
[
|
||||
next-vreg :> temp
|
||||
temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr
|
||||
insn dst>> temp expr in1>> vn>vreg ##add
|
||||
] { } make ;
|
||||
|
||||
M: ##unbox-any-c-ptr rewrite
|
||||
dup src>> vreg>expr dup box-displaced-alien?
|
||||
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
|
||||
|
|
|
@ -87,6 +87,12 @@ M: unary-expr simplify*
|
|||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-box-displaced-alien ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ over expr-zero? ] [ nip ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: binary-expr simplify*
|
||||
dup op>> {
|
||||
{ \ ##add [ simplify-add ] }
|
||||
|
@ -107,6 +113,7 @@ M: binary-expr simplify*
|
|||
{ \ ##sar-imm [ simplify-shr ] }
|
||||
{ \ ##shl [ simplify-shl ] }
|
||||
{ \ ##shl-imm [ simplify-shl ] }
|
||||
{ \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
|
||||
[ 2drop f ]
|
||||
} case ;
|
||||
|
||||
|
|
|
@ -870,6 +870,63 @@ cell 8 = [
|
|||
] unit-test
|
||||
] when
|
||||
|
||||
! Displaced alien optimizations
|
||||
3 vreg-counter set-global
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##unbox-any-c-ptr f 4 0 }
|
||||
T{ ##add-imm f 3 4 16 }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##unbox-any-c-ptr f 3 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
4 vreg-counter set-global
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##copy f 5 1 any-rep }
|
||||
T{ ##add-imm f 4 5 16 }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##unbox-any-c-ptr f 4 3 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
3 vreg-counter set-global
|
||||
|
||||
[
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 0 }
|
||||
T{ ##copy f 3 0 any-rep }
|
||||
T{ ##replace f 3 D 1 }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##replace f 3 D 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
||||
! Branch folding
|
||||
[
|
||||
{
|
||||
|
@ -1301,3 +1358,4 @@ V{
|
|||
] unit-test
|
||||
|
||||
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel accessors
|
||||
sorting sets sequences
|
||||
sorting sets sequences arrays
|
||||
cpu.architecture
|
||||
sequences.deep
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.instructions
|
||||
|
@ -32,10 +33,13 @@ M: insn process-instruction
|
|||
dup rewrite
|
||||
[ process-instruction ] [ ] ?if ;
|
||||
|
||||
M: array process-instruction
|
||||
[ process-instruction ] map ;
|
||||
|
||||
: value-numbering-step ( insns -- insns' )
|
||||
init-value-graph
|
||||
init-expressions
|
||||
[ process-instruction ] map ;
|
||||
[ process-instruction ] map flatten ;
|
||||
|
||||
: value-numbering ( cfg -- cfg' )
|
||||
[ value-numbering-step ] local-optimization
|
||||
|
|
|
@ -177,10 +177,13 @@ M: ##float>integer generate-insn dst/src %float>integer ;
|
|||
|
||||
M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
|
||||
|
||||
M: ##unbox-float generate-insn dst/src %unbox-float ;
|
||||
M: ##unbox-float generate-insn dst/src %unbox-float ;
|
||||
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
|
||||
M: ##box-float generate-insn dst/src/temp %box-float ;
|
||||
M: ##box-alien generate-insn dst/src/temp %box-alien ;
|
||||
M: ##box-float generate-insn dst/src/temp %box-float ;
|
||||
M: ##box-alien generate-insn dst/src/temp %box-alien ;
|
||||
|
||||
M: ##box-displaced-alien generate-insn
|
||||
[ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
|
||||
|
||||
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
|
||||
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
|
||||
|
|
|
@ -463,6 +463,54 @@ cell 8 = [
|
|||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 123 ] [
|
||||
123 [ <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 123 ] [
|
||||
123 [ { fixnum } declare <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 123 ] [
|
||||
[ 123 <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
0 [ <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
0 [ { fixnum } declare <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ 0 <alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 321 ] [
|
||||
0 ALIEN: 321 [ <displaced-alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 321 ] [
|
||||
0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ ALIEN: 321 ] [
|
||||
ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ B{ 0 1 2 3 4 } ] [
|
||||
2 B{ 0 1 2 3 4 } <displaced-alien>
|
||||
[ 1 swap <displaced-alien> ] compile-call
|
||||
underlying>>
|
||||
] unit-test
|
||||
|
||||
[ B{ 0 1 2 3 4 } ] [
|
||||
2 B{ 0 1 2 3 4 } <displaced-alien>
|
||||
[ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
|
||||
underlying>>
|
||||
] unit-test
|
||||
|
||||
[
|
||||
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
|
||||
] must-fail
|
||||
|
|
|
@ -120,6 +120,7 @@ HOOK: %unbox-float cpu ( dst src -- )
|
|||
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
|
||||
HOOK: %box-float cpu ( dst src temp -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
|
||||
|
||||
HOOK: %alien-unsigned-1 cpu ( dst src -- )
|
||||
HOOK: %alien-unsigned-2 cpu ( dst src -- )
|
||||
|
|
|
@ -315,23 +315,50 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
|
|||
|
||||
: alien@ ( n -- n' ) cells object tag-number - ;
|
||||
|
||||
:: %allot-alien ( dst base displacement temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
temp \ f tag-number %load-immediate
|
||||
! Store expired slot
|
||||
temp dst 1 alien@ STW
|
||||
! Store underlying-alien slot
|
||||
base dst 2 alien@ STW
|
||||
! Store offset
|
||||
displacement dst 3 alien@ STW ;
|
||||
|
||||
M:: ppc %box-alien ( dst src temp -- )
|
||||
[
|
||||
"f" define-label
|
||||
dst \ f tag-number %load-immediate
|
||||
0 src 0 CMPI
|
||||
"f" get BEQ
|
||||
dst 4 cells alien temp %allot
|
||||
! Store offset
|
||||
src dst 3 alien@ STW
|
||||
! Store expired slot
|
||||
temp \ f tag-number %load-immediate
|
||||
temp dst 1 alien@ STW
|
||||
! Store underlying-alien slot
|
||||
temp dst 2 alien@ STW
|
||||
dst temp src temp %allot-alien
|
||||
"f" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: ppc %box-displaced-alien ( dst displacement base temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
! If displacement is zero, return the base
|
||||
dst base MR
|
||||
0 displacement 0 CMPI
|
||||
"end" get BEQ
|
||||
! If base is already a displaced alien, unpack it
|
||||
0 base \ f tag-number CMPI
|
||||
"ok" get BEQ
|
||||
temp base header-offset LWZ
|
||||
0 temp alien type-number tag-fixnum CMPI
|
||||
"ok" get BEQ
|
||||
! displacement += base.displacement
|
||||
temp base 3 alien@ LWZ
|
||||
displacement displacement temp ADD
|
||||
! base = base.base
|
||||
base base 1 alien@ LWZ
|
||||
"ok" resolve-label
|
||||
dst base displacement temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: ppc %alien-unsigned-1 0 LBZ ;
|
||||
M: ppc %alien-unsigned-2 0 LHZ ;
|
||||
|
||||
|
|
|
@ -255,17 +255,42 @@ M:: x86 %box-float ( dst src temp -- )
|
|||
|
||||
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||
|
||||
:: %allot-alien ( dst base displacement temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ base MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement MOV ! displacement
|
||||
;
|
||||
|
||||
M:: x86 %box-alien ( dst src temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
dst \ f tag-number MOV
|
||||
src 0 CMP
|
||||
"end" get JE
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ \ f tag-number MOV
|
||||
dst 2 alien@ \ f tag-number MOV
|
||||
! Store src in alien-offset slot
|
||||
dst 3 alien@ src MOV
|
||||
dst \ f tag-number src temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %box-displaced-alien ( dst displacement base temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
! If displacement is zero, return the base
|
||||
dst base MOV
|
||||
displacement 0 CMP
|
||||
"end" get JE
|
||||
! If base is already a displaced alien, unpack it
|
||||
base \ f tag-number CMP
|
||||
"ok" get JE
|
||||
base header-offset [+] alien type-number tag-fixnum CMP
|
||||
"ok" get JNE
|
||||
! displacement += base.displacement
|
||||
displacement base 3 alien@ ADD
|
||||
! base = base.base
|
||||
base base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst base displacement temp %allot-alien
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue