vregs now delegate to a register class

library/compiler/amd64/architecture.factor

@@ -5,7 +5,8 @@ USING: alien arrays assembler kernel
 kernel-internals math namespaces sequences ;
 
 ! AMD64 register assignments
-! RAX RCX RDX RSI RDI R8 R9 R10 R11 vregs
+! RAX RCX RDX RSI RDI R8 R9 R10 R11 integer vregs
+! XMM0 - XMM7 float vregs
 ! R13 cards_offset
 ! R14 datastack
 ! R15 callstack
@@ -14,11 +15,9 @@ kernel-internals math namespaces sequences ;
 : cs-reg R15 ; inline
 : remainder-reg RDX ; inline
 
-: vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
-
 M: int-regs return-reg drop RAX ;
-
+M: int-regs vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
-M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
+M: int-regs fastcall-regs { RDI RSI RDX RCX R8 R9 } ;
 
 : compile-c-call ( symbol dll -- )
     2dup dlsym R10 swap MOV
@@ -29,9 +28,8 @@ M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
     swap [ MOV ] 2each compile-c-call ;
 
 M: float-regs return-reg drop XMM0 ;
-
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: float-regs fastcall-regs
+M: float-regs fastcall-regs vregs ;
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : address-operand ( address -- operand )
     #! On AMD64, we have to load 64-bit addresses into a

library/compiler/generator/architecture.factor

@@ -5,10 +5,16 @@ sequences ;
 ! A scratch register for computations
 TUPLE: vreg n ;
 
+C: vreg ( n reg-class -- vreg )
+    [ set-delegate ] keep [ set-vreg-n ] keep ;
+
 ! Register classes
 TUPLE: int-regs ;
 TUPLE: float-regs size ;
 
+: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
+
 ! A pseudo-register class for parameters spilled on the stack
 TUPLE: stack-params ;
 
@@ -19,7 +25,7 @@ GENERIC: return-reg ( register-class -- reg )
 GENERIC: fastcall-regs ( register-class -- regs )
 
 ! Sequence mapping vreg-n to native assembler registers
-DEFER: vregs ( -- regs )
+GENERIC: vregs ( register-class -- regs )
 
 ! Load a literal (immediate or indirect)
 G: load-literal ( obj vreg -- ) 1 standard-combination ;
@@ -105,9 +111,6 @@ M: float-regs inc-reg-class
     macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
 GENERIC: v>operand
-
 M: integer v>operand tag-bits shift ;
-
+M: vreg v>operand dup vreg-n swap vregs nth ;
-M: vreg v>operand vreg-n vregs nth ;
-
 M: f v>operand address ;

library/compiler/generator/generator.factor

@@ -140,12 +140,12 @@ M: #if generate-node ( node -- next )
 
 : if>boolean-intrinsic ( label -- )
     <label> "end" set
-    f T{ vreg f 0 } load-literal
+    f 0 <int-vreg> load-literal
     "end" get %jump-label
     save-xt
-    t T{ vreg f 0 } load-literal
+    t 0 <int-vreg> load-literal
     "end" get save-xt
-    T{ vreg f 0 } phantom-d get phantom-push ;
+    0 <int-vreg> phantom-d get phantom-push ;
 
 : do-if-intrinsic ( node -- next )
     [ <label> dup ] keep if-intrinsic call
@@ -194,7 +194,7 @@ UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
     >#push< dup length dup ensure-vregs
-    alloc-reg# [ <vreg> ] map
+    alloc-reg# [ <int-vreg> ] map
     [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 

library/compiler/generator/templates.factor

@@ -106,7 +106,7 @@ SYMBOL: phantom-r
     phantoms [ finalize-height ] 2apply ;
 
 : stack>vreg ( vreg# loc -- operand )
-    >r <vreg> dup r> %peek ;
+    >r <int-vreg> dup r> %peek ;
 
 : stack>new-vreg ( loc -- vreg )
     alloc-reg swap stack>vreg ;
@@ -157,7 +157,7 @@ SYMBOL: phantom-r
     phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
 : compute-free-vregs ( -- )
-    used-vregs vregs length reverse diff
+    used-vregs T{ int-regs } vregs length reverse diff
     >vector free-vregs set ;
 
 : additional-vregs# ( seq seq -- n )
@@ -257,7 +257,7 @@ SYMBOL: +clobber
     +input get { } additional-vregs# +scratch get length + ;
 
 : alloc-scratch ( -- )
-    +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+    +scratch get [ alloc-vregs [ <int-vreg> ] map ] keep
     phantom-vregs ;
 
 : template-inputs ( -- )

library/compiler/optimizer/class-infer.factor

@@ -10,7 +10,7 @@ kernel-internals math namespaces sequences words ;
     node-classes ?hash [ object ] unless* ;
 
 : node-class# ( node n -- class )
-    swap [ node-in-d reverse-slice nth ] keep node-class ;
+    swap [ node-in-d reverse-slice ?nth ] keep node-class ;
 
 ! Variables used by the class inferencer
 

library/compiler/ppc/architecture.factor

@@ -10,10 +10,9 @@ memory namespaces sequences words ;
 ! r14 data stack
 ! r15 call stack
 
-: vregs { 3 4 5 6 7 8 9 10 } ; inline
-
 M: int-regs return-reg drop 3 ;
 M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
@@ -163,7 +162,7 @@ M: stack-params freg>stack
     11 [ compile-dlsym ] keep MTLR BLRL ;
 
 : %alien-callback ( quot -- )
-    T{ vreg f 0 } load-literal "run_callback" f %alien-invoke ;
+    0 <int-vreg> load-literal "run_callback" f %alien-invoke ;
 
 : save-return 0 swap [ return-reg ] keep freg>stack ;
 : load-return 0 swap [ return-reg ] keep stack>freg ;

library/compiler/x86/alien.factor

@@ -63,7 +63,7 @@ M: float-regs load-return-reg
     drop-return-reg ;
 
 : %alien-callback ( quot -- )
-    T{ vreg f 0 } load-literal
+    0 <int-vreg> load-literal
     EAX PUSH
     "run_callback" f %alien-invoke
     EAX POP ;

library/compiler/x86/architecture.factor

@@ -5,20 +5,20 @@ math memory namespaces sequences words ;
 IN: compiler
 
 ! x86 register assignments
-! EAX, ECX, EDX vregs
+! EAX, ECX, EDX integer vregs
+! XMM0 - XMM7 float vregs
 ! ESI datastack
 ! EBX callstack
 
-! AMD64 redefines these four
+! AMD64 redefines a lot of words in this file
+
 : ds-reg ESI ; inline
 : cs-reg EBX ; inline
 : remainder-reg EDX ; inline
-: vregs { EAX ECX EDX } ; inline
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
 M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-
 M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 
 : %alien-invoke ( symbol dll -- )
@@ -32,8 +32,10 @@ M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs fastcall-regs drop { } ;
+M: int-regs vregs drop { EAX ECX EDX } ;
 
 M: float-regs fastcall-regs drop { } ;
+M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : address-operand ( address -- operand )
     #! On x86, we can always use an address as an operand

library/compiler/x86/intrinsics.factor

@@ -4,6 +4,7 @@ USING: alien arrays assembler kernel kernel-internals lists math
 math-internals namespaces sequences words ;
 IN: compiler
 
+! Type checks
 \ tag [
     "in" operand tag-mask AND
     "in" operand tag-bits SHL
@@ -48,6 +49,7 @@ IN: compiler
     { +output { "obj" } }
 } define-intrinsic
 
+! Slots
 : untag ( reg -- ) tag-mask bitnot AND ;
 
 \ slot [
@@ -114,7 +116,8 @@ IN: compiler
     { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
-: define-binary-op ( word op -- )
+! Fixnums
+: define-fixnum-op ( word op -- )
     [ [ "x" operand "y" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
@@ -127,7 +130,7 @@ IN: compiler
     { fixnum-bitor OR }
     { fixnum-bitxor XOR }
 } [
-    first2 define-binary-op
+    first2 define-fixnum-op
 ] each
 
 \ fixnum-bitnot [
@@ -241,7 +244,7 @@ IN: compiler
     { +clobber { "x" "y" } }
 } define-intrinsic
 
-: define-binary-jump ( word op -- )
+: define-fixnum-jump ( word op -- )
     [
         [ end-basic-block "x" operand "y" operand CMP ] % ,
     ] [ ] make H{
@@ -255,9 +258,10 @@ IN: compiler
     { fixnum>= JGE }
     { eq? JE }
 } [
-    first2 define-binary-jump
+    first2 define-fixnum-jump
 ] each
 
+! User environment
 : %userenv ( -- )
     "x" operand "userenv" f dlsym MOV
     0 rel-absolute-cell rel-userenv

library/test/compiler/callbacks.factor

@@ -1,6 +1,6 @@
 IN: temporary
-USING: alien compiler errors inference io kernel math memory
+USING: alien compiler errors inference io kernel kernel-internals
-namespaces test threads ;
+math memory namespaces test threads ;
 
 : callback-1 "void" { } [ ] alien-callback ; compiled