Working on improved alien intrinsics

core/compiler/test/templates-early.factor

@@ -119,12 +119,12 @@ SYMBOL: template-chosen
 
     ! This is not empty since a load instruction is emitted
     [ f ] [
-        [ { { f "x"  } } fast-input ] { } make empty?
+        [ { { f "x" } } fast-input ] { } make empty?
     ] unit-test
 
     ! This is empty since we already loaded the value
     [ t ] [
-        [ { { f "x"  } } fast-input ] { } make empty?
+        [ { { f "x" } } fast-input ] { } make empty?
     ] unit-test
 
     ! This is empty since we didn't change the stack

core/compiler/test/templates.factor

@@ -1,9 +1,9 @@
-! Black box testing of templater optimization
+! Black box testing of templating optimization
 
 USING: arrays compiler kernel kernel.private math
 hashtables.private math.private math.ratios.private namespaces
 sequences sequences.private tools.test namespaces.private
-slots.private combinators.private ;
+slots.private combinators.private byte-arrays alien layouts ;
 IN: temporary
 
 ! Oops!
@@ -185,3 +185,31 @@ TUPLE: my-tuple ;
 [ 4 ] [ T{ my-tuple } foox ] unit-test
 
 [ 5 ] [ "hi" foox ] unit-test
+
+! Making sure we don't needlessly unbox/rebox
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test
+
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test
+
+[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test
+
+[ 1 B{ 1 2 3 4 } ] [
+    B{ 1 2 3 4 } [
+        { byte-array } declare
+        [ 0 alien-unsigned-1 ] keep
+    ] compile-1
+] unit-test
+
+[ 1 t ] [
+    B{ 1 2 3 4 } [
+        { simple-c-ptr } declare
+        [ 0 alien-unsigned-1 ] keep type
+    ] compile-1 byte-array type-number =
+] unit-test
+
+[ t ] [
+    B{ 1 2 3 4 } [
+        { simple-c-ptr } declare
+        0 alien-cell type
+    ] compile-1 alien type-number =
+] unit-test

core/cpu/architecture/architecture.factor

@@ -183,24 +183,15 @@ PREDICATE: integer inline-array 32 < ;
     ] if-small-struct ;
 
 ! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( quot src -- ) inline
+HOOK: %unbox-byte-array compiler-backend ( dst src -- )
 
-HOOK: %unbox-alien compiler-backend ( quot src -- ) inline
+HOOK: %unbox-alien compiler-backend ( dst src -- )
 
-HOOK: %unbox-f compiler-backend ( quot src -- ) inline
+HOOK: %unbox-f compiler-backend ( dst src -- )
 
-HOOK: %complex-alien-accessor compiler-backend ( quot src -- )
+HOOK: %unbox-c-ptr compiler-backend ( dst src -- )
-inline
 
