steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

First cut at bignum inline allocators

slava 2006-11-07 05:22:34 +00:00
parent 7642d69352
commit d54e3baac8
13 changed files with 154 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -6,6 +6,8 @@
- intrinsic fixnum>float float>fixnum
- amd64 structs-by-value bug
- callback scheduling issue
- sometimes fep when closing window
- %allot-bignum-signed-2: handle carry in negation
+ ui:

2
library/compiler/generator/generator.factor
View File

@ -113,7 +113,7 @@ M: #if generate-node
"end" get %jump-label
resolve-label
t 0 <int-vreg> load-literal
"end" get resolve-label
"end" resolve-label
0 <int-vreg> phantom-d get phantom-push
compute-free-vregs ;

3
library/compiler/generator/templates.factor
View File

@ -277,3 +277,6 @@ SYMBOL: +clobber+
compute-free-vregs ; inline
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline

3
library/compiler/generator/xt.factor
View File

@ -15,7 +15,8 @@ C: label ( -- label ) ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label -- )
: resolve-label ( label/name -- )
dup string? [ get ] when
compiled-offset swap set-label-offset ;
SYMBOL: compiled-xts

84
library/compiler/ppc/allot.factor Normal file
View File

@ -0,0 +1,84 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: kernel assembler kernel-internals namespaces math ;
: load-zone-ptr ( reg -- )
"generations" f pick compile-dlsym dup 0 LWZ ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
#! nursery in r11.
8 align ! align the size
12 load-zone-ptr ! nusery -> r12
11 12 cell LWZ ! nursery.here -> r11
11 11 pick ADDI ! increment r11
11 12 cell STW ! r11 -> nursery.here
11 11 rot SUBI ! old value
tag-header 12 LI ! compute header
12 11 0 STW ! store header
;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float-tag 16 %allot
11 8 STFD
11 12 float-tag ORI ;
M: float-regs (%replace)
drop
swap v>operand %allot-float
12 swap loc>operand STW ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
bignum-tag over 3 + cells %allot
1 + tag-bits shift 12 LI ! compute the length
12 11 cell STW ! store the length
;
: %allot-bignum-signed-1 ( reg -- )
#! on entry, reg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in reg
[
"end" define-label
"pos" define-label
1 %allot-bignum
0 over 0 CMPI ! is the fixnum negative?
"pos" get BGE
1 12 LI
12 11 2 cells STW ! store negative sign
dup dup -1 MULI ! negate fixnum
"end" get B
"pos" resolve-label
0 12 LI
12 11 2 cells STW ! store positive sign
"end" resolve-label
dup 11 3 cells STW ! store the number
11 swap bignum-tag ORI ! tag the bignum, store it in reg
] with-scope ;
: %allot-bignum-signed-2 ( reg1 reg2 -- )
#! on entry, reg1 and reg2 together form a signed 64-bit
#! quantity.
#! exits with tagged ptr to bignum in reg1
[
"end" define-label
"pos" define-label
2 %allot-bignum
0 pick 0 CMPI ! is the 64-bit quantity negative?
"pos" get BGE
1 12 LI
12 11 2 cells STW ! store negative sign
over dup NOT ! negate 64-bit quanity
dup dup -1 MULI
"end" get B
"pos" resolve-label
0 12 LI
12 11 2 cells STW ! store positive sign
"end" resolve-label
11 3 cells STW ! store the number
dup 11 4 cells STW
11 swap bignum-tag ORI ! tag the bignum, store it in reg
] with-scope ;

32
library/compiler/ppc/architecture.factor
View File

@ -107,32 +107,6 @@ M: int-regs (%replace)
: %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 ] keep cell STW ;
: with-inline-alloc ( prequot postquot spec -- )
load-allot-ptr [
\ 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)
drop swap
[ v>operand 12 8 STFD ]
[ 11 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 ;
: %inc-r ( n -- ) 15 15 rot cells ADDI ;
@ -219,3 +193,9 @@ M: stack-params %freg>stack
load-return ;
: %cleanup ( n -- ) drop ;
: %untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
: %tag-fixnum ( src dest -- ) tag-bits SLWI ;
: %untag-fixnum ( src dest -- ) tag-bits SRAWI ;

2
library/compiler/ppc/assembler.factor
View File

@ -51,6 +51,8 @@ words ;
: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
: MULI d-form 7 insn ;
: (ADD) 266 xo-form 31 insn ;
: ADD 0 0 (ADD) ; : ADD. 0 1 (ADD) ;
: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;

86
library/compiler/ppc/intrinsics.factor
View File

@ -4,12 +4,6 @@ IN: compiler
USING: alien assembler kernel kernel-internals math
math-internals namespaces sequences words ;
: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
: tag-fixnum ( src dest -- ) tag-bits SLWI ;
: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
: generate-slot ( size quot -- )
>r >r
! turn tagged fixnum slot # into an offset, multiple of 4
@ -20,7 +14,7 @@ math-internals namespaces sequences words ;
"obj" operand dup r> call ; inline
\ slot [
"obj" operand dup untag
"obj" operand dup %untag
cell log2 [ 0 LWZ ] generate-slot
] H{
{ +input+ { { f "obj" } { f "n" } } }
@ -29,7 +23,7 @@ math-internals namespaces sequences words ;
\ char-slot [
1 [ string-offset LHZ ] generate-slot
"obj" operand dup tag-fixnum
"obj" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +output+ { "obj" } }
@ -53,7 +47,7 @@ math-internals namespaces sequences words ;
"x" operand "obj" operand 0 STB ;
\ set-slot [
"obj" operand dup untag
"obj" operand dup %untag
cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
] H{
{ +input+ { { f "val" } { f "obj" } { f "slot" } } }
@ -63,7 +57,7 @@ math-internals namespaces sequences words ;
\ set-char-slot [
! untag the new value in 0th input
"val" operand dup untag-fixnum
"val" operand dup %untag-fixnum
1 [ string-offset STH ] generate-set-slot
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
@ -105,7 +99,7 @@ math-internals namespaces sequences words ;
\ fixnum-bitnot [
"x" operand dup NOT
"x" operand dup untag
"x" operand dup %untag
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
@ -128,18 +122,17 @@ math-internals namespaces sequences words ;
] each
: simple-overflow ( word -- )
>r
"end" define-label
"end" get BNO
{ "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
3 "y" operand "x" operand r> execute
"s48_long_to_bignum" f %alien-invoke
! An untagged pointer to the bignum is now in r3; tag it
3 "r" operand bignum-tag ORI
"end" get resolve-label ; inline
[
>r
"end" define-label
"end" get BNO
{ "x" "y" } [ dup %untag-fixnum ] unique-operands
"r" operand "y" operand "x" operand r> execute
"r" operand %allot-bignum-signed-1
"end" resolve-label
] with-scope ; inline
\ fixnum+ [
finalize-contents
0 MTXER
"r" operand "y" operand "x" operand ADDO.
\ ADD simple-overflow
@ -151,7 +144,6 @@ math-internals namespaces sequences words ;
} define-intrinsic
\ fixnum- [
finalize-contents
0 MTXER
"r" operand "y" operand "x" operand SUBFO.
\ SUBF simple-overflow
@ -163,23 +155,16 @@ math-internals namespaces sequences words ;
} define-intrinsic
\ fixnum* [
finalize-contents
"end" define-label
"r" operand "x" operand untag-fixnum
"r" operand "x" operand %untag-fixnum
0 MTXER
12 "y" operand "r" operand MULLWO.
"s" operand "y" operand "r" operand MULLWO.
"end" get BNO
4 "y" operand "r" operand MULHW
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 12 bignum-tag ORI
"end" get resolve-label
"s" operand 12 MR
"s" operand "y" operand %untag-fixnum
"x" operand "s" operand "r" operand MULLWO.
"s" operand "s" operand "r" operand MULHW
"s" operand "x" operand %allot-bignum-signed-2
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
@ -201,17 +186,15 @@ math-internals namespaces sequences words ;
most-positive-fixnum "s" operand LOAD
"r" operand 0 "s" operand CMP
"no-overflow" get BLE
most-negative-fixnum neg 3 LOAD
"s48_long_to_bignum" f %alien-invoke
"x" operand 3 bignum-tag ORI ;
most-negative-fixnum neg "x" operand LOAD
"x" operand %allot-bignum-signed-1 ;
\ fixnum/i [
finalize-contents
generate-fixnum/i
"end" get B
"no-overflow" get resolve-label
"r" operand "x" operand tag-fixnum
"end" get resolve-label
"no-overflow" resolve-label
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
@ -220,14 +203,13 @@ math-internals namespaces sequences words ;
} define-intrinsic
\ fixnum/mod [
finalize-contents
generate-fixnum/i
0 "s" operand LI
"end" get B
"no-overflow" get resolve-label
"no-overflow" resolve-label
generate-fixnum-mod
"r" operand "x" operand tag-fixnum
"end" get resolve-label
"r" operand "x" operand %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "r" } { f "s" } } }
@ -268,7 +250,7 @@ math-internals namespaces sequences words ;
\ tag [
"in" operand "out" operand tag-mask ANDI
"out" operand dup tag-fixnum
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "out" } } }
@ -281,7 +263,7 @@ math-internals namespaces sequences words ;
! Get the tag
"obj" operand "y" operand tag-mask ANDI
! Tag the tag
"y" operand "x" operand tag-fixnum
"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
@ -292,12 +274,12 @@ math-internals namespaces sequences words ;
"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
"x" operand dup %untag
"end" get B
"f" get resolve-label
"f" resolve-label
! The pointer is equal to 3. Load F_TYPE (9).
f type tag-bits shift "x" operand LI
"end" get resolve-label
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }

1
library/compiler/ppc/load.factor
View File

@ -2,5 +2,6 @@ PROVIDE: library/compiler/ppc
{ +files+ {
"assembler.factor"
"architecture.factor"
"allot.factor"
"intrinsics.factor"
} } ;

2
library/compiler/x86/architecture.factor
View File

@ -139,7 +139,7 @@ M: object load-literal
! Align for better performance
compile-aligned
! Fix up jump table pointer
"end" get resolve-label ;
"end" resolve-label ;
: %target ( label -- ) 0 cell, rel-absolute-cell rel-label ;

15
library/compiler/x86/intrinsics.factor
View File

@ -29,7 +29,7 @@ IN: compiler
! It doesn't store type info in its header
"obj" operand tag-bits SHL
"end" get JMP
"header" get resolve-label
"header" resolve-label
! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9).
"x" operand object-tag CMP
@ -39,10 +39,10 @@ IN: compiler
! Mask off header tag, making a fixnum.
"obj" operand object-tag XOR
"end" get JMP
"f" get resolve-label
"f" resolve-label
! The pointer is equal to 3. Load F_TYPE (9).
"obj" operand f type tag-bits shift MOV
"end" get resolve-label
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
@ -155,9 +155,6 @@ IN: compiler
: ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
: simple-overflow ( word -- )
finalize-contents
"z" operand "x" operand MOV
@ -173,7 +170,7 @@ IN: compiler
! An untagged pointer to the bignum is now in EAX; tag it
T{ int-regs } return-reg bignum-tag OR
"z" operand T{ int-regs } return-reg ?MOV
"end" get resolve-label ; inline
"end" resolve-label ; inline
: simple-overflow-template ( word insn -- )
[ simple-overflow ] curry H{
@ -200,7 +197,7 @@ IN: compiler
"x" operand tag-bits neg 2array compile-c-call*
! an untagged pointer to the bignum is now in EAX; tag it
T{ int-regs } return-reg bignum-tag OR
"end" get resolve-label
"end" resolve-label
] H{
{ +input+ { { 0 "x" } { 1 "y" } } }
{ +output+ { "x" } }
@ -233,7 +230,7 @@ IN: compiler
stack-reg 16 cell - ADD
! the remainder is now in EDX
remainder-reg POP
"end" get resolve-label ;
"end" resolve-label ;
\ fixnum/i [ generate-fixnum/mod ] H{
{ +input+ { { 0 "x" } { 1 "y" } } }

5
vm/data_gc.c
View File

@ -618,3 +618,8 @@ void primitive_gc_time(void)
{
box_unsigned_8(gc_time);
}
void simple_gc(void)
{
maybe_gc(0);
}

8
vm/data_gc.h
View File

@ -243,9 +243,14 @@ INLINE void *allot_zone(F_ZONE *z, CELL a)
return (void*)h;
}
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
INLINE void maybe_gc(CELL a)
{
if(nursery.here + a > nursery.limit)
if(nursery.here + a + ALLOT_BUFFER_ZONE > nursery.limit)
garbage_collection(NURSERY,false);
}
@ -270,3 +275,4 @@ void update_cards_offset(void);
CELL collect_next(CELL scan);
void primitive_data_gc(void);
void primitive_gc_time(void);
DLLEXPORT void simple_gc(void);