should fix in 0.82:
- clean up/rewrite register allocation
-- moving between int and float vregs
- intrinsic fixnum>float float>fixnum
- amd64 %box-struct
IN: compiler
-USING: generic kernel kernel-internals math memory namespaces
-sequences ;
+USING: arrays generic kernel kernel-internals math memory
+namespaces sequences ;
! A scratch register for computations
TUPLE: vreg n ;
! 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 -- )
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 )
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
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 over loc? [
- over integer? [
- >r <int-vreg> dup r> %peek
- ] [
- stack>new-vreg
- ] if
- ] [
- drop
- ] if r> 2array
- ] 2map ;
+ [ first2 >r (lazy-load) r> 2array ] 2map ;
: stack>vregs ( phantom template -- values )
[
] 2keep length neg swap adjust-phantom ;
: compatible-vreg? ( n vreg -- ? )
- {
- { [ dup [ int-regs? ] is? ] [ vreg-n = ] }
- { [ dup [ float-regs? ] is? ] [ 2drop t ] }
- { [ t ] [ 2drop f ] }
- } cond ;
+ dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
: compatible-values? ( value template -- ? )
{
"unnest_stacks" f %alien-invoke
! Restore return register
load-return ;
+
+: %cleanup ( n -- ) drop ;
: 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 ;
: %return ( -- ) %epilogue RET ;
-: vreg-mov swap [ v>operand ] 2apply MOV ;
+: %move-int>int ( dst src -- )
+ [ v>operand ] 2apply MOV ;
+
+: %move-int>float ( dst src -- )
+ [ v>operand ] 2apply float-offset [+] MOVSD ;
-: %peek ( vreg loc -- )
- swap [ vreg-mov ] unboxify-float ;
+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) ;
: %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 ;
lists math math-internals memory namespaces sequences words ;
IN: compiler
-: literal-template
- #! floats map to 'float' so we put float literals in float
- #! vregs
- [ class ] map ;
+: fp-scratch ( -- vreg )
+ "fp-scratch" get [
+ T{ int-regs } alloc-reg dup "fp-scratch" set
+ ] 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
! 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 ]