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
UNION: immediate fixnum POSTPONE: f ;
: generate-push ( node -- )
- >#push< dup length f <array>
- dup requested-vregs ensure-vregs
- [ spec>vreg [ load-literal ] keep ] 2map
+ >#push<
+ dup length ?fp-scratch + 0 ensure-vregs
+ [ f spec>vreg [ load-literal ] keep ] map
phantom-d get phantom-append ;
M: #push generate-node ( #push -- )
: 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? ;
+scratch get (requests-class?) or ;
: ?fp-scratch ( -- n )
- T{ float-regs f 8 } dup holds-class? >r requests-class? r>
- or 1 0 ? ;
+ T{ float-regs f 8 } requests-class? 1 0 ? ;
: fp-scratch ( -- vreg )
"fp-scratch" get [
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 } ;
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
- fp-scratch v>operand 12 0 STW
- >r call 12 fp-scratch v>operand \ tag get call ORI
+ \ tag-header get call tag-header 11 LI
+ 11 12 0 STW
+ >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 ] }
: 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
- dup [] \ tag-header get call tag-header MOV
- r> over slip dup \ tag get call OR
- r> over slip \ size get call inc-allot-ptr
+ EBX PUSH
+ EBX load-allot-ptr
+ EBX [] \ tag-header get call tag-header MOV
+ >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
- [ 8 [+] rot v>operand MOVSD ]
- [ >r v>operand r> MOV ] H{
+ drop
+ [ EBX 8 [+] rot v>operand MOVSD ]
+ [ v>operand EBX MOV ] H{
{ tag-header [ float-tag ] }
{ tag [ float-tag ] }
{ size [ 16 ] }