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
+ 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
: 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* ;
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 -- )
: 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 ;
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
: 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* ;
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
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 ? + ;
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
: %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 ;
+
+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 ;
-: %replace ( vreg loc -- ) >r v>operand r> loc>operand STW ;
+: 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 ;
M: stack-params freg>stack
>r stack-increment + swap r> stack>freg ;
-: (%move) [ fastcall-regs nth ] keep ;
-
-: %stack>freg ( n reg reg-class -- ) (%move) stack>freg ;
+: %stack>freg ( n reg reg-class -- )
+ [ fastcall-regs nth ] keep 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
: %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 ;
: 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 ;
: 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
: 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. ;
>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 ;
: 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
{ +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" } }
{ fixnum-bitor OR }
{ fixnum-bitxor XOR }
} [
- first2 define-binary-op
+ first2 define-fixnum-op
] each
: generate-fixnum-mod
{ +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" } } } }
{ 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
{ +clobber { "x" "y" } }
} define-intrinsic
-: ?MR 2dup = [ 2drop ] [ MR ] if ;
-
\ fixnum* [
finalize-contents
<label> "end" set
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
{ +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 ;
: %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) ;
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
: 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 ;
: 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
] 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 -- )
+++ /dev/null
-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
: 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 -- )
projects / factor.git / commitdiff