-: %alien-accessor ( quot src class -- )
+HOOK: %box-alien compiler-backend ( dst src -- )
-    {
-        { [ dup \ f class< ] [ drop %unbox-f ] }
-        { [ dup simple-alien class< ] [ drop %unbox-alien ] }
-        { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
-        { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
-        { [ dup float-array class< ] [ drop %unbox-byte-array ] }
-        { [ t ] [ drop %complex-alien-accessor ] }
-    } cond ; inline
 
 : operand ( var -- op ) get v>operand ; inline
 

core/cpu/ppc/allot/allot.factor

@@ -78,22 +78,22 @@ M: ppc-backend %box-float ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-: %allot-alien ( ptr -- )
+M: ppc-backend %box-alien ( dst src -- )
-    "temp" set
     "f" define-label
     "end" define-label
-    0 "temp" operand 0 CMPI
+    0 over v>operand 0 CMPI
     "f" get BEQ
     alien 4 cells %allot
-    "temp" operand 11 3 cells STW
+    ! Store offset
-    f v>operand "temp" operand LI
+    v>operand 11 3 cells STW
+    f v>operand 12 LI
     ! Store expired slot
-    "temp" operand 11 1 cells STW
+    12 11 1 cells STW
     ! Store underlying-alien slot
-    "temp" operand 11 2 cells STW
+    12 11 2 cells STW
     ! Store tagged ptr in reg
-    "temp" get object %store-tagged
+    dup object %store-tagged
     "end" get B
     "f" resolve-label
-    f v>operand "temp" operand LI
+    f v>operand swap v>operand LI
     "end" resolve-label ;

core/cpu/ppc/architecture/architecture.factor

@@ -315,34 +315,28 @@ M: ppc-backend %unbox-small-struct
     drop "No small structs" throw ;
 
 ! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( quot src -- )
+M: ppc-backend %unbox-byte-array ( dst src -- )
-    "address" operand "alien" operand "offset" operand ADD
+    [ v>operand ] 2apply byte-array-offset ADDI ;
-    "address" operand byte-array-offset
-    roll call ;
 
-M: ppc-backend %unbox-alien ( quot src -- )
+M: ppc-backend %unbox-alien ( dst src -- )
-    "address" operand "alien" operand alien-offset LWZ
+    [ v>operand ] 2apply alien-offset LWZ ;
-    "address" operand dup "offset" operand ADD
-    "address" operand 0
-    roll call ;
 
-M: ppc-backend %unbox-f ( quot src -- )
+M: ppc-backend %unbox-f ( dst src -- )
-    "offset" operand 0
+    drop 0 swap v>operand LI ;
-    roll call ;
 
-M: ppc-backend %complex-alien-accessor ( quot src -- )
+M: ppc-backend %unbox-c-ptr ( dst src -- )
     "is-f" define-label
     "is-alien" define-label
     "end" define-label
-    0 "alien" operand f v>operand CMPI
+    0 over v>operand f v>operand CMPI
     "is-f" get BEQ
-    "address" operand "alien" operand header-offset LWZ
+    12 over v>operand header-offset LWZ
-    0 "address" operand alien type-number tag-header CMPI
+    0 12 alien type-number tag-header CMPI
     "is-alien" get BEQ
-    [ %unbox-byte-array ] 2keep
+    2dup %unbox-byte-array
     "end" get B
     "is-alien" resolve-label
-    [ %unbox-alien ] 2keep
+    2dup %unbox-alien
     "end" get B
     "is-f" resolve-label
     %unbox-f

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -601,41 +601,48 @@ IN: cpu.ppc.intrinsics
 } define-intrinsic
 
 ! Alien intrinsics
+: %alien-get ( quot -- )
+    "offset" operand dup %untag-fixnum
+    "offset" operand dup "alien" operand ADD
+    "output" operand "offset" operand 0 roll call ; inline
+
+: %alien-set ( quot -- )
+    "offset" operand dup %untag-fixnum
+    "offset" operand dup "alien" operand ADD
+    "value" operand "offset" operand 0 roll call ; inline
+
 : alien-integer-get-template
     H{
         { +input+ {
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" simple-c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "output" } } }
+        { +scratch+ { { f "output" } { f "address" } } }
         { +output+ { "output" } }
         { +clobber+ { "offset" } }
     } ;
 
-: %alien-get ( quot -- )
-    "output" get "address" set
-    "offset" operand dup %untag-fixnum
-    "output" operand "alien" operand-class %alien-accessor ;
-
 : %alien-integer-get ( quot -- )
     %alien-get
     "output" operand dup %tag-fixnum ; inline
 
-: %alien-integer-set ( quot -- )
-    { "offset" "value" } %untag-fixnums
-    "value" operand "alien" operand-class %alien-accessor ; inline
-
 : alien-integer-set-template
     H{
         { +input+ {
             { f "value" fixnum }
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" simple-c-ptr }
             { f "offset" fixnum }
         } }
         { +scratch+ { { f "address" } } }
         { +clobber+ { "value" "offset" } }
     } ;
 
+: %alien-integer-set ( quot -- )
+    "offset" get "value" get = [
+        "value" operand dup %untag-fixnum
+    ] unless
+    %alien-set ; inline
+
 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
     [ %alien-integer-set ] curry
     alien-integer-set-template
@@ -660,41 +667,56 @@ define-alien-integer-intrinsics
 \ set-alien-signed-2 [ STH ]
 define-alien-integer-intrinsics
 
-: %alien-float-get ( quot -- )
+\ alien-cell [
-    "offset" operand dup %untag-fixnum
+    [ LWZ ] %alien-get
-    "output" operand "alien" operand-class %alien-accessor ; inline
+] H{
+    { +input+ {
+        { unboxed-c-ptr "alien" simple-c-ptr }
+        { f "offset" fixnum }
+    } }
+    ! should be unboxed-alien
+    { +scratch+ { { unboxed-c-ptr "output" } } }
+    { +output+ { "output" } }
+    { +clobber+ { "offset" } }
+} define-intrinsic
+
+\ set-alien-cell [
+    [ STW ] %alien-set
+] H{
+    { +input+ {
+        { unboxed-c-ptr "value" simple-c-ptr }
+        { unboxed-c-ptr "alien" simple-c-ptr }
+        { f "offset" fixnum }
+    } }
+    { +clobber+ { "offset" } }
+} define-intrinsic
 
 : alien-float-get-template
     H{
         { +input+ {
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" simple-c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { float "output" } { f "address" } } }
+        { +scratch+ { { float "output" } } }
         { +output+ { "output" } }
         { +clobber+ { "offset" } }
     } ;
 
-: %alien-float-set ( quot -- )
-    "offset" operand dup %untag-fixnum
-    "value" operand "alien" operand-class %alien-accessor ; inline
-
 : alien-float-set-template
     H{
         { +input+ {
             { float "value" float }
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" simple-c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "address" } } }
         { +clobber+ { "offset" } }
     } ;
 
 : define-alien-float-intrinsics ( word get-quot word set-quot -- )
-    [ %alien-float-set ] curry
+    [ %alien-set ] curry
     alien-float-set-template
     define-intrinsic
-    [ %alien-float-get ] curry
+    [ %alien-get ] curry
     alien-float-get-template
     define-intrinsic ;
 
@@ -705,8 +727,3 @@ define-alien-float-intrinsics
 \ alien-float [ LFS ]
 \ set-alien-float [ STFS ]
 define-alien-float-intrinsics
-
-\ alien-cell [
-    [ LWZ ] %alien-get
-    "output" get %allot-alien
-] alien-integer-get-template define-intrinsic

core/generator/registers/registers.factor

@@ -47,6 +47,23 @@ TUPLE: rs-loc n ;
 
 C: <rs-loc> rs-loc
 
+! Unboxed alien pointers
+TUPLE: unboxed-alien vreg ;
+C: <unboxed-alien> unboxed-alien
+M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+
+TUPLE: unboxed-byte-array vreg ;
+C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+
+TUPLE: unboxed-f vreg ;
+C: <unboxed-f> unboxed-f
+M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+
+TUPLE: unboxed-c-ptr vreg ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+
 <PRIVATE
 
 UNION: loc ds-loc rs-loc ;
@@ -54,22 +71,34 @@ UNION: loc ds-loc rs-loc ;
 ! Moving values between locations and registers
 GENERIC: move-spec ( obj -- spec )
 
+M: unboxed-alien move-spec class ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-f move-spec class ;
+M: unboxed-c-ptr move-spec class ;
 M: int-regs move-spec drop f ;
 M: float-regs move-spec drop float ;
 M: value move-spec class ;
 M: cached move-spec drop cached ;
 M: loc move-spec drop loc ;
 M: f move-spec drop loc ;
-USE: prettyprint
+
 : %move ( dst src -- )
-    dup [ "FUCK" throw ] unless
     2dup [ move-spec ] 2apply 2array {
         { { f f } [ "Bug in generator.registers %move" throw ] }
-        { { float f } [ %unbox-float ] }
-        { { loc f } [ swap %replace ] }
-        { { f float } [ %box-float ] }
         { { f value } [ value-literal swap load-literal ] }
+
+        { { f float } [ %box-float ] }
+        ! { { f unboxed-alien } [ %box-alien ] }
+        { { f unboxed-c-ptr } [ %box-alien ] }
         { { f loc } [ %peek ] }
+
+        { { float f } [ %unbox-float ] }
+        { { unboxed-alien f } [ %unbox-alien ] }
+        { { unboxed-byte-array f } [ %unbox-byte-array ] }
+        { { unboxed-f f } [ %unbox-f ] }
+        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+        { { loc f } [ swap %replace ] }
+
         [ drop temp-reg swap %move temp-reg %move ]
     } case ;
 
@@ -188,7 +217,11 @@ PRIVATE>
 ! Phantom stacks hold values, locs, and vregs
 GENERIC: live-vregs* ( obj -- )
 
-M: cached live-vregs* cached-vreg , ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
 M: vreg live-vregs* , ;
 M: object live-vregs* drop ;
 
@@ -239,7 +272,13 @@ SYMBOL: fresh-objects
 
 ! Copying vregs to stacks
 : alloc-vreg ( spec -- reg )
-    reg-spec>class free-vregs pop ;
+    dup reg-spec>class free-vregs pop swap {
+        { unboxed-alien [ <unboxed-alien> ] }
+        { unboxed-byte-array [ <unboxed-byte-array> ] }
+        { unboxed-f [ <unboxed-f> ] }
+        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+        [ drop ]
+    } case ;
 
 : allocation ( value spec -- reg-class )
     dup quotation? [
@@ -368,8 +407,19 @@ M: object minimal-ds-loc* drop ;
 : vreg-substitution ( value vreg -- pair )
     dupd <cached> 2array ;
 
+: substitute-vreg? ( old new -- ? )
+    #! We don't substitute locs for float or alien vregs,
+    #! since in those cases the boxing overhead might kill us.
+    cached-vreg {
+        { [ dup vreg? not ] [ f ] }
+        { [ dup delegate int-regs? not ] [ f ] }
+        { [ over loc? not ] [ f ] }
+        { [ t ] [ t ] }
+    } cond 2nip ;
+
 : substitute-vregs ( values vregs -- )
-    [ vreg-substitution ] 2map [ first loc? ] subset >hashtable
+    [ vreg-substitution ] 2map
+    [ substitute-vreg? ] assoc-subset >hashtable
     [ swap substitute ] curry each-phantom ;
 
 : lazy-load ( values template -- )