Compiler cleanups and bootstrap speedup

TODO.FACTOR.txt

@@ -1,5 +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
@@ -48,6 +49,7 @@ should fix in 0.82:
 
 + compiler/ffi:
 
+- free up r12 as a vreg on ppc
 - amd64 %box-struct
 - float= on powerpc doesn't consider nans equal
 - intrinsic fixnum>float float>fixnum

library/collections/sequence-eq.factor

@@ -13,7 +13,7 @@ UNION: sequence array string sbuf vector ;
         dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
     ] [
         2drop f
-    ] if ; inline
+    ] if ;
 
 M: sequence = ( obj seq -- ? )
     2dup eq? [

library/compiler/amd64/architecture.factor

@@ -16,28 +16,27 @@ math namespaces sequences ;
 : remainder-reg RDX ; inline
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 } ;
+M: int-regs vregs drop { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ;
 M: int-regs fastcall-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 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 vregs ;
 
+: address-operand ( address -- operand )
+    #! On AMD64, we have to load 64-bit addresses into a
+    #! scratch register first. The usage of R11 here is a hack.
+    #! This word can only be called right before a subroutine
+    #! call, where all vregs have been flushed anyway.
+    R11 [ swap MOV ] keep ; inline
+
 : compile-c-call ( symbol dll -- )
-    2dup dlsym R10 swap MOV rel-absolute-cell rel-dlsym
-    R10 CALL ;
+    2dup dlsym address-operand rel-absolute-cell rel-dlsym CALL ;
 
 : compile-c-call* ( symbol dll args -- )
     T{ int-regs } fastcall-regs
     swap [ MOV ] 2each compile-c-call ;
 
-: address-operand ( address -- operand )
-    #! On AMD64, we have to load 64-bit addresses into a
-    #! scratch register first. The usage of R11 here is a hack.
-    #! We cannot write '0 scratch' since scratch registers are
-    #! not permitted inside basic-block VOPs.
-    R11 [ swap MOV ] keep ; inline
-
 : fixnum>slot@ drop ; inline
 
 : prepare-division CQO ; inline

library/compiler/generator/templates.factor

@@ -102,9 +102,6 @@ SYMBOL: phantom-r
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
-: stack>new-vreg ( loc spec -- vreg )
-    spec>vreg [ swap %peek ] keep ;
-
 : vreg>stack ( value loc -- )
     over loc? over not or [ 2drop ] [ %replace ] if ;
 
@@ -118,17 +115,17 @@ SYMBOL: phantom-r
     [ first2 over loc? >r = not r> and ] subset
     [ first ] map ;
 
+: stack>new-vreg ( loc spec -- vreg )
+    spec>vreg [ swap %peek ] keep ;
+
 : live-locs ( phantom phantom -- hash )
     [ (live-locs) ] 2apply append prune
     [ dup f stack>new-vreg ] map>hash ;
 
 : lazy-store ( value loc -- )
     over loc? [
-        2dup = [
-            2drop
-        ] [
-            >r \ live-locs get hash r> vreg>stack 
-        ] if
+        2dup =
+        [ 2drop ] [ >r \ live-locs get hash r> vreg>stack ] if
     ] [
         2drop
     ] if ;

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-r10 integer vregs
+! r3-r11 integer vregs
 ! f0-f13 float vregs
-! r11 linkage
+! r12 linkage
 ! 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 } ;
+M: int-regs vregs drop { 3 4 5 6 7 8 9 10 11 } ;
 
 M: float-regs return-reg drop 1 ;
 M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
@@ -93,8 +93,8 @@ M: int-regs (%peek) ( vreg loc -- )
     drop >r v>operand r> loc>operand LWZ ;
 
 M: float-regs (%peek) ( vreg loc -- )
-    drop 11 swap loc>operand LWZ
-    v>operand 11 float-offset LFD ;
+    drop fp-scratch v>operand swap loc>operand LWZ
+    fp-scratch [ v>operand ] 2apply float-offset LFD ;
 
 M: int-regs (%replace) ( vreg loc -- )
     drop >r v>operand r> loc>operand STW ;
@@ -108,24 +108,24 @@ M: int-regs (%replace) ( vreg loc -- )
 : load-zone-ptr ( reg -- )
     "generations" f pick compile-dlsym dup 0 LWZ ;
 
-: load-allot-ptr ( -- ) 12 load-zone-ptr 12 12 cell LWZ ;
+: load-allot-ptr ( -- )
+    12 load-zone-ptr 12 12 cell LWZ ;
 
-: save-allot-ptr ( -- ) 11 load-zone-ptr 12 11 cell STW ;
+: save-allot-ptr ( -- )
+    fp-scratch v>operand [ load-zone-ptr 12 ] keep cell STW ;
 
-: with-inline-alloc ( vreg prequot postquot spec -- )
-    #! both quotations are called with the vreg
+: with-inline-alloc ( prequot postquot spec -- )
     load-allot-ptr [
-        >r >r v>operand dup 12 MR
-        \ tag-header get call tag-header 11 LI
-        11 12 0 STW
-        r> over slip dup dup \ tag get call ORI
+        \ tag-header get call tag-header fp-scratch v>operand LI
+        fp-scratch v>operand 12 0 STW
+        >r call 12 fp-scratch v>operand \ 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
-    [ >r v>operand r> 8 STFD ]
-    [ swap loc>operand STW ] H{
+    drop swap
+    [ v>operand 12 8 STFD ]
+    [ fp-scratch v>operand swap loc>operand STW ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
@@ -189,7 +189,7 @@ M: stack-params %freg>stack
     "box_value_struct" struct-ptr/size ;
 
 : %alien-invoke ( symbol dll -- )
-    11 [ compile-dlsym ] keep MTLR BLRL ;
+    12 [ compile-dlsym ] keep MTLR BLRL ;
 
 : %alien-callback ( quot -- )
     0 <int-vreg> load-literal "run_callback" f %alien-invoke ;

library/compiler/ppc/intrinsics.factor

@@ -167,19 +167,19 @@ math-internals namespaces sequences words ;
     <label> "end" set
     "r" operand "x" operand untag-fixnum
     0 MTXER
-    11 "y" operand "r" operand MULLWO.
+    12 "y" operand "r" operand MULLWO.
     "end" get BNO
     4 "y" operand "r" operand MULHW
-    3 11 MR
+    3 12 MR
     "s48_fixnum_pair_to_bignum" f %alien-invoke
     ! now we have to shift it by three bits to remove the second
     ! tag
     tag-bits neg 4 LI
     "s48_bignum_arithmetic_shift" f %alien-invoke
     ! An untagged pointer to the bignum is now in r3; tag it
-    3 11 bignum-tag ORI
+    3 12 bignum-tag ORI
     "end" get save-xt
-    "s" operand 11 MR
+    "s" operand 12 MR
 ] H{
     { +input { { f "x" } { f "y" } } }
     { +scratch { { f "r" } { f "s" } } }

library/generic/generic.factor

@@ -51,7 +51,7 @@ DEFER: (class<)
     >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
 
 : union-class< ( cls1 cls2 -- ? )
-    >r flatten-class r> flatten-class hash-keys swap
+    [ flatten-class ] 2apply hash-keys swap
     [ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
 
 : class-empty? ( class -- ? )

library/generic/tuple.factor

@@ -16,7 +16,7 @@ IN: kernel-internals
         [ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
     ] [
         2drop f
-    ] if ; inline
+    ] if ;
 
 : tuple-hashcode ( n tuple -- n )
     dup class-tuple hashcode >r >r 1-