Merge branch 'master' of http://factorcode.org/git/factor into experimental

core/bootstrap/primitives.factor

@@ -607,7 +607,7 @@ tuple
     { "(exists?)" "io.files.private" }
     { "(directory)" "io.files.private" }
     { "gc" "memory" }
-    { "gc-time" "memory" }
+    { "gc-stats" "memory" }
     { "save-image" "memory" }
     { "save-image-and-exit" "memory" }
     { "datastack" "kernel" }
@@ -702,6 +702,7 @@ tuple
     { "resize-float-array" "float-arrays" }
     { "dll-valid?" "alien" }
     { "unimplemented" "kernel.private" }
+    { "gc-reset" "memory" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/checksums/checksums-docs.factor

@@ -48,4 +48,5 @@ $nl
 { $subsection "checksums.crc32" }
 { $vocab-subsection "MD5 checksum" "checksums.md5" }
 { $vocab-subsection "SHA1 checksum" "checksums.sha1" }
-{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
+{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ;

core/compiler/constants/constants.factor

@@ -5,6 +5,7 @@ IN: compiler.constants
 
 ! These constants must match vm/memory.h
 : card-bits 6 ;
+: deck-bits 12 ;
 : card-mark HEX: 40 HEX: 80 bitor ;
 
 ! These constants must match vm/layouts.h

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -56,14 +56,22 @@ IN: cpu.ppc.intrinsics
 : load-cards-offset ( dest -- )
     "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
 
+: load-decks-offset ( dest -- )
+    "decks_offset" f pick %load-dlsym  dup 0 LWZ ;
+
 : %write-barrier ( -- )
     "val" get operand-immediate? "obj" get fresh-object? or [
-        "obj" operand "scratch" operand card-bits SRWI
+        "scratch1" operand card-mark LI
+
+        ! Mark the card
         "val" operand load-cards-offset
-        "scratch" operand dup "val" operand ADD
+        "obj" operand "scratch2" operand card-bits SRWI
-        "val" operand "scratch" operand 0 LBZ
+        "val" operand "scratch2" operand "val" operand STBX
-        "val" operand dup card-mark ORI
+
-        "val" operand "scratch" operand 0 STB
+        ! Mark the card deck
+        "val" operand load-decks-offset
+        "obj" operand "scratch" operand deck-bits SRWI
+        "val" operand "scratch" operand "val" operand STBX
     ] unless ;
 
 \ set-slot {
@@ -71,7 +79,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-literal-known-tag STW %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch" } } }
+            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
             { +clobber+ { "val" } }
         }
     }

core/cpu/x86/32/32.factor

@@ -22,8 +22,9 @@ M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86.32 %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-    (CALL) rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;

core/cpu/x86/64/64.factor

@@ -130,7 +130,10 @@ M: x86.64 %prepare-box-struct ( size -- )
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: x86.64 %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-global
+    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
     0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
 
 M: x86.64 %prepare-alien-indirect ( -- )

core/cpu/x86/architecture/architecture.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.compiler arrays
-cpu.x86.assembler cpu.architecture kernel kernel.private math
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
-memory namespaces sequences words generator generator.registers
+kernel kernel.private math memory namespaces sequences words
-generator.fixup system layouts combinators compiler.constants
+generator generator.registers generator.fixup system layouts
-math.order ;
+combinators compiler.constants math.order ;
 IN: cpu.x86.architecture
 
 HOOK: ds-reg cpu
@@ -63,8 +63,7 @@ M: x86 %prologue ( n -- )
 M: x86 %epilogue ( n -- )
     stack-reg swap ADD ;
 
-: %alien-global ( symbol dll register -- )
+HOOK: %alien-global cpu ( symbol dll register -- )
-    [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
 
 M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a

core/cpu/x86/assembler/assembler-tests.factor

@@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
 [ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test

core/cpu/x86/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system layouts math.order ;
+words system layouts math.order accessors ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.
@@ -11,11 +11,6 @@ IN: cpu.x86.assembler
 ! In 64-bit mode, { 1234 } is RIP-relative.
 ! Beware!
 
-: n, >le % ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
-
 ! Register operands -- eg, ECX
 <<
 
@@ -45,6 +40,10 @@ REGISTERS: 128
 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
 
+TUPLE: byte value ;
+
+C: <byte> byte
+
 <PRIVATE
 
 #! Extended AMD64 registers (R8-R15) return true.
@@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
 ! Addressing modes
 TUPLE: indirect base index scale displacement ;
 
-M: indirect extended? indirect-base extended? ;
+M: indirect extended? base>> extended? ;
 
 : canonicalize-EBP
     #! { EBP } ==> { EBP 0 }
-    dup indirect-base { EBP RBP R13 } memq? [
+    dup base>> { EBP RBP R13 } member? [
-        dup indirect-displacement [
+        dup displacement>> [ 0 >>displacement ] unless
-            drop
+    ] when drop ;
-        ] [
-            0 swap set-indirect-displacement
-        ] if
-    ] [
-        drop
-    ] if ;
 
 : canonicalize-ESP
     #! { ESP } ==> { ESP ESP }
-    dup indirect-base { ESP RSP R12 } memq? [
+    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
-        ESP swap set-indirect-index
-    ] [
-        drop
-    ] if ;
 
 : canonicalize ( indirect -- )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    dup canonicalize-EBP
+    [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
-    canonicalize-ESP ;
 
 : <indirect> ( base index scale displacement -- indirect )
     indirect boa dup canonicalize ;
 
 : reg-code "register" word-prop 7 bitand ;
 
-: indirect-base* indirect-base EBP or reg-code ;
+: indirect-base* base>> EBP or reg-code ;
 
-: indirect-index* indirect-index ESP or reg-code ;
+: indirect-index* index>> ESP or reg-code ;
 
-: indirect-scale* indirect-scale 0 or ;
+: indirect-scale* scale>> 0 or ;
 
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    dup indirect-base { ESP RSP } memq?
+    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
-    over indirect-index rot indirect-scale or or ;
 
 M: register sib-present? drop f ;
 
@@ -130,16 +117,23 @@ M: indirect r/m
 
 M: register r/m reg-code ;
 
-: byte? -128 127 between? ;
+! Immediate operands
+UNION: immediate byte integer ;
+
+GENERIC: fits-in-byte? ( value -- ? )
+
+M: byte fits-in-byte? drop t ;
+
+M: integer fits-in-byte? -128 127 between? ;
 
 GENERIC: modifier ( op -- n )
 
 M: indirect modifier
-    dup indirect-base [
+    dup base>> [
-        indirect-displacement {
+        displacement>> {
-            { [ dup not ]      [ BIN: 00 ] }
+            { [ dup not ] [ BIN: 00 ] }
-            { [ dup byte? ]    [ BIN: 01 ] }
+            { [ dup fits-in-byte? ] [ BIN: 01 ] }
-            { [ dup integer? ] [ BIN: 10 ] }
+            { [ dup immediate? ] [ BIN: 10 ] }
         } cond nip
     ] [
         drop BIN: 00
@@ -147,14 +141,23 @@ M: indirect modifier
 
 M: register modifier drop BIN: 11 ;
 
+GENERIC# n, 1 ( value n -- )
+
+M: integer n, >le % ;
+M: byte n, >r value>> r> n, ;
+: 1, 1 n, ; inline
+: 4, 4 n, ; inline
+: 2, 2 n, ; inline
+: cell, bootstrap-cell n, ; inline
+
 : mod-r/m, ( reg# indirect -- )
-    dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ;
+    [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 
 : sib, ( indirect -- )
     dup sib-present? [
-        dup indirect-base*
+        [ indirect-base* ]
-        over indirect-index* 3 shift bitor
+        [ indirect-index* 3 shift ]
-        swap indirect-scale* 6 shift bitor ,
+        [ indirect-scale* 6 shift ] tri bitor bitor ,
     ] [
         drop
     ] if ;
@@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ;
 GENERIC: displacement, ( op -- )
 
 M: indirect displacement,
-    dup indirect-displacement dup [
+    dup displacement>> dup [
-        swap indirect-base
+        swap base>>
-        [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
+        [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
     ] [
         2drop
     ] if ;
@@ -172,18 +175,19 @@ M: indirect displacement,
 M: register displacement, drop ;
 
 : addressing ( reg# indirect -- )
-    [ mod-r/m, ] keep [ sib, ] keep displacement, ;
+    [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 
 ! Utilities
 UNION: operand register indirect ;
 
-: operand-64? ( operand -- ? )
+GENERIC: operand-64? ( operand -- ? )
-    dup indirect? [
+
-        dup indirect-base register-64?
+M: indirect operand-64?
-        swap indirect-index register-64? or
+    [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
-    ] [
+
-        register-64?
+M: register-64 operand-64? drop t ;
-    ] if ;
+
+M: object operand-64? drop f ;
 
 : rex.w? ( rex.w reg r/m -- ? )
     {
@@ -198,8 +202,7 @@ UNION: operand register indirect ;
 : rex.b
     [ extended? [ BIN: 00000001 bitor ] when ] keep
     dup indirect? [
-        indirect-index extended?
+        index>> extended? [ BIN: 00000010 bitor ] when
-        [ BIN: 00000010 bitor ] when
     ] [
         drop
     ] if ;
@@ -230,25 +233,34 @@ UNION: operand register indirect ;
 
 : opcode-or ( opcode mask -- opcode' )
     swap dup array?
-    [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
+    [ unclip-last rot bitor suffix ] [ bitor ] if ;
 
-: 1-operand ( op reg rex.w opcode -- )
+: 1-operand ( op reg,rex.w,opcode -- )
     #! The 'reg' is not really a register, but a value for the
     #! 'reg' field of the mod-r/m byte.
-    >r >r over r> prefix-1 r> opcode, swap addressing ;
+    first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
 
-: immediate-1 ( imm dst reg rex.w opcode -- )
+: immediate-operand-size-bit
-    1-operand , ;
+    pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 
-: immediate-1/4 ( imm dst reg rex.w opcode -- )
+: immediate-1 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 1, ;
+
+: immediate-4 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 4, ;
+
+: immediate-fits-in-size-bit
+    pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+
+: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
     #! If imm is a byte, compile the opcode and the byte.
-    #! Otherwise, set the 32-bit operand flag in the opcode, and
+    #! Otherwise, set the 8-bit operand flag in the opcode, and
     #! compile the cell. The 'reg' is not really a register, but
     #! a value for the 'reg' field of the mod-r/m byte.
-    >r >r pick byte? [
+    pick fits-in-byte? [
-        r> r> BIN: 10 opcode-or immediate-1
+        immediate-fits-in-size-bit immediate-1
     ] [
-        r> r> 1-operand 4,
+        immediate-4
     ] if ;
 
 : (2-operand) ( dst src op -- )
@@ -283,22 +295,24 @@ PRIVATE>
 ! Moving stuff
 GENERIC: PUSH ( op -- )
 M: register PUSH f HEX: 50 short-operand ;
-M: integer PUSH HEX: 68 , 4, ;
+M: immediate PUSH HEX: 68 , 4, ;
-M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
+M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
 
 GENERIC: POP ( op -- )
 M: register POP f HEX: 58 short-operand ;
-M: operand POP BIN: 000 f HEX: 8f 1-operand ;
+M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 
 ! MOV where the src is immediate.
 GENERIC: (MOV-I) ( src dst -- )
 M: register (MOV-I) t HEX: b8 short-operand cell, ;
-M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
+M: operand (MOV-I)
+    { BIN: 000 t HEX: c6 }
+    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 
 PREDICATE: callable < word register? not ;
 
 GENERIC: MOV ( dst src -- )
-M: integer MOV swap (MOV-I) ;
+M: immediate MOV swap (MOV-I) ;
 M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
@@ -309,13 +323,13 @@ GENERIC: JMP ( op -- )
 : (JMP) HEX: e9 , 0 4, rc-relative ;
 M: callable JMP (JMP) rel-word ;
 M: label JMP (JMP) label-fixup ;
-M: operand JMP BIN: 100 t HEX: ff 1-operand ;
+M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
 : (CALL) HEX: e8 , 0 4, rc-relative ;
 M: callable CALL (CALL) rel-word ;
 M: label CALL (CALL) label-fixup ;
-M: operand CALL BIN: 010 t HEX: ff 1-operand ;
+M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
 : (JUMPcc) extended-opcode, 0 4, rc-relative ;
@@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ;
 ! Arithmetic
 
 GENERIC: ADD ( dst src -- )
-M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ;
+M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
 M: operand ADD OCT: 000 2-operand ;
 
 GENERIC: OR ( dst src -- )
-M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ;
+M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
 M: operand OR OCT: 010 2-operand ;
 
 GENERIC: ADC ( dst src -- )
-M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ;
+M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
 M: operand ADC OCT: 020 2-operand ;
 
 GENERIC: SBB ( dst src -- )
-M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ;
+M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
 M: operand SBB OCT: 030 2-operand ;
 
 GENERIC: AND ( dst src -- )
-M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ;
+M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
 M: operand AND OCT: 040 2-operand ;
 
 GENERIC: SUB ( dst src -- )
-M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ;
+M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
 M: operand SUB OCT: 050 2-operand ;
 
 GENERIC: XOR ( dst src -- )
-M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ;
+M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
 M: operand XOR OCT: 060 2-operand ;
 
 GENERIC: CMP ( dst src -- )
-M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ;
+M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
-: NOT  ( dst -- ) BIN: 010 t HEX: f7 1-operand ;
+: NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
-: NEG  ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
+: NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
-: MUL  ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
+: MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
-: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
-: DIV  ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
+: DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
-: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ;
+: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
 
 : CDQ HEX: 99 , ;
 : CQO HEX: 48 , CDQ ;
 
-: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ;
+: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
 
 GENERIC: IMUL2 ( dst src -- )
-M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
+M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
 M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 : MOVSX ( dst src -- )
@@ -432,11 +446,11 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 ! x87 Floating Point Unit
 
-: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ;
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
-: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
 
-: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
-: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 
 ! SSE multimedia instructions
 

core/cpu/x86/intrinsics/intrinsics.factor

@@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics
 : generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
     "val" get operand-immediate? "obj" get fresh-object? or [
+        ! Mark the card
         "obj" operand card-bits SHR
         "cards_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark OR
+        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
+
+        ! Mark the card deck
+        "obj" operand deck-bits card-bits - SHR
+        "decks_offset" f temp-reg v>operand %alien-global
+        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
     ] unless ;
 
 \ set-slot {

core/inference/known-words/known-words.factor

@@ -362,7 +362,7 @@ M: object infer-call
 
 \ gc { } { } <effect> set-primitive-effect
 
-\ gc-time { } { integer } <effect> set-primitive-effect
+\ gc-stats { } { array } <effect> set-primitive-effect
 
 \ save-image { string } { } <effect> set-primitive-effect
 
@@ -372,7 +372,7 @@ M: object infer-call
 t over set-effect-terminated?
 set-primitive-effect
 
-\ data-room { } { integer array } <effect> set-primitive-effect
+\ data-room { } { integer integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
 \ code-room { } { integer integer integer integer } <effect> set-primitive-effect

core/inference/state/state-tests.factor

@@ -1,5 +1,5 @@
 IN: inference.state.tests
-USING: tools.test inference.state words ;
+USING: tools.test inference.state words kernel namespaces ;
 
 : computing-dependencies ( quot -- dependencies )
     H{ } clone [ dependencies rot with-variable ] keep ;

core/io/files/files-docs.factor

@@ -273,11 +273,11 @@ $nl
 
 HELP: append-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Concatenates two pathnames." } ;
+{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
 
 HELP: prepend-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Concatenates two pathnames." } ;
+{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
 
 { append-path prepend-path } related-words
 

core/io/io-docs.factor

@@ -125,7 +125,7 @@ $nl
 ABOUT: "streams"
 
 HELP: stream-readln
-{ $values { "stream" "an input stream" } { "str" string } }
+{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
 { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
 { $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
 $io-error ;
@@ -139,7 +139,7 @@ $io-error ;
 HELP: stream-read
 { $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
 { $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." }
 $io-error ;
 
 HELP: stream-read-until

core/io/io.factor

@@ -4,7 +4,7 @@ USING: hashtables generic kernel math namespaces sequences
 continuations assocs io.styles ;
 IN: io
 
-GENERIC: stream-readln ( stream -- str )
+GENERIC: stream-readln ( stream -- str/f )
 GENERIC: stream-read1 ( stream -- ch/f )
 GENERIC: stream-read ( n stream -- str/f )
 GENERIC: stream-read-until ( seps stream -- str/f sep/f )

core/memory/memory-docs.factor

@@ -40,10 +40,6 @@ HELP: instances
 HELP: gc ( -- )
 { $description "Performs a full garbage collection." } ;
 
-HELP: gc-time ( -- n )
-{ $values { "n" "a timestamp in milliseconds" } }
-{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
-
 HELP: data-room ( -- cards generations )
 { $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
 { $description "Queries the runtime for memory usage information." } ;

extra/benchmark/benchmark.factor

@@ -6,7 +6,7 @@ continuations debugger ;
 IN: benchmark
 
 : run-benchmark ( vocab -- result )
-  [ [ require ] [ [ run ] benchmark nip ] bi ] curry
+  [ [ require ] [ [ run ] benchmark ] bi ] curry
   [ error. f ] recover ;
 
 : run-benchmarks ( -- assoc )

extra/benchmark/binary-trees/binary-trees.factor

@@ -53,3 +53,5 @@ M: f item-check drop 0 ;
 
 : binary-trees-main ( -- )
     16 binary-trees ;
+
+MAIN: binary-trees-main

extra/benchmark/partial-sums/partial-sums.factor

@@ -3,7 +3,8 @@ prettyprint words hints ;
 IN: benchmark.partial-sums
 
 : summing ( n quot -- y )
-    [ + ] compose 0.0 -rot 1 -rot (each-integer) ; inline
+    [ >float ] swap [ + ] 3compose
+    0.0 -rot 1 -rot (each-integer) ; inline
 
 : 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
 

extra/checksums/adler-32/adler-32-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.adler-32
+
+HELP: adler-32
+{ $description "Adler-32 checksum algorithm." } ;
+
+ARTICLE: "checksums.adler-32" "Adler-32 checksum"
+"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."
+{ $subsection adler-32 } ;
+
+ABOUT: "checksums.adler-32"

extra/checksums/adler-32/adler-32-tests.factor

@@ -0,0 +1,5 @@
+USING: checksums.adler-32 checksums strings tools.test ;
+IN: checksums.adler-32.tests
+
+[ 300286872 ] [ "Wikipedia" adler-32 checksum-bytes ] unit-test
+[ 2679885283 ] [ 10000 CHAR: a <string> adler-32 checksum-bytes ] unit-test

extra/checksums/adler-32/adler-32.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: checksums classes.singleton kernel math math.ranges
+math.vectors sequences ;
+IN: checksums.adler-32
+
+SINGLETON: adler-32
+
+: adler-32-modulus 65521 ; inline
+
+M: adler-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    [ sum 1+ ]
+    [ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
+    [ adler-32-modulus mod ] bi@ 16 shift bitor ;

extra/checksums/adler-32/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/cocoa/application/application-docs.factor

@@ -26,7 +26,7 @@ HELP: with-cocoa
 { $values { "quot" quotation } }
 { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
 
-HELP: do-events
+HELP: do-event
 { $values { "app" "an " { $snippet "NSApplication" } } }
 { $description "Processes any pending events in the queue. Does not block." } ;
 
@@ -49,7 +49,7 @@ ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
 { $subsection NSApp }
 { $subsection with-autorelease-pool }
 { $subsection with-cocoa }
-{ $subsection do-events }
+{ $subsection do-event }
 { $subsection add-observer }
 { $subsection remove-observer }
 { $subsection install-delegate } ;

extra/cocoa/application/application.factor

@@ -29,9 +29,6 @@ IN: cocoa.application
 : do-event ( app -- ? )
     dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
 
-: do-events ( app -- )
-    dup do-event [ do-events ] [ drop ] if ;
-
 : add-observer ( observer selector name object -- )
     >r >r >r >r NSNotificationCenter -> defaultCenter
     r> r> sel_registerName

extra/optimizer/report/report.factor

@@ -20,7 +20,7 @@ IN: optimizer.report
     [
         dup [
             word-dataflow nip 1 count-optimization-passes
-        ] benchmark nip 2array
+        ] benchmark 2array
     ] { } map>assoc
     [ first ] "Worst number of optimizer passes:" results
     [ second ] "Worst compile times:" results ;

extra/project-euler/ave-time/ave-time-docs.factor

@@ -16,9 +16,7 @@ HELP: ave-time
     "This word can be used to compare performance of the non-optimizing and optimizing compilers."
     $nl
     "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
-    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" }
+    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" }
     "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
-    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" }
+    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" }
 } ;
-
-{ benchmark collect-benchmarks gc-time millis time ave-time } related-words

extra/project-euler/ave-time/ave-time.factor

@@ -4,20 +4,13 @@ USING: arrays combinators io kernel math math.functions math.parser
     math.statistics namespaces sequences tools.time ;
 IN: project-euler.ave-time
 
-<PRIVATE
-
-: ave-benchmarks ( seq -- pair )
-    flip [ mean round ] map ;
-
-PRIVATE>
-
 : collect-benchmarks ( quot n -- seq )
   [
-    >r >r datastack r> [ benchmark 2array , ] curry tuck
+    >r >r datastack r> [ benchmark , ] curry tuck
     [ with-datastack drop ] 2curry r> swap times call
   ] { } make ;
 
 : ave-time ( quot n -- )
-    [ collect-benchmarks ] keep swap ave-benchmarks [
+    [ collect-benchmarks ] keep swap mean round [
-        dup second # " ms run / " % first # " ms GC ave time - " % # " trials" %
+        # " ms run time - " % # " trials" %
     ] "" make print flush ; inline

extra/reports/optimizer/optimizer.factor

@@ -20,7 +20,7 @@ IN: report.optimizer
     [
         dup [
             word-dataflow nip 1 count-optimization-passes
-        ] benchmark nip 2array
+        ] benchmark 2array
     ] { } map>assoc ;
 
 : optimizer-measurements. ( alist -- )

extra/taxes/taxes-tests.factor

@@ -111,6 +111,6 @@ IN: taxes.tests
     24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
 ] unit-test
 
-[ 754 22 ] [
+[ 754 72 ] [
     78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
 ] unit-test

extra/tools/deploy/config/config-docs.factor

@@ -96,7 +96,7 @@ HELP: deploy-io
         { "2" "Basic ANSI C streams" }
         { "3" "Non-blocking streams and networking" }
     }
-"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ;
+"The default value is 2, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such as networking are not available." } ;
 
 HELP: deploy-reflection
 { $description "The level of reflection support required by the deployed image."

extra/tools/memory/memory.factor

@@ -36,6 +36,7 @@ IN: tools.memory
         [ first2 ] [ number>string "Generation " prepend ] bi*
         write-total/used/free
     ] 2each
+    "Decks" write-total
     "Cards" write-total ;
 
 : write-labelled-size ( n string -- )

extra/tools/test/test.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces arrays prettyprint sequences kernel
 vectors quotations words parser assocs combinators
-continuations debugger io io.files vocabs tools.time
+continuations debugger io io.files vocabs
 vocabs.loader source-files compiler.units inspector
 inference effects tools.vocabs ;
 IN: tools.test
@@ -19,7 +19,7 @@ SYMBOL: this-test
 
 : (unit-test) ( what quot -- )
     swap dup . flush this-test set
-    [ time ] curry failures get [
+    failures get [
         [ this-test get failure ] recover
     ] [
         call

extra/tools/time/time-docs.factor

@@ -6,9 +6,9 @@ ARTICLE: "timing" "Timing code"
 { $subsection time }
 "A lower-level word puts timings on the stack, intead of printing:"
 { $subsection benchmark }
-"You can also read the system clock and total garbage collection time directly:"
+"You can also read the system clock and garbage collection statistics directly:"
 { $subsection millis } 
-{ $subsection gc-time }
+{ $subsection gc-stats }
 { $see-also "profiling" } ;
 
 ABOUT: "timing"
@@ -20,14 +20,6 @@ HELP: benchmark
 
 HELP: time
 { $values { "quot" "a quotation" } }
-{ $description "Runs a quotation and then prints the total run time and time spent in the garbage collector." }
+{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
-{ $examples
-    "This word can be used to compare performance of the non-optimizing and optimizing compilers."
-    $nl
-    "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
-    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] time" "1116 ms run / 6 ms GC time" }
-    "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
-    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] time" "202 ms run / 13 ms GC time" }
-} ;
 
-{ gc-time benchmark millis time } related-words
+{ benchmark millis time } related-words

extra/tools/time/time.factor

@@ -1,14 +1,54 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math memory io namespaces system
+USING: kernel math math.vectors memory io io.styles prettyprint
-math.parser ;
+namespaces system sequences splitting assocs strings ;
 IN: tools.time
 
 : benchmark ( quot -- gctime runtime )
-    millis >r gc-time >r call gc-time r> - millis r> - ;
+    millis >r call millis r> - ; inline
-    inline
+
+: simple-table. ( values -- )
+    standard-table-style [
+        [
+            [
+                [
+                    dup string?
+                    [ [ write ] with-cell ]
+                    [ pprint-cell ]
+                    if
+                ] each
+            ] with-row
+        ] each
+    ] tabular-output ;
+
+: time. ( data -- )
+    unclip
+    "==== RUNNING TIME" print nl pprint " ms" print nl
+    4 cut*
+    "==== GARBAGE COLLECTION" print nl
+    [
+        6 group
+        {
+            "GC count:"
+            "Cumulative GC time (ms):"
+            "Longest GC pause (ms):"
+            "Average GC pause (ms):"
+            "Objects copied:"
+            "Bytes copied:"
+        } prefix
+        flip
+        { "" "Nursery" "Aging" "Tenured" } prefix
+        simple-table.
+    ]
+    [
+        nl
+        {
+            "Total GC time (ms):"
+            "Cards scanned:"
+            "Decks scanned:"
+            "Code heap literal scans:"
+        } swap zip simple-table.
+    ] bi* ;
 
 : time ( quot -- )
-    benchmark
+    gc-reset millis >r call gc-stats millis r> - prefix time. ; inline
-    [ # " ms run / " % # " ms GC time" % ] "" make print flush ;
-    inline

extra/ui/backend/backend.factor

@@ -5,6 +5,8 @@ IN: ui.backend
 
 SYMBOL: ui-backend
 
+HOOK: do-events ui-backend ( -- )
+
 HOOK: set-title ui-backend ( string world -- )
 
 HOOK: set-fullscreen* ui-backend ( ? world -- )

extra/ui/cocoa/cocoa.factor

@@ -14,18 +14,13 @@ C: <handle> handle
 
 SINGLETON: cocoa-ui-backend
 
-SYMBOL: stop-after-last-window?
+M: cocoa-ui-backend do-events ( -- )
-
+    [
-: event-loop? ( -- ? )
-    stop-after-last-window? get-global
-    [ windows get-global empty? not ] [ t ] if ;
-
-: event-loop ( -- )
-    event-loop? [
         [
-            [ NSApp do-events ui-wait ] ui-try
+            NSApp [ dup do-event ] [ ] [ ] while drop
-        ] with-autorelease-pool event-loop
+            ui-wait
-    ] when ;
+        ] ui-try
+    ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 
@@ -112,6 +107,7 @@ M: cocoa-ui-backend ui
     "UI" assert.app [
         [
             init-clipboard
+            stop-after-last-window? off
             cocoa-init-hook get [ call ] when*
             start-ui
             finish-launching

extra/ui/ui.factor

@@ -10,6 +10,18 @@ IN: ui
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
 
+SYMBOL: stop-after-last-window?
+
+: event-loop? ( -- ? )
+    {
+        { [ stop-after-last-window? get not ] [ t ] }
+        { [ graft-queue dlist-empty? not ] [ t ] }
+        { [ windows get-global empty? not ] [ t ] }
+        [ f ]
+    } cond ;
+
+: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
 : window ( handle -- world ) windows get-global at ;
 
 : window-focus ( handle -- gadget ) window world-focus ;
@@ -201,5 +213,9 @@ MAIN: ui
         call
     ] [
         f windows set-global
-        ui-hook [ ui ] with-variable
+        [
+            ui-hook set
+            stop-after-last-window? on
+            ui
+        ] with-scope
     ] if ;

extra/ui/windows/windows.factor

@@ -387,17 +387,12 @@ SYMBOL: trace-messages?
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 
-: event-loop ( msg -- )
+M: windows-ui-backend do-events
-    {
+    msg-obj get-global
-        { [ windows get empty? ] [ drop ] }
+    dup peek-message? [ drop ui-wait ] [
-        { [ dup peek-message? ] [ ui-wait event-loop ] }
+        [ TranslateMessage drop ]
-        { [ dup MSG-message WM_QUIT = ] [ drop ] }
+        [ DispatchMessage drop ] bi
-        [
+    ] if ;
-            dup TranslateMessage drop
-            dup DispatchMessage drop
-            event-loop
-        ]
-    } cond ;
 
 : register-wndclassex ( -- class )
     "WNDCLASSEX" <c-object>
@@ -500,10 +495,11 @@ M: windows-ui-backend set-title ( string world -- )
 M: windows-ui-backend ui
     [
         [
+            stop-after-last-window? on
             init-clipboard
             init-win32-ui
             start-ui
-            msg-obj get event-loop
+            event-loop
         ] [ cleanup-win32-ui ] [ ] cleanup
     ] ui-running ;
 

extra/ui/x11/x11.factor

@@ -183,15 +183,10 @@ M: world client-event
         ui-wait wait-event
     ] if ;
 
-: do-events ( -- )
+M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup
     [ [ 2dup handle-event ] assert-depth ] when 2drop ;
 
-: event-loop ( -- )
-    windows get empty? [
-        [ do-events ] ui-try event-loop
-    ] unless ;
-
 : x-clipboard@ ( gadget clipboard -- prop win )
     x-clipboard-atom swap
     find-world world-handle x11-handle-window ;
@@ -254,6 +249,7 @@ M: x11-ui-backend ui ( -- )
     [
         f [
             [
+                stop-after-last-window? on
                 init-clipboard
                 start-ui
                 event-loop

extra/unix/ffi/ffi.factor

@@ -0,0 +1,6 @@
+
+USING: alien.syntax ;
+
+IN: unix.ffi
+
+FUNCTION: int open ( char* path, int flags, int prot ) ;

extra/unix/unix.factor

@@ -2,7 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: alien alien.c-types alien.syntax kernel libc structs
-math namespaces system combinators vocabs.loader unix.types ;
+       math namespaces system combinators vocabs.loader unix.ffi unix.types
+       qualified ;
+
+QUALIFIED: unix.ffi
 
 IN: unix
 
@@ -75,7 +78,14 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
 FUNCTION: int munmap ( void* addr, size_t len ) ;
 FUNCTION: uint ntohl ( uint n ) ;
 FUNCTION: ushort ntohs ( ushort n ) ;
-FUNCTION: int open ( char* path, int flags, int prot ) ;
+FUNCTION: char* strerror ( int errno ) ;
+
+ERROR: open-error path flags prot message ;
+
+: open ( path flags prot -- int )
+    3dup unix.ffi:open
+    dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ;
+
 FUNCTION: int pclose ( void* file ) ;
 FUNCTION: int pipe ( int* filedes ) ;
 FUNCTION: void* popen ( char* command, char* type ) ;
@@ -96,7 +106,6 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
 FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
 FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
-FUNCTION: char* strerror ( int errno ) ;
 FUNCTION: int symlink ( char* path1, char* path2 ) ;
 FUNCTION: int system ( char* command ) ;
 FUNCTION: int unlink ( char* path ) ;
@@ -159,8 +168,6 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
 FUNCTION: pid_t wait ( int* status ) ;
 FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
 
 {

vm/Config.unix

@@ -1,4 +1,6 @@
-CFLAGS += -fomit-frame-pointer
+ifndef DEBUG
+	CFLAGS += -fomit-frame-pointer
+endif
 
 EXE_SUFFIX =
 DLL_PREFIX = lib

vm/data_gc.c

@@ -21,10 +21,12 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
 	return z->end;
 }
 
-void init_cards_offset(void)
+void init_card_decks(void)
 {
-	cards_offset = (CELL)data_heap->cards
+	CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
-		- (data_heap->segment->start >> CARD_BITS);
+	allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
+	cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
+	decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
 }
 
 F_DATA_HEAP *alloc_data_heap(CELL gens,
@@ -62,10 +64,17 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 	data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 
-	CELL cards_size = total_size / CARD_SIZE;
+	CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE;
+	data_heap->allot_markers = safe_malloc(cards_size);
+	data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
+
 	data_heap->cards = safe_malloc(cards_size);
 	data_heap->cards_end = data_heap->cards + cards_size;
 
+	CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE;
+	data_heap->decks = safe_malloc(decks_size);
+	data_heap->decks_end = data_heap->decks + decks_size;
+
 	CELL alloter = data_heap->segment->start;
 
 	alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
@@ -104,7 +113,9 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
 	dealloc_segment(data_heap->segment);
 	free(data_heap->generations);
 	free(data_heap->semispaces);
+	free(data_heap->allot_markers);
 	free(data_heap->cards);
+	free(data_heap->decks);
 	free(data_heap);
 }
 
@@ -113,18 +124,45 @@ cleared when a generation has been cleared */
 void clear_cards(CELL from, CELL to)
 {
 	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
 	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start);
+	F_CARD *ptr;
-	for(; ptr < last_card; ptr++)
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0;
-		clear_card(ptr);
+}
+
+void clear_decks(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start);
+	F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0;
+}
+
+void clear_allot_markers(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
+	F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK;
 }
 
 void set_data_heap(F_DATA_HEAP *data_heap_)
 {
 	data_heap = data_heap_;
 	nursery = data_heap->generations[NURSERY];
-	init_cards_offset();
+	init_card_decks();
 	clear_cards(NURSERY,TENURED);
+	clear_decks(NURSERY,TENURED);
+	clear_allot_markers(NURSERY,TENURED);
+}
+
+void gc_reset(void)
+{
+	int i;
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+		memset(&gc_stats[i],0,sizeof(F_GC_STATS));
 }
 
 void init_data_heap(CELL gens,
@@ -141,11 +179,13 @@ void init_data_heap(CELL gens,
 	extra_roots_region = alloc_segment(getpagesize());
 	extra_roots = extra_roots_region->start - CELLS;
 
-	gc_time = 0;
-	aging_collections = 0;
-	nursery_collections = 0;
-	cards_scanned = 0;
 	secure_gc = secure_gc_;
+
+	gc_reset();
+
+	cards_scanned = 0;
+	decks_scanned = 0;
+	code_heap_scans = 0;
 }
 
 /* Size of the object pointed to by a tagged pointer */
@@ -228,6 +268,7 @@ DEFINE_PRIMITIVE(data_room)
 	int gen;
 
 	dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
+	dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
 
 	for(gen = 0; gen < data_heap->gen_count; gen++)
 	{
@@ -263,7 +304,7 @@ CELL next_object(void)
 
 	if(heap_scan_ptr >= data_heap->generations[TENURED].here)
 		return F;
-	
+
 	type = untag_header(value);
 	heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 
@@ -283,36 +324,60 @@ DEFINE_PRIMITIVE(end_scan)
 }
 
 /* Scan all the objects in the card */
-INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
+void collect_card(F_CARD *ptr, CELL gen, CELL here)
 {
-	F_CARD c = *ptr;
+	CELL offset = CARD_OFFSET(ptr);
-	CELL offset = (c & CARD_BASE_MASK);
 
-	if(offset == CARD_BASE_MASK)
+	if(offset != CARD_BASE_MASK)
 	{
-		if(c == 0xff)
+		CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
-			critical_error("bad card",(CELL)ptr);
+		CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-		else
+
-			return;
+		while(card_scan < card_end && card_scan < here)
+			card_scan = collect_next(card_scan);
+
+		cards_scanned++;
+	}
+}
+
+void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
+{
+	F_CARD *first_card = DECK_TO_CARD(deck);
+	F_CARD *last_card = DECK_TO_CARD(deck + 1);
+
+	CELL here = data_heap->generations[gen].here;
+
+	u32 *quad_ptr;
+	u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
+
+	for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
+	{
+		if(*quad_ptr & quad_mask)
+		{
+			F_CARD *ptr = (F_CARD *)quad_ptr;
+
+			int card;
+			for(card = 0; card < 4; card++)
+			{
+				if(ptr[card] & mask)
+				{
+					collect_card(&ptr[card],gen,here);
+					ptr[card] &= ~unmask;
+				}
+			}
+		}
 	}
 
-	CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+	decks_scanned++;
-	CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
-	while(card_scan < card_end && card_scan < here)
-		card_scan = collect_next(card_scan);
-
-	cards_scanned++;
 }
 
 /* Copy all newspace objects referenced from marked cards to the destination */
-INLINE void collect_gen_cards(CELL gen)
+void collect_gen_cards(CELL gen)
 {
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start);
+	F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
-	CELL here = data_heap->generations[gen].here;
+	F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
-	F_CARD *last_card = ADDR_TO_CARD(here - 1);
 
-	CELL mask, unmask;
+	F_CARD mask, unmask;
 
 	/* if we are collecting the nursery, we care about old->nursery pointers
 	but not old->aging pointers */
@@ -360,11 +425,13 @@ INLINE void collect_gen_cards(CELL gen)
 		return;
 	}
 
-	for(; ptr <= last_card; ptr++)
+	F_DECK *ptr;
+
+	for(ptr = first_deck; ptr < last_deck; ptr++)
 	{
 		if(*ptr & mask)
 		{
-			collect_card(ptr,gen,here);
+			collect_card_deck(ptr,gen,mask,unmask);
 			*ptr &= ~unmask;
 		}
 	}
@@ -454,6 +521,11 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
 		longjmp(gc_jmp,1);
 	allot_barrier(newspace->here);
 	newpointer = allot_zone(newspace,size);
+
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+	s->object_count++;
+	s->bytes_copied += size;
+
 	memcpy(newpointer,pointer,size);
 	return newpointer;
 }
@@ -584,6 +656,7 @@ CELL collect_next(CELL scan)
 INLINE void reset_generation(CELL i)
 {
 	F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
+
 	z->here = z->start;
 	if(secure_gc)
 		memset((void*)z->start,69,z->size);
@@ -594,8 +667,12 @@ their allocation pointers and cards reset. */
 void reset_generations(CELL from, CELL to)
 {
 	CELL i;
-	for(i = from; i <= to; i++) reset_generation(i);
+	for(i = from; i <= to; i++)
+		reset_generation(i);
+
 	clear_cards(from,to);
+	clear_decks(from,to);
+	clear_allot_markers(from,to);
 }
 
 /* Prepare to start copying reachable objects into an unused zone */
@@ -620,6 +697,8 @@ void begin_gc(CELL requested_bytes)
 		reset_generation(collecting_gen);
 		newspace = &data_heap->generations[collecting_gen];
 		clear_cards(collecting_gen,collecting_gen);
+		clear_decks(collecting_gen,collecting_gen);
+		clear_allot_markers(collecting_gen,collecting_gen);
 	}
 	else
 	{
@@ -638,8 +717,15 @@ void begin_gc(CELL requested_bytes)
 #endif
 }
 
-void end_gc(void)
+void end_gc(CELL gc_elapsed)
 {
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+
+	s->collections++;
+	s->gc_time += gc_elapsed;
+	if(s->max_gc_time < gc_elapsed)
+		s->max_gc_time = gc_elapsed;
+
 	if(growing_data_heap)
 	{
 		dealloc_data_heap(old_data_heap);
@@ -654,29 +740,12 @@ void end_gc(void)
 		old-school Cheney collector */
 		if(collecting_gen != NURSERY)
 			reset_generations(NURSERY,collecting_gen - 1);
-
-		if(collecting_gen == TENURED)
-		{
-			GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
-			aging_collections = 0;
-			cards_scanned = 0;
-		}
-		else if(HAVE_AGING_P && collecting_gen == AGING)
-		{
-			aging_collections++;
-
-			GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
-			nursery_collections = 0;
-			cards_scanned = 0;
-		}
 	}
 	else
 	{
 		/* all generations up to and including the one
 		collected are now empty */
 		reset_generations(NURSERY,collecting_gen);
-
-		nursery_collections++;
 	}
 
 	if(collecting_gen == TENURED)
@@ -758,7 +827,10 @@ void garbage_collection(CELL gen,
 			literals from any code block which gets marked as live.
 			if we are not doing code GC, just consider all literals
 			as roots. */
+			code_heap_scans++;
+
 			collect_literals();
+
 			if(collecting_accumulation_gen_p())
 				last_code_heap_scan = collecting_gen;
 			else
@@ -772,9 +844,8 @@ void garbage_collection(CELL gen,
 	CELL gc_elapsed = (current_millis() - start);
 
 	GC_PRINT(END_GC,gc_elapsed);
-	end_gc();
+	end_gc(gc_elapsed);
 
-	gc_time += gc_elapsed;
 	performing_gc = false;
 }
 
@@ -793,10 +864,38 @@ DEFINE_PRIMITIVE(gc)
 	gc();
 }
 
-/* Push total time spent on GC */
+DEFINE_PRIMITIVE(gc_stats)
-DEFINE_PRIMITIVE(gc_time)
 {
-	box_unsigned_8(gc_time);
+	GROWABLE_ARRAY(stats);
+
+	CELL i;
+	CELL total_gc_time = 0;
+
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+	{
+		F_GC_STATS *s = &gc_stats[i];
+		GROWABLE_ADD(stats,allot_cell(s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->object_count));
+		GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+
+		total_gc_time += s->gc_time;
+	}
+
+	GROWABLE_ADD(stats,allot_cell(total_gc_time));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+	GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+
+	GROWABLE_TRIM(stats);
+	dpush(stats);
+}
+
+DEFINE_PRIMITIVE(gc_reset)
+{
+	gc_reset();
 }
 
 DEFINE_PRIMITIVE(become)
@@ -809,7 +908,7 @@ DEFINE_PRIMITIVE(become)
 		critical_error("bad parameters to become",0);
 
 	CELL i;
-	
+
 	for(i = 0; i < capacity; i++)
 	{
 		CELL old_obj = array_nth(old_objects,i);

vm/data_gc.h

@@ -44,8 +44,14 @@ typedef struct {
 	F_ZONE *generations;
 	F_ZONE* semispaces;
 
+	CELL *allot_markers;
+	CELL *allot_markers_end;
+
 	CELL *cards;
 	CELL *cards_end;
+
+	CELL *decks;
+	CELL *decks_end;
 } F_DATA_HEAP;
 
 F_DATA_HEAP *data_heap;
@@ -71,25 +77,39 @@ offset within the card */
 #define CARD_BITS 6
 #define ADDR_CARD_MASK (CARD_SIZE-1)
 
-INLINE void clear_card(F_CARD *c)
-{
-	*c = CARD_BASE_MASK; /* invalid value */
-}
-
 DLLEXPORT CELL cards_offset;
-void init_cards_offset(void);
+DLLEXPORT CELL allot_markers_offset;
 
 #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
 #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
 
+/* A deck is 4 kilobytes or 64 cards. */
+typedef u8 F_DECK;
+
+#define DECK_SIZE (4 * 1024)
+#define DECK_BITS 12
+#define ADDR_DECK_MASK (DECK_SIZE-1)
+
+DLLEXPORT CELL decks_offset;
+
+#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
+#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
+
+#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
+
+#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
+#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+
+void init_card_decks(void);
+
 /* this is an inefficient write barrier. compiled definitions use a more
 efficient one hand-coded in assembly. the write barrier must be called
 any time we are potentially storing a pointer from an older generation
 to a younger one */
 INLINE void write_barrier(CELL address)
 {
-	F_CARD *c = ADDR_TO_CARD(address);
+	*ADDR_TO_CARD(address) = CARD_MARK_MASK;
-	*c |= (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING);
+	*ADDR_TO_DECK(address) = CARD_MARK_MASK;
 }
 
 #define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
@@ -103,11 +123,10 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value)
 /* we need to remember the first object allocated in the card */
 INLINE void allot_barrier(CELL address)
 {
-	F_CARD *ptr = ADDR_TO_CARD(address);
+	F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
-	F_CARD c = *ptr;
+	F_CARD b = *ptr;
-	CELL b = (c & CARD_BASE_MASK);
+	F_CARD a = (address & ADDR_CARD_MASK);
-	CELL a = (address & ADDR_CARD_MASK);
+	*ptr = (b < a ? b : a);
-	*ptr = ((c & CARD_MARK_MASK) | ((b < a) ? b : a));
 }
 
 void clear_cards(CELL from, CELL to);
@@ -122,6 +141,8 @@ void collect_cards(void);
 /* the oldest generation */
 #define TENURED (data_heap->gen_count-1)
 
+#define MAX_GEN_COUNT 3
+
 /* used during garbage collection only */
 F_ZONE *newspace;
 
@@ -142,10 +163,18 @@ void init_data_heap(CELL gens,
 	bool secure_gc_);
 
 /* statistics */
-s64 gc_time;
+typedef struct {
-CELL nursery_collections;
+	CELL collections;
-CELL aging_collections;
+	CELL gc_time;
-CELL cards_scanned;
+	CELL max_gc_time;
+	CELL object_count;
+	u64 bytes_copied;
+} F_GC_STATS;
+
+F_GC_STATS gc_stats[MAX_GEN_COUNT];
+u64 cards_scanned;
+u64 decks_scanned;
+CELL code_heap_scans;
 
 /* only meaningful during a GC */
 bool performing_gc;
@@ -364,7 +393,8 @@ INLINE void* allot_object(CELL type, CELL a)
 CELL collect_next(CELL scan);
 
 DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_time);
+DECLARE_PRIMITIVE(gc_stats);
+DECLARE_PRIMITIVE(gc_reset);
 DECLARE_PRIMITIVE(become);
 
 CELL find_all_words(void);

vm/os-linux.c

@@ -18,6 +18,8 @@ const char *vm_executable_path(void)
 	}
 }
 
+#ifdef SYS_inotify_init
+
 int inotify_init(void)
 {
 	return syscall(SYS_inotify_init);
@@ -32,3 +34,25 @@ int inotify_rm_watch(int fd, u32 wd)
 {
 	return syscall(SYS_inotify_rm_watch, fd, wd);
 }
+
+#else
+
+int inotify_init(void)
+{
+	not_implemented_error();
+	return -1;
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+	not_implemented_error();
+	return -1;
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+	not_implemented_error();
+	return -1;
+}
+
+#endif

vm/primitives.c

@@ -91,7 +91,7 @@ void *primitives[] = {
 	primitive_existsp,
 	primitive_read_dir,
 	primitive_gc,
-	primitive_gc_time,
+	primitive_gc_stats,
 	primitive_save_image,
 	primitive_save_image_and_exit,
 	primitive_datastack,
@@ -186,4 +186,5 @@ void *primitives[] = {
 	primitive_resize_float_array,
 	primitive_dll_validp,
 	primitive_unimplemented,
+	primitive_gc_reset,
 };