Floating point intrinsics for PowerPC

TODO.FACTOR.txt

@@ -1,7 +1,8 @@
 should fix in 0.82:
 
-- clean up/rewrite register allocation
+- clean up fp-scratch
 - intrinsic fixnum>float float>fixnum
+- update amd64 backend
 
 - amd64 %box-struct
 - when generating a 32-bit image on a 64-bit system, large numbers which should
@@ -10,6 +11,7 @@ should fix in 0.82:
 
 + io:
 
+- gdb triggers 'mutliple i/o ops on port' error
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - yield in a loop starves i/o

library/bootstrap/boot-stage1.factor

@@ -12,8 +12,7 @@ vectors words ;
 : parse-resource* ( path -- )
     [ parse-resource ] catch [
         dup error.
-        "Try again? [yn]" print
-        readln "yY" subseq?
+        "Try again? [yn]" print flush readln "yY" subseq?
         [ drop parse-resource* ] [ rethrow ] if
     ] when* ;
 

library/compiler/generator/architecture.factor

@@ -64,10 +64,12 @@ DEFER: %inc-d ( n -- )
 DEFER: %inc-r ( n -- )
 
 ! Load stack into vreg
-DEFER: %peek ( vreg loc -- )
+GENERIC: (%peek) ( vreg loc reg-class -- )
+: %peek ( vreg loc -- ) over (%peek) ;
 
 ! Store vreg to stack
-DEFER: %replace ( vreg loc -- )
+GENERIC: (%replace) ( vreg loc reg-class -- )
+: %replace ( vreg loc -- ) over (%replace) ;
 
 ! Move one vreg to another
 DEFER: %move-int>int ( dst src -- )

library/compiler/generator/generator.factor

@@ -196,9 +196,8 @@ UNION: immediate fixnum POSTPONE: f ;
 : generate-push ( node -- )
     >#push< dup length f <array>
     dup requested-vregs ensure-vregs
-    alloc-vregs [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append
-    "fp-scratch" off ;
+    [ spec>vreg [ load-literal ] keep ] 2map
+    phantom-d get phantom-append ;
 
 M: #push generate-node ( #push -- )
     generate-push iterate-next ;
@@ -221,7 +220,7 @@ M: #push generate-node ( #push -- )
     shuffle-in-r length neg phantom-r get adjust-phantom ;
 
 : shuffle-vregs# ( shuffle -- n )
-    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
+    dup shuffle-in-d swap shuffle-in-r additional-vregs ;
 
 : phantom-shuffle ( shuffle -- )
     dup shuffle-vregs# 0 ensure-vregs
@@ -241,3 +240,8 @@ M: #return generate-node drop end-basic-block %return f ;
 
 : float-offset 8 float-tag - ;
 : string-offset 3 cells object-tag - ;
+
+: fp-scratch ( -- vreg )
+    "fp-scratch" get [
+        T{ int-regs } alloc-reg dup "fp-scratch" set
+    ] unless* ;

library/compiler/ppc/architecture.factor

@@ -5,7 +5,8 @@ USING: alien assembler generic kernel kernel-internals math
 memory namespaces sequences words ;
 
 ! PowerPC register assignments
-! r3-r10 vregs
+! r3-r10 integer vregs
+! f0-f13 float vregs
 ! r11 linkage
 ! r14 data stack
 ! r15 call stack
@@ -16,6 +17,7 @@ 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 } ;
+M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
 ! Mach-O -vs- Linux/PPC
 : stack@ macosx? 24 8 ? + ;
@@ -27,7 +29,7 @@ M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
 
 M: immediate load-literal ( literal vreg -- )
-    >r address r> v>operand LOAD ;
+    [ v>operand ] 2apply LOAD ;
 
 M: object load-literal ( literal vreg -- )
     v>operand swap
@@ -84,9 +86,50 @@ M: object load-literal ( literal vreg -- )
 
 : %return ( -- ) %epilogue BLR ;
 
-: %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
+: compile-dlsym ( symbol dll register -- )
+    >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
 
-: %replace ( vreg loc -- ) >r v>operand r> loc>operand STW ;
+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 ;
+
+M: int-regs (%replace) ( vreg loc -- )
+    drop >r v>operand r> loc>operand STW ;
+
+: %move-int>int ( dst src -- )
+    [ v>operand ] 2apply MR ;
+
+: %move-int>float ( dst src -- )
+    [ v>operand ] 2apply float-offset LFD ;
+
+: load-zone-ptr ( reg -- )
+    "generations" f pick compile-dlsym dup 0 LWZ ;
+
+: load-allot-ptr ( -- ) 12 load-zone-ptr 12 12 cell LWZ ;
+
+: save-allot-ptr ( -- ) 11 load-zone-ptr 12 11 cell STW ;
+
+: with-inline-alloc ( vreg prequot postquot spec -- )
+    #! both quotations are called with the vreg
+    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
+        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{
+        { tag-header [ float-tag ] }
+        { tag [ float-tag ] }
+        { size [ 16 ] }
+    } with-inline-alloc ;
 
 : %inc-d ( n -- ) 14 14 rot cells ADDI ;
 
@@ -118,11 +161,11 @@ M: stack-params stack>freg
 M: stack-params freg>stack
    >r stack-increment + swap r> stack>freg ;
 
-: (%move) [ fastcall-regs nth ] keep ;
+: %stack>freg ( n reg reg-class -- )
+    [ fastcall-regs nth ] keep stack>freg ;
 
-: %stack>freg ( n reg reg-class -- ) (%move) stack>freg ;
-
-: %freg>stack ( n reg reg-class -- ) (%move) freg>stack ;
+: %freg>stack ( n reg reg-class -- )
+    [ fastcall-regs nth ] keep freg>stack ;
 
 : %unbox ( n reg-class func -- )
     ! Call the unboxer
@@ -155,9 +198,6 @@ M: stack-params freg>stack
 : %box-struct ( n reg-class size -- )
     "box_value_struct" struct-ptr/size ;
 
-: compile-dlsym ( symbol dll register -- )
-    >r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
-
 : %alien-invoke ( symbol dll -- )
     11 [ compile-dlsym ] keep MTLR BLRL ;
 

library/compiler/ppc/assembler.factor

@@ -16,6 +16,10 @@ USING: compiler errors generic kernel math memory words ;
 
 : insn ( operand opcode -- ) 26 shift bitor assemble-cell ;
 
+: a-form ( d a b c xo rc -- n )
+    >r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
+    r> bitor r> bitor r> bitor r> bitor r> bitor ;
+
 : b-form ( bo bi bd aa lk -- n )
     >r 1 shift >r 2 shift >r 16 shift >r 21 shift
     r> bitor r> bitor r> bitor r> bitor ;
@@ -26,10 +30,6 @@ USING: compiler errors generic kernel math memory words ;
 : i-form ( li aa lk -- n )
     >r 1 shift bitor r> bitor ;
 
-: m-form ( s a b mb me -- n )
-    >r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
-    r> bitor r> bitor r> bitor r> bitor r> bitor ;
-
 : x-form ( a s b xo rc -- n )
     swap
     >r 1 shift >r 11 shift >r swap 16 shift >r 21 shift
@@ -144,7 +144,7 @@ USING: compiler errors generic kernel math memory words ;
 : CMP 0 0 x-form 31 insn ;
 : CMPL 0 32 x-form 31 insn ;
 
-: (RLWINM) m-form 21 insn ;
+: (RLWINM) a-form 21 insn ;
 : RLWINM 0 (RLWINM) ;  : RLWINM. 1 (RLWINM) ;
 
 : SLWI 0 31 pick - RLWINM ;  : SLWI. 0 31 pick - RLWINM. ;
@@ -193,10 +193,31 @@ M: word BC >r 0 BC r> relative-2 ;
    >r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
 
 ! Floating point
-: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
-: FMR 0 (FMR) ;  : FMR. 1 (FMR) ;
-
 : LFS d-form 48 insn ;  : LFSU d-form 49 insn ;
 : LFD d-form 50 insn ;  : LFDU d-form 51 insn ;
 : STFS d-form 52 insn ; : STFSU d-form 53 insn ;
 : STFD d-form 54 insn ; : STFDU d-form 55 insn ;
+
+: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
+: FMR 0 (FMR) ;  : FMR. 1 (FMR) ;
+
+: (FCTIWZ) >r 0 -rot 15 r> x-form 63 insn ;
+: FCTIWZ 0 (FCTIWZ) ;  : FCTIWZ. 1 (FCTIWZ) ;
+
+: (FADD) >r 0 21 r> a-form 63 insn ;
+: FADD 0 (FADD) ;  : FADD. 1 (FADD) ;
+
+: (FSUB) >r 0 20 r> a-form 63 insn ;
+: FSUB 0 (FSUB) ;  : FSUB. 1 (FSUB) ;
+
+: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
+: FMUL 0 (FMUL) ;  : FMUL. 1 (FMUL) ;
+
+: (FDIV) >r 0 18 r> a-form 63 insn ;
+: FDIV 0 (FDIV) ;  : FDIV. 1 (FDIV) ;
+
+: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
+: FSQRT 0 (FSQRT) ;  : FSQRT. 1 (FSQRT) ;
+
+: FCMPU 0 0 x-form 63 insn ;
+: FCMPO 0 32 x-form 63 insn ;

library/compiler/ppc/intrinsics.factor

@@ -10,15 +10,6 @@ math-internals namespaces sequences words ;
 
 : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
 
-\ tag [
-    "in" operand "out" operand tag-mask ANDI
-    "out" operand dup tag-fixnum
-] H{
-    { +input { { f "in" } } }
-    { +scratch { { f "out" } } }
-    { +output { "out" } }
-} define-intrinsic
-
 : generate-slot ( size quot -- )
     >r >r
     ! turn tagged fixnum slot # into an offset, multiple of 4
@@ -80,7 +71,7 @@ math-internals namespaces sequences words ;
     { +clobber { "val" "slot" "obj" } }
 } define-intrinsic
 
-: define-binary-op ( word op -- )
+: define-fixnum-op ( word op -- )
     [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
@@ -93,7 +84,7 @@ math-internals namespaces sequences words ;
     { fixnum-bitor OR }
     { fixnum-bitxor XOR }
 } [
-    first2 define-binary-op
+    first2 define-fixnum-op
 ] each
 
 : generate-fixnum-mod
@@ -120,7 +111,7 @@ math-internals namespaces sequences words ;
     { +output { "x" } }
 } define-intrinsic
 
-: define-binary-jump ( word op -- )
+: define-fixnum-jump ( word op -- )
     [
         [ end-basic-block "x" operand 0 "y" operand CMP ] % ,
      ] [ ] make H{ { +input { { f "x" } { f "y" } } } }
@@ -133,38 +124,9 @@ math-internals namespaces sequences words ;
     { fixnum>= BGE }
     { eq? BEQ }
 } [
-    first2 define-binary-jump
+    first2 define-fixnum-jump
 ] each
 
-\ type [
-    <label> "f" set
-    <label> "end" set
-    ! Get the tag
-    "obj" operand "y" operand tag-mask ANDI
-    ! Tag the tag
-    "y" operand "x" operand tag-fixnum
-    ! Compare with object tag number (3).
-    0 "y" operand object-tag CMPI
-    ! Jump if the object doesn't store type info in its header
-    "end" get BNE
-    ! It does store type info in its header
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 "obj" operand object-tag CMPI
-    "f" get BEQ
-    ! The pointer is not equal to 3. Load the object header.
-    "x" operand "obj" operand object-tag neg LWZ
-    "x" operand dup untag
-    "end" get B
-    "f" get save-xt
-    ! The pointer is equal to 3. Load F_TYPE (9).
-    f type tag-bits shift "x" operand LI
-    "end" get save-xt
-] H{
-    { +input { { f "obj" } } }
-    { +scratch { { f "x" } { f "y" } } }
-    { +output { "x" } }
-} define-intrinsic
-
 : simple-overflow ( word -- )
     >r
     <label> "end" set
@@ -200,8 +162,6 @@ math-internals namespaces sequences words ;
     { +clobber { "x" "y" } }
 } define-intrinsic
 
-: ?MR 2dup = [ 2drop ] [ MR ] if ;
-
 \ fixnum* [
     finalize-contents
     <label> "end" set
@@ -210,7 +170,7 @@ math-internals namespaces sequences words ;
     11 "y" operand "r" operand MULLWO.
     "end" get BNO
     4 "y" operand "r" operand MULHW
-    3 11 ?MR
+    3 11 MR
     "s48_fixnum_pair_to_bignum" f %alien-invoke
     ! now we have to shift it by three bits to remove the second
     ! tag
@@ -275,6 +235,75 @@ math-internals namespaces sequences words ;
     { +clobber { "y" } }
 } define-intrinsic
 
+: define-float-op ( word op -- )
+    [ [ "x" operand "x" operand "y" operand ] % , ] [ ] make H{
+        { +input { { float "x" } { float "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
+
+{
+    { float+ FADD }
+    { float- FSUB }
+    { float* FMUL }
+    { float/f FDIV }
+} [
+    first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand 0 "y" operand FCMPU ] % ,
+     ] [ ] make H{ { +input { { float "x" } { float "y" } } } }
+    define-if-intrinsic ;
+
+{
+    { float< BLT }
+    { float<= BLE }
+    { float> BGT }
+    { float>= BGE }
+    { float= BEQ }
+} [
+    first2 define-float-jump
+] each
+
+\ tag [
+    "in" operand "out" operand tag-mask ANDI
+    "out" operand dup tag-fixnum
+] H{
+    { +input { { f "in" } } }
+    { +scratch { { f "out" } } }
+    { +output { "out" } }
+} define-intrinsic
+
+\ type [
+    <label> "f" set
+    <label> "end" set
+    ! Get the tag
+    "obj" operand "y" operand tag-mask ANDI
+    ! Tag the tag
+    "y" operand "x" operand tag-fixnum
+    ! Compare with object tag number (3).
+    0 "y" operand object-tag CMPI
+    ! Jump if the object doesn't store type info in its header
+    "end" get BNE
+    ! It does store type info in its header
+    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+    0 "obj" operand object-tag CMPI
+    "f" get BEQ
+    ! The pointer is not equal to 3. Load the object header.
+    "x" operand "obj" operand object-tag neg LWZ
+    "x" operand dup untag
+    "end" get B
+    "f" get save-xt
+    ! The pointer is equal to 3. Load F_TYPE (9).
+    f type tag-bits shift "x" operand LI
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "x" } }
+} define-intrinsic
+
 : userenv ( reg -- )
     #! Load the userenv pointer in a register.
     "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;

library/compiler/x86/architecture.factor

@@ -91,18 +91,10 @@ M: object load-literal ( literal vreg -- )
 : %move-int>float ( dst src -- )
     [ v>operand ] 2apply float-offset [+] MOVSD ;
 
-GENERIC: (%peek) ( vreg loc reg-class -- )
-
 M: int-regs (%peek) drop %move-int>int ;
 
-: %peek ( vreg loc -- ) over (%peek) ;
-
-GENERIC: (%replace) ( vreg loc reg-class -- )
-
 M: int-regs (%replace) drop swap %move-int>int ;
 
-: %replace ( vreg loc -- ) over (%replace) ;
-
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 : %inc-d ( n -- ) ds-reg (%inc) ;

library/compiler/x86/intrinsics-sse2.factor

@@ -4,11 +4,6 @@ USING: alien arrays assembler generic kernel kernel-internals
 lists math math-internals memory namespaces sequences words ;
 IN: compiler
 
-: fp-scratch ( -- vreg )
-    "fp-scratch" get [
-        T{ int-regs } alloc-reg dup "fp-scratch" set
-    ] unless* ;
-
 M: float-regs (%peek) ( vreg loc reg-class -- )
     drop
     fp-scratch swap %move-int>int
@@ -16,7 +11,7 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
 
 : load-zone-ptr ( vreg -- )
     #! Load pointer to start of zone array
-    "generations" f dlsym [] MOV ;
+    "generations" f 2dup dlsym [] MOV rel-dlsym ;
 
 : load-allot-ptr ( vreg -- )
     dup load-zone-ptr dup cell [+] MOV ;
@@ -24,9 +19,9 @@ 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 spec prequot postquot -- )
+: with-inline-alloc ( vreg prequot postquot spec -- )
     #! both quotations are called with the vreg
-    rot [
+    [
         >r >r v>operand dup load-allot-ptr
         dup [] \ tag-header get call tag-header MOV
         r> over slip dup \ tag get call OR
@@ -34,12 +29,13 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
     ] bind ; inline
 
 M: float-regs (%replace) ( vreg loc reg-class -- )
-    drop fp-scratch H{
+    drop fp-scratch
+    [ 8 [+] rot v>operand MOVSD ]
+    [ >r v>operand r> MOV ] H{
         { tag-header [ float-tag ] }
         { tag [ float-tag ] }
         { size [ 16 ] }
-    } [ 8 [+] rot v>operand MOVSD ]
-    [ >r v>operand r> MOV ] with-inline-alloc ;
+    } with-inline-alloc ;
 
 ! Floats
 : define-float-op ( word op -- )

library/test/compiler/assembler-x86.factor

@@ -1,9 +0,0 @@
-IN: temporary
-USING: assembler kernel test ;
-
-[ t ] [ { EBP } indirect? >boolean ] unit-test
-[ { EBP 0 } ] [ { EBP } canonicalize ] unit-test
-[ t ] [ { EAX 3 } displaced? >boolean ] unit-test
-[ { EAX } ] [ { EAX 0 } canonicalize ] unit-test
-[ { EAX } ] [ { EAX } canonicalize ] unit-test
-[ { EAX 3 } ] [ { EAX 3 } canonicalize ] unit-test

library/unix/io.factor

@@ -104,7 +104,7 @@ GENERIC: task-container ( task -- vector )
 : add-io-task ( callback task -- )
     [ >r <queue> [ enque ] keep r> set-io-task-callbacks ] keep
     dup io-task-fd over task-container 2dup hash [
-        "Cannot perform multiple I/O ops on the same port" throw
+        "Cannot perform multiple reads from the same port" throw
     ] when set-hash ;
 
 : remove-io-task ( task -- )