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
+ 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
dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
] [
2drop f
- ] if ; inline
+ ] if ;
M: sequence = ( obj seq -- ? )
2dup eq? [
: 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
: 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 ;
[ 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 ;
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 } ;
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 ;
: 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 ] }
"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 ;
<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" } } }
>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 -- ? )
[ 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-