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

basis/compiler/cfg/def-use/def-use.factor

@@ -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 ;

basis/compiler/cfg/hats/hats.factor

@@ -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

basis/compiler/cfg/instructions/instructions.factor

@@ -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 ;

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -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
+locals combinators combinators.short-circuit cpu.architecture
-compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+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 ;
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -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 ] }

basis/compiler/cfg/renaming/functor/functor.factor

@@ -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 ;
 

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -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 } ;

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -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 ;

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -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 ;
 

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -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
+

basis/compiler/cfg/value-numbering/value-numbering.factor

@@ -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

basis/compiler/codegen/codegen.factor

@@ -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-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien       generate-insn dst/src/temp %box-alien ;
+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 ;

basis/compiler/tests/intrinsics.factor

@@ -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

basis/cpu/architecture/architecture.factor

@@ -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 -- )

basis/cpu/ppc/ppc.factor

@@ -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
+        dst temp src temp %allot-alien
-        ! 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
         "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 ;
 

basis/cpu/x86/x86.factor

@@ -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 \ f tag-number src temp %allot-alien
-        dst 1 alien@ \ f tag-number MOV
+        "end" resolve-label
-        dst 2 alien@ \ f tag-number MOV
+    ] with-scope ;
-        ! Store src in alien-offset slot
+
-        dst 3 alien@ src MOV
+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 ;