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 ;
: ^^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
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 ;
! 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 ;
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
+QUALIFIED: alien
+QUALIFIED: alien.accessors
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.libm
-QUALIFIED: alien.accessors
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
{ \ 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 ] }
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 ;
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 } ;
! 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
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 ;
[ 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 ] }
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] }
+ { \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
[ 2drop f ]
} case ;
] 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
[
{
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+
! 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
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
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 ;
] 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
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 -- )
: 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 ;
: 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 ;