Preliminary floating point intrinsics work

library/compiler/amd64/architecture.factor

@@ -16,8 +16,8 @@ kernel-internals math namespaces sequences ;
 : remainder-reg RDX ; inline
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
+M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
-M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 : compile-c-call ( symbol dll -- )
     2dup dlsym R10 swap MOV

library/compiler/generator/generator.factor

@@ -192,8 +192,16 @@ M: #dispatch generate-node ( node -- next )
 ! #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 ;
 
@@ -221,7 +229,7 @@ M: #push generate-node ( #push -- )
     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) ;
@@ -236,4 +244,5 @@ M: #return generate-node drop end-basic-block %return f ;
 : card-bits 7 ;
 : card-mark HEX: 80 ;
 
+: float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;

library/compiler/generator/templates.factor

@@ -7,22 +7,18 @@ namespaces prettyprint sequences vectors words ;
 ! 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 )
+: alloc-reg ( reg-class -- vreg ) free-vregs pop ;
-    >r free-vregs get pop r> <vreg> ;
 
-: requested-vregs ( template -- n )
+: take-reg ( vreg -- ) dup delegate free-vregs delete ;
-    0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
-    [ requested-vregs ] 2apply + ;
 
 : alloc-vregs ( template -- template )
-    [ first [ <int-vreg> ] [ T{ int-regs } alloc-reg ] if* ] map ;
+    [
-
+        first dup
-: adjust-free-vregs ( seq -- )
+        H{ { f T{ int-regs } } { float T{ float-regs f 8 } } }
-    free-vregs [ diff ] change ;
+        hash [ alloc-reg ] [ <int-vreg> dup take-reg ] ?if
+    ] map ;
 
 ! A data stack location.
 TUPLE: ds-loc n ;
@@ -84,7 +80,6 @@ M: phantom-callstack finalize-height
     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 )
@@ -150,22 +145,29 @@ SYMBOL: phantom-r
     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
+    used-vregs
-    >vector free-vregs set ;
+    { 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* ( -- int# float# )
-    free-vregs get length
+    T{ int-regs } free-vregs length
-    phantoms [ [ loc? ] subset length ] 2apply + - ;
+    phantoms [ [ loc? ] subset length ] 2apply + -
+    T{ float-regs f 8 } free-vregs length ;
 
-: ensure-vregs ( n -- )
+: ensure-vregs ( int# float# -- )
-    compute-free-vregs free-vregs* <=
+    compute-free-vregs free-vregs* swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
 : lazy-load ( value loc -- value )
@@ -181,12 +183,18 @@ SYMBOL: phantom-r
         [ 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 ] }
+        { [ dup { f float } memq? ] [ 2drop t ] }
-        { [ over not ] [ 2drop f ] }
+        { [ dup integer? ] [ swap compatible-vreg? ] }
-        { [ dup integer? ] [ swap vreg-n = ] }
     } cond ;
 
 : template-match? ( template phantom -- ? )
@@ -245,12 +253,12 @@ SYMBOL: +clobber
     outputs-clash? [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
-: input-vregs ( -- seq )
+: requested-vregs ( template -- int# float# )
-    +input +scratch [ get [ second get vreg-n ] map ] 2apply
+    dup length swap [ float eq? ] subset length [ - ] keep ;
-    append ;
 
-: guess-vregs ( -- n )
+: guess-vregs ( -- int# float# )
-    +input get { } additional-vregs# +scratch get length + ;
+    +input get { } additional-vregs#
+    +scratch get requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )
     +scratch get [ alloc-vregs ] keep phantom-vregs ;
@@ -261,11 +269,9 @@ SYMBOL: +clobber
     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
+    +input get match-template fast-input slow-input
-    used-vregs adjust-free-vregs
+    ! Finally allocate scratch registers
-    slow-input
+    alloc-scratch ;
-    alloc-scratch
-    input-vregs adjust-free-vregs ;
 
 : template-outputs ( -- )
     +output get [ get ] map { } (template-outputs) ;

library/compiler/x86/architecture.factor

@@ -46,12 +46,23 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : 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
+    [ load-indirect ] unboxify-float ;
-    add-literal [] MOV rel-absolute-cell rel-address ;
 
 : (%call) ( label -- label )
     dup postpone-word dup primitive? [ address-operand ] when ;
@@ -85,9 +96,22 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue RET ;
 
-: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
+: vreg-mov [ v>operand ] 2apply MOV ;
 
-: %replace ( vreg loc -- ) swap %peek ;
+: %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 ;
 

library/compiler/x86/intrinsics.factor

@@ -261,6 +261,39 @@ IN: compiler
     first2 define-fixnum-jump
 ] each
 
+! Floats
+! : define-float-op ( word op -- )
+!     [ [ "x" operand "y" operand ] % , ] [ ] make H{
+!         { +input { { float "x" } { float "y" } } }
+!         { +output { "x" } }
+!     } define-intrinsic ;
+! 
+! {
+!     { float+ ADDSD }
+!     { float- SUBSD }
+!     { float* MULSD }
+!     { float/f DIVSD }
+! } [
+!     first2 define-float-op
+! ] each
+! 
+! : define-float-jump ( word op -- )
+!     [
+!         [ end-basic-block "x" operand "y" operand COMISD ] % ,
+!     ] [ ] make H{
+!         { +input { { float "x" } { float "y" } } }
+!     } define-if-intrinsic ;
+! 
+! {
+!     { float< JL }
+!     { float<= JLE }
+!     { float> JG }
+!     { float>= JGE }
+!     { float= JE }
+! } [
+!     first2 define-float-jump
+! ] each
+
 ! User environment
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV