! #push
UNION: immediate fixnum POSTPONE: f ;
+: alloc-literal-reg ( literal -- vreg )
+ float? T{ float-regs f 8 } T{ int-regs } ? alloc-reg ;
+
+! : generate-push ( node -- )
+! >#push< dup [ class ] map requested-vregs ensure-vregs
+! [ dup alloc-literal-reg [ load-literal ] keep ] map
+! phantom-d get phantom-append ;
+
: generate-push ( node -- )
- >#push< dup length ensure-vregs
+ >#push< dup length 0 ensure-vregs
[ T{ int-regs } alloc-reg [ load-literal ] keep ] map
phantom-d get phantom-append ;
dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
: phantom-shuffle ( shuffle -- )
- dup shuffle-vregs# ensure-vregs
+ dup shuffle-vregs# 0 ensure-vregs
[ phantom-shuffle-inputs ] keep
[ shuffle* ] keep adjust-shuffle
(template-outputs) ;
: card-bits 7 ;
: card-mark HEX: 80 ;
+: float-offset 8 float-tag - ;
: string-offset 3 cells object-tag - ;
! Register allocation
! Hash mapping reg-classes to mutable vectors
-SYMBOL: free-vregs
+: free-vregs ( reg-class -- seq ) \ free-vregs get hash ;
-: alloc-reg ( reg-class -- vreg )
- >r free-vregs get pop r> <vreg> ;
+: alloc-reg ( reg-class -- vreg ) free-vregs pop ;
-: requested-vregs ( template -- n )
- 0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
- [ requested-vregs ] 2apply + ;
+: take-reg ( vreg -- ) dup delegate free-vregs delete ;
: alloc-vregs ( template -- template )
- [ first [ <int-vreg> ] [ T{ int-regs } alloc-reg ] if* ] map ;
-
-: adjust-free-vregs ( seq -- )
- free-vregs [ diff ] change ;
+ [
+ first dup
+ H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
+ hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
+ ] map ;
! A data stack location.
TUPLE: ds-loc n ;
dup length swap phantom-locs ;
: adjust-phantom ( n phantom -- )
- #! Change stack heiht.
[ phantom-stack-height + ] keep set-phantom-stack-height ;
GENERIC: cut-phantom ( n phantom -- seq )
finalize-contents finalize-heights ;
: used-vregs ( -- seq )
- phantoms append [ vreg? ] subset [ vreg-n ] map ;
+ phantoms append [ vreg? ] subset ;
+
+: (compute-free-vregs) ( used class -- vector )
+ dup vregs length reverse [ swap <vreg> ] map-with diff
+ >vector ;
: compute-free-vregs ( -- )
- used-vregs T{ int-regs } vregs length reverse diff
- >vector free-vregs set ;
+ used-vregs
+ { T{ int-regs } T{ float-regs f 8 } }
+ [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
+ drop ;
: additional-vregs# ( seq seq -- n )
2array phantoms 2array [ [ length ] map ] 2apply v-
0 [ 0 max + ] reduce ;
-: free-vregs* ( -- n )
- free-vregs get length
- phantoms [ [ loc? ] subset length ] 2apply + - ;
+: free-vregs* ( -- int# float# )
+ T{ int-regs } free-vregs length
+ phantoms [ [ loc? ] subset length ] 2apply + -
+ T{ float-regs f 8 } free-vregs length ;
-: ensure-vregs ( n -- )
- compute-free-vregs free-vregs* <=
+: ensure-vregs ( int# float# -- )
+ compute-free-vregs free-vregs* swapd <= >r <= r> and
[ finalize-contents compute-free-vregs ] unless ;
: lazy-load ( value loc -- value )
[ dupd %peek ] 2map
] 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 ;
+
: compatible-values? ( value template -- ? )
{
{ [ over loc? ] [ 2drop t ] }
- { [ dup not ] [ 2drop t ] }
- { [ over not ] [ 2drop f ] }
- { [ dup integer? ] [ swap vreg-n = ] }
+ { [ dup { f float } memq? ] [ 2drop t ] }
+ { [ dup integer? ] [ swap compatible-vreg? ] }
} cond ;
: template-match? ( template phantom -- ? )
outputs-clash? [ finalize-contents ] when
phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
-: input-vregs ( -- seq )
- +input +scratch [ get [ second get vreg-n ] map ] 2apply
- append ;
+: requested-vregs ( template -- int# float# )
+ dup length swap [ float eq? ] subset length [ - ] keep ;
-: guess-vregs ( -- n )
- +input get { } additional-vregs# +scratch get length + ;
+: guess-vregs ( -- int# float# )
+ +input get { } additional-vregs#
+ +scratch get requested-vregs >r + r> ;
: alloc-scratch ( -- )
+scratch get [ alloc-vregs ] keep phantom-vregs ;
guess-vregs ensure-vregs
! Split the template into available (fast) parts and those
! that require allocating registers and reading the stack
- +input get match-template fast-input
- used-vregs adjust-free-vregs
- slow-input
- alloc-scratch
- input-vregs adjust-free-vregs ;
+ +input get match-template fast-input slow-input
+ ! Finally allocate scratch registers
+ alloc-scratch ;
: template-outputs ( -- )
+output get [ get ] map { } (template-outputs) ;
: prepare-division CDQ ; inline
+: unboxify-float ( obj vreg quot -- | quot: obj int-vreg )
+ over [ float-regs? ] is? [
+ swap >r T{ int-regs } alloc-reg [ swap call ] keep
+ r> swap [ v>operand ] 2apply float-offset [+] MOVSD
+ ] [
+ call
+ ] if ; inline
+
M: immediate load-literal ( literal vreg -- )
- v>operand swap address MOV ;
+ v>operand swap v>operand MOV ;
+
+: load-indirect ( literal vreg -- )
+ v>operand swap add-literal [] MOV
+ rel-absolute-cell rel-address ;
M: object load-literal ( literal vreg -- )
- v>operand swap
- add-literal [] MOV rel-absolute-cell rel-address ;
+ [ load-indirect ] unboxify-float ;
: (%call) ( label -- label )
dup postpone-word dup primitive? [ address-operand ] when ;
: %return ( -- ) %epilogue RET ;
-: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
-
-: %replace ( vreg loc -- ) swap %peek ;
+: vreg-mov [ v>operand ] 2apply MOV ;
+
+: %peek ( vreg loc -- )
+ swap [ swap vreg-mov ] unboxify-float ;
+
+: %replace ( vreg loc -- )
+ over [ float-regs? ] is? [
+ ! >r
+ ! "fp-scratch" operand "allot.here" f dlsym [] MOV
+ ! "fp-scratch" operand [] float-tag >header MOV
+ ! "fp-scratch" operand 8 [+] r> MOVSD
+ ! "allot.here" f dlsym [] 16 ADD
+ vreg-mov
+ ] [
+ vreg-mov
+ ] if ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;