- 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:
"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 ;
compute-free-vregs ; inline
: operand ( var -- op ) get v>operand ; inline
+
+: unique-operands ( operands quot -- )
+ >r [ operand ] map prune r> each ; inline
: 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
--- /dev/null
+! 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 ;
: %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 ;
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 ;
: 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) ;
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
"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" } } }
\ 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" } }
"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" } } }
\ 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" } } }
\ fixnum-bitnot [
"x" operand dup NOT
- "x" operand dup untag
+ "x" operand dup %untag
] H{
{ +input+ { { f "x" } } }
{ +output+ { "x" } }
] 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
} define-intrinsic
\ fixnum- [
- finalize-contents
0 MTXER
"r" operand "y" operand "x" operand SUBFO.
\ SUBF simple-overflow
} 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" } } }
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" } } }
} 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" } } }
\ 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" } } }
! 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
"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" } } }
{ +files+ {
"assembler.factor"
"architecture.factor"
+ "allot.factor"
"intrinsics.factor"
} } ;
! 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 ;
! 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
! 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" } } }
: ?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
! 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{
"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" } }
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" } } }
{
box_unsigned_8(gc_time);
}
+
+void simple_gc(void)
+{
+ maybe_gc(0);
+}
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);
}
CELL collect_next(CELL scan);
void primitive_data_gc(void);
void primitive_gc_time(void);
+DLLEXPORT void simple_gc(void);