First cut at bignum inline allocators

TODO.FACTOR.txt

@@ -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:
 

library/compiler/generator/generator.factor

@@ -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 ;
 

library/compiler/generator/templates.factor

@@ -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

library/compiler/generator/xt.factor

@@ -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

library/compiler/ppc/allot.factor

@@ -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 ;

library/compiler/ppc/architecture.factor

@@ -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 ;

library/compiler/ppc/assembler.factor

@@ -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) ;

library/compiler/ppc/intrinsics.factor

@@ -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
+        { "x" "y" } [ dup %untag-fixnum ] unique-operands
-    3 "y" operand "x" operand r> execute
+        "r" operand "y" operand "x" operand r> execute
-    "s48_long_to_bignum" f %alien-invoke
+        "r" operand %allot-bignum-signed-1
-    ! An untagged pointer to the bignum is now in r3; tag it
+        "end" resolve-label
-    3 "r" operand bignum-tag ORI
+    ] with-scope ; inline
-    "end" get resolve-label ; 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
+    "s" operand "y" operand %untag-fixnum
-    3 12 MR
+    "x" operand "s" operand "r" operand MULLWO.
-    "s48_fixnum_pair_to_bignum" f %alien-invoke
+    "s" operand "s" operand "r" operand MULHW
-    ! now we have to shift it by three bits to remove the second
+    "s" operand "x" operand %allot-bignum-signed-2
-    ! tag
+    "end" resolve-label
-    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
 ] 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
+    most-negative-fixnum neg "x" operand LOAD
-    "s48_long_to_bignum" f %alien-invoke
+    "x" operand %allot-bignum-signed-1 ;
-    "x" operand 3 bignum-tag ORI ;
 
 \ fixnum/i [
-    finalize-contents
     generate-fixnum/i
     "end" get B
-    "no-overflow" get resolve-label
+    "no-overflow" resolve-label
-    "r" operand "x" operand tag-fixnum
+    "r" operand "x" operand %tag-fixnum
-    "end" get resolve-label
+    "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
+    "r" operand "x" operand %tag-fixnum
-    "end" get resolve-label
+    "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" } } }

library/compiler/ppc/load.factor

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

library/compiler/x86/architecture.factor

@@ -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 ;
 

library/compiler/x86/intrinsics.factor

@@ -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" } } }

vm/data_gc.c

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

vm/data_gc.h

@@ -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);