fp-scratch cleanup

TODO.FACTOR.txt

@@ -1,7 +1,6 @@
 should fix in 0.82:
 
 - another i/o bug: on factorcode eventually all i/o times out
-- clean up fp-scratch
 - update amd64 backend
 - when generating a 32-bit image on a 64-bit system, large numbers which should
   be bignums become fixnums

library/compiler/generator/generator.factor

@@ -194,9 +194,9 @@ M: #dispatch generate-node ( node -- next )
 UNION: immediate fixnum POSTPONE: f ;
 
 : generate-push ( node -- )
-    >#push< dup length f <array>
+    >#push<
-    dup requested-vregs ensure-vregs
+    dup length ?fp-scratch + 0 ensure-vregs
-    [ spec>vreg [ load-literal ] keep ] 2map
+    [ f spec>vreg [ load-literal ] keep ] map
     phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )

library/compiler/generator/templates.factor

@@ -242,13 +242,6 @@ SYMBOL: +clobber
 : requested-vregs ( template -- int# float# )
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
-: (holds-class?) ( class phantom -- ? )
-    [ delegate class eq? ] contains-with? ;
-
-: holds-class? ( class -- ? )
-    dup phantom-d get (holds-class?) swap
-    phantom-r get (holds-class?) or ;
-
 : (requests-class?) ( class template -- )
     [ second reg-spec>class eq? ] contains-with? ;
 
@@ -257,8 +250,7 @@ SYMBOL: +clobber
     +scratch get (requests-class?) or ;
 
 : ?fp-scratch ( -- n )
-    T{ float-regs f 8 } dup holds-class? >r requests-class? r>
+    T{ float-regs f 8 } requests-class? 1 0 ? ;
-    or 1 0 ? ;
 
 : fp-scratch ( -- vreg )
     "fp-scratch" get [

library/compiler/ppc/architecture.factor

@@ -5,15 +5,15 @@ USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
 
 ! PowerPC register assignments
-! r3-r11 integer vregs
+! r3-r10 integer vregs
 ! f0-f13 float vregs
-! r12 linkage
+! r11, r12 scratch
 ! r14 data stack
 ! r15 call stack
 
 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 11 } ;
+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 } ;
@@ -112,20 +112,20 @@ M: int-regs (%replace) ( vreg loc -- )
     12 load-zone-ptr 12 12 cell LWZ ;
 
 : save-allot-ptr ( -- )
-    fp-scratch v>operand [ load-zone-ptr 12 ] keep cell STW ;
+    11 [ load-zone-ptr 12 ] keep cell STW ;
 
 : with-inline-alloc ( prequot postquot spec -- )
     load-allot-ptr [
-        \ tag-header get call tag-header fp-scratch v>operand LI
+        \ tag-header get call tag-header 11 LI
-        fp-scratch v>operand 12 0 STW
+        11 12 0 STW
-        >r call 12 fp-scratch v>operand \ tag get call ORI
+        >r call 12 11 \ tag get call ORI
         r> call 12 12 \ size get call ADDI
     ] bind save-allot-ptr ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop swap fp-scratch drop
+    drop swap
     [ v>operand 12 8 STFD ]
-    [ fp-scratch v>operand swap loc>operand STW ] H{
+    [ 11 swap loc>operand STW ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }

library/compiler/x86/intrinsics-sse2.factor

@@ -20,19 +20,21 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 : inc-allot-ptr ( vreg n -- )
     >r dup load-zone-ptr cell [+] r> ADD ;
 
-: with-inline-alloc ( vreg prequot postquot spec -- )
+: with-inline-alloc ( prequot postquot spec -- )
     #! both quotations are called with the vreg
     [
-        >r >r v>operand dup load-allot-ptr
+        EBX PUSH
-        dup [] \ tag-header get call tag-header MOV
+        EBX load-allot-ptr
-        r> over slip dup \ tag get call OR
+        EBX [] \ tag-header get call tag-header MOV
-        r> over slip \ size get call inc-allot-ptr
+        >r call EBX \ tag get call OR
+        r> call EBX \ size get call inc-allot-ptr
+        EBX POP
     ] bind ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop fp-scratch
+    drop
-    [ 8 [+] rot v>operand MOVSD ]
+    [ EBX 8 [+] rot v>operand MOVSD ]
-    [ >r v>operand r> MOV ] H{
+    [ v>operand EBX MOV ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }