Compiler work

TODO.FACTOR.txt

@@ -1,7 +1,6 @@
 should fix in 0.82:
 
 - clean up/rewrite register allocation
-- moving between int and float vregs
 - intrinsic fixnum>float float>fixnum
 
 - amd64 %box-struct

library/compiler/generator/architecture.factor

@@ -1,6 +1,6 @@
 IN: compiler
-USING: generic kernel kernel-internals math memory namespaces
+USING: arrays generic kernel kernel-internals math memory
-sequences ;
+namespaces sequences ;
 
 ! A scratch register for computations
 TUPLE: vreg n ;
@@ -69,6 +69,20 @@ DEFER: %peek ( vreg loc -- )
 ! Store vreg to stack
 DEFER: %replace ( vreg loc -- )
 
+! Move one vreg to another
+DEFER: %move-int>int ( dst src -- )
+DEFER: %move-int>float ( dst src -- )
+
+: %move ( dst src -- )
+    2dup = [
+        2drop
+    ] [
+        2dup [ delegate class ] 2apply 2array {
+            { [ { int-regs int-regs } = ] [ %move-int>int ] }
+            { [ { float-regs int-regs } = ] [ %move-int>float ] }
+        } cond
+    ] if ;
+
 ! FFI stuff
 DEFER: %unbox ( n reg-class func -- )
 
@@ -84,14 +98,6 @@ DEFER: %alien-callback ( quot -- )
 
 DEFER: %callback-value ( reg-class func -- )
 
-! A few FFI operations have default implementations
-: %cleanup ( n -- ) drop ;
-
-: %stack>freg ( n reg reg-class -- ) 3drop ;
-
-: %freg>stack ( n reg reg-class -- ) 3drop ;
-
-! Some stuff probably not worth redefining in other backends
 M: stack-params fastcall-regs drop 0 ;
 
 GENERIC: reg-size ( register-class -- n )

library/compiler/generator/generator.factor

@@ -194,7 +194,7 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup literal-template
+    >#push< dup length f <array>
     dup requested-vregs ensure-vregs
     alloc-vregs [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append

library/compiler/generator/templates.factor

@@ -175,18 +175,20 @@ SYMBOL: phantom-r
     compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
+: spec>vreg ( spec -- vreg )
+    dup integer? [ <int-vreg> ] [ reg-spec>class alloc-reg ] if ;
+
+: (lazy-load) ( value spec -- value )
+    spec>vreg swap [
+        {
+            { [ dup loc? ] [ %peek ] }
+            { [ dup vreg? ] [ %move ] }
+            { [ t ] [ 2drop ] }
+        } cond
+    ] keep ;
+
 : lazy-load ( values template -- template )
-    [
+    [ first2 >r (lazy-load) r> 2array ] 2map ;
-        first2 >r over loc? [
-            over integer? [
-                >r <int-vreg> dup r> %peek
-            ] [
-                stack>new-vreg
-            ] if
-        ] [
-            drop
-        ] if r> 2array
-    ] 2map ;
 
 : stack>vregs ( phantom template -- values )
     [
@@ -195,11 +197,7 @@ SYMBOL: phantom-r
     ] 2keep length neg swap adjust-phantom ;
 
 : compatible-vreg? ( n vreg -- ? )
-    {
+    dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
-        { [ dup [ int-regs? ] is? ] [ vreg-n = ] }
-        { [ dup [ float-regs? ] is? ] [ 2drop t ] }
-        { [ t ] [ 2drop f ] }
-    } cond ;
 
 : compatible-values? ( value template -- ? )
     {

library/compiler/ppc/architecture.factor

@@ -176,3 +176,5 @@ M: stack-params freg>stack
     "unnest_stacks" f %alien-invoke
     ! Restore return register
     load-return ;
+
+: %cleanup ( n -- ) drop ;

library/compiler/x86/architecture.factor

@@ -46,36 +46,13 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : prepare-division CDQ ; inline
 
-: fp-scratch ( -- vreg )
-    "fp-scratch" get [
-        T{ int-regs } alloc-reg dup "fp-scratch" set
-    ] unless* ;
-
-: unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
-    #! The SSE2 code here will never be generated unless SSE2
-    #! intrinsics are loaded.
-    over [ float-regs? ] is? [
-        swap >r fp-scratch [ swap call ] keep
-        r> swap [ v>operand ] 2apply float-offset [+] MOVSD
-    ] [
-        call
-    ] if ; inline
-
-: literal-template
-    #! All literals go into integer registers unless SSE2
-    #! intrinsics are loaded.
-    length f <array> ;
-
 M: immediate load-literal ( literal vreg -- )
     v>operand swap v>operand MOV ;
 
-: load-indirect ( literal vreg -- )
+M: object load-literal ( literal vreg -- )
     v>operand swap add-literal [] MOV
     rel-absolute-cell rel-address ;
 
-M: object load-literal ( literal vreg -- )
-    [ load-indirect ] unboxify-float ;
-
 : (%call) ( label -- label )
     dup postpone-word dup primitive? [ address-operand ] when ;
 
@@ -108,14 +85,21 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: vreg-mov swap [ v>operand ] 2apply MOV ;
+: %move-int>int ( dst src -- )
+    [ v>operand ] 2apply MOV ;
 
-: %peek ( vreg loc -- )
+: %move-int>float ( dst src -- )
-    swap [ vreg-mov ] unboxify-float ;
+    [ v>operand ] 2apply float-offset [+] MOVSD ;
+
+GENERIC: (%peek) ( vreg loc reg-class -- )
+
+M: int-regs (%peek) drop %move-int>int ;
+
+: %peek ( vreg loc -- ) over (%peek) ;
 
 GENERIC: (%replace) ( vreg loc reg-class -- )
 
-M: int-regs (%replace) drop vreg-mov ;
+M: int-regs (%replace) drop swap %move-int>int ;
 
 : %replace ( vreg loc -- ) over (%replace) ;
 
@@ -124,3 +108,7 @@ M: int-regs (%replace) drop vreg-mov ;
 : %inc-d ( n -- ) ds-reg (%inc) ;
 
 : %inc-r ( n -- ) cs-reg (%inc) ;
+
+: %stack>freg ( n reg reg-class -- ) 3drop ;
+
+: %freg>stack ( n reg reg-class -- ) 3drop ;

library/compiler/x86/intrinsics-sse2.factor

@@ -4,10 +4,15 @@ USING: alien arrays assembler generic kernel kernel-internals
 lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
-: literal-template
+: fp-scratch ( -- vreg )
-    #! floats map to 'float' so we put float literals in float
+    "fp-scratch" get [
-    #! vregs
+        T{ int-regs } alloc-reg dup "fp-scratch" set
-    [ class ] map ;
+    ] unless* ;
+
+M: float-regs (%peek) ( vreg loc reg-class -- )
+    drop
+    fp-scratch swap %move-int>int
+    fp-scratch %move-int>float ;
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array

library/test/compiler/templates.factor

@@ -31,6 +31,8 @@ unit-test
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
 
+[ 2 ] [ 1 2 [ swap fixnum/i ] compile-1 ] unit-test
+
 : foo ;
 
 [ 4 4 ]