diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6149e83893..3ce783d620 100755 --- a/core/bootstrap/primitives.factor +++ b/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 diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index c352f02af4..9196008ba6 100644 --- a/core/checksums/checksums-docs.factor +++ b/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" } ; diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 11f64c9373..9594cf7b23 100755 --- a/core/compiler/constants/constants.factor +++ b/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 diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 34e9900893..d85c70577e 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/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 - "val" operand "scratch" operand 0 LBZ - "val" operand dup card-mark ORI - "val" operand "scratch" operand 0 STB + "obj" operand "scratch2" operand card-bits SRWI + "val" operand "scratch2" operand "val" operand STBX + + ! 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" } } } } diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 50e38f2082..9ef8177cf3 100755 --- a/core/cpu/x86/32/32.factor +++ b/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 -- ) - (CALL) rel-dlsym ; +M: x86.32 %alien-global 0 [] MOV rc-absolute-cell 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 ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 5f396e7751..9c44a6a656 100755 --- a/core/cpu/x86/64/64.factor +++ b/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 ( -- ) diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index f0ca47a1ba..88881b19a8 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/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 -memory namespaces sequences words generator generator.registers -generator.fixup system layouts combinators compiler.constants -math.order ; +cpu.x86.assembler cpu.x86.assembler.private cpu.architecture +kernel kernel.private math memory namespaces sequences words +generator generator.registers generator.fixup system layouts +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 -- ) - [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; +HOOK: %alien-global cpu ( symbol dll register -- ) M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index caa00bd618..4c0f04fcc2 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/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 OR ] { } make ] unit-test +[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index cabd81dad6..bc6a12d167 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/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 + ; ! 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 indirect-displacement [ - drop - ] [ - 0 swap set-indirect-displacement - ] if - ] [ - drop - ] if ; + dup base>> { EBP RBP R13 } member? [ + dup displacement>> [ 0 >>displacement ] unless + ] when drop ; : canonicalize-ESP #! { ESP } ==> { ESP ESP } - dup indirect-base { ESP RSP R12 } memq? [ - ESP swap set-indirect-index - ] [ - drop - ] if ; + dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ; : canonicalize ( indirect -- ) #! Modify the indirect to work around certain addressing mode #! quirks. - dup canonicalize-EBP - canonicalize-ESP ; + [ canonicalize-EBP ] [ canonicalize-ESP ] bi ; : ( 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? - over indirect-index rot indirect-scale or or ; + [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri 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 [ - indirect-displacement { - { [ dup not ] [ BIN: 00 ] } - { [ dup byte? ] [ BIN: 01 ] } - { [ dup integer? ] [ BIN: 10 ] } + dup base>> [ + displacement>> { + { [ dup not ] [ BIN: 00 ] } + { [ dup fits-in-byte? ] [ BIN: 01 ] } + { [ 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* - over indirect-index* 3 shift bitor - swap indirect-scale* 6 shift bitor , + [ indirect-base* ] + [ indirect-index* 3 shift ] + [ 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 [ - swap indirect-base - [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if + dup displacement>> dup [ + swap base>> + [ 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 -- ? ) - dup indirect? [ - dup indirect-base register-64? - swap indirect-index register-64? or - ] [ - register-64? - ] if ; +GENERIC: operand-64? ( operand -- ? ) + +M: indirect operand-64? + [ base>> ] [ index>> ] bi [ operand-64? ] either? ; + +M: register-64 operand-64? drop t ; + +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? - [ BIN: 00000010 bitor ] when + index>> extended? [ 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 -- ) - 1-operand , ; +: immediate-operand-size-bit + 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? [ - r> r> BIN: 10 opcode-or immediate-1 + pick fits-in-byte? [ + 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: operand PUSH BIN: 110 f HEX: ff 1-operand ; +M: immediate PUSH HEX: 68 , 4, ; +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 ; -: NEG ( dst -- ) BIN: 011 t HEX: f7 1-operand ; -: MUL ( dst -- ) BIN: 100 t HEX: f7 1-operand ; -: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ; -: DIV ( dst -- ) BIN: 110 t HEX: f7 1-operand ; -: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ; +: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ; +: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ; +: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ; +: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ; +: DIV ( dst -- ) { BIN: 110 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 ; -: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ; -: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ; -: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ; -: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ; -: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ; -: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ; +: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ; +: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ; +: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ; +: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ; +: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ; +: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } 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 ; -: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ; +: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ; +: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ; -: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ; -: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ; +: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ; +: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ; ! SSE multimedia instructions diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index c48f33b765..667f08c053 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/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 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 MOV ] unless ; \ set-slot { diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index b68c98d25d..ff5fc478ca 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -362,7 +362,7 @@ M: object infer-call \ gc { } { } set-primitive-effect -\ gc-time { } { integer } set-primitive-effect +\ gc-stats { } { array } set-primitive-effect \ save-image { string } { } set-primitive-effect @@ -372,7 +372,7 @@ M: object infer-call t over set-effect-terminated? set-primitive-effect -\ data-room { } { integer array } set-primitive-effect +\ data-room { } { integer integer array } set-primitive-effect \ data-room make-flushable \ code-room { } { integer integer integer integer } set-primitive-effect diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index fe1f51a5e7..c63786dc9e 100644 --- a/core/inference/state/state-tests.factor +++ b/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 ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index d18babf31b..ec74bb001e 100755 --- a/core/io/files/files-docs.factor +++ b/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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ddea4da556..2d74dfabd5 100755 --- a/core/io/io-docs.factor +++ b/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 diff --git a/core/io/io.factor b/core/io/io.factor index e28fd28fb3..6bad8331db 100755 --- a/core/io/io.factor +++ b/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 ) diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 75876a3c8f..38f39ec588 100755 --- a/core/memory/memory-docs.factor +++ b/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." } ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a75251331f..c00087fc9f 100755 --- a/extra/benchmark/benchmark.factor +++ b/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 ) diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor index 6e63877989..bd3d460961 100644 --- a/extra/benchmark/binary-trees/binary-trees.factor +++ b/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 diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor index b4bb1fa8d2..8eb883241b 100644 --- a/extra/benchmark/partial-sums/partial-sums.factor +++ b/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 ; diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/extra/checksums/adler-32/adler-32-docs.factor new file mode 100755 index 0000000000..b7400cbaa0 --- /dev/null +++ b/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" diff --git a/extra/checksums/adler-32/adler-32-tests.factor b/extra/checksums/adler-32/adler-32-tests.factor new file mode 100644 index 0000000000..ccee74baae --- /dev/null +++ b/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 adler-32 checksum-bytes ] unit-test diff --git a/extra/checksums/adler-32/adler-32.factor b/extra/checksums/adler-32/adler-32.factor new file mode 100644 index 0000000000..1be4bfb584 --- /dev/null +++ b/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] v. ] [ length ] bi + ] bi + [ adler-32-modulus mod ] bi@ 16 shift bitor ; diff --git a/extra/checksums/adler-32/authors.txt b/extra/checksums/adler-32/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/checksums/adler-32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/cocoa/application/application-docs.factor b/extra/cocoa/application/application-docs.factor index ad2f8ffbd9..01a79cf35a 100644 --- a/extra/cocoa/application/application-docs.factor +++ b/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 } ; diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 2ae17a1604..90159c1656 100755 --- a/extra/cocoa/application/application.factor +++ b/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 diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 70756e81c2..60b83819d5 100755 --- a/extra/optimizer/report/report.factor +++ b/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 ; diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor index cc40ae4bf1..d8ee0846b0 100644 --- a/extra/project-euler/ave-time/ave-time-docs.factor +++ b/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 diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index b908dbd7b0..c8212b4009 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/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 - - : 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 [ - dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % + [ collect-benchmarks ] keep swap mean round [ + # " ms run time - " % # " trials" % ] "" make print flush ; inline diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 06e76d0a99..51eae24333 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/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 -- ) diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 32dbd0d625..17d1998f67 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -111,6 +111,6 @@ IN: taxes.tests 24000 2008 2 f withholding biweekly dollars/cents ] unit-test -[ 754 22 ] [ +[ 754 72 ] [ 78250 2008 2 f withholding biweekly dollars/cents ] unit-test diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 4af1219daf..2960cf452d 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/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." diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index b8fdcab280..9628b218e9 100644 --- a/extra/tools/memory/memory.factor +++ b/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 -- ) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 854ef7af0e..8ef80c6add 100755 --- a/extra/tools/test/test.factor +++ b/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 diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor index 36ab3c01d4..c0afa920c4 100644 --- a/extra/tools/time/time-docs.factor +++ b/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." } -{ $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" } -} ; +{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ; -{ gc-time benchmark millis time } related-words +{ benchmark millis time } related-words diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor index 4862cc2b27..0a0121c74e 100644 --- a/extra/tools/time/time.factor +++ b/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 -math.parser ; +USING: kernel math math.vectors memory io io.styles prettyprint +namespaces system sequences splitting assocs strings ; IN: tools.time : benchmark ( quot -- gctime runtime ) - millis >r gc-time >r call gc-time r> - millis r> - ; - inline + millis >r call millis r> - ; 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 - [ # " ms run / " % # " ms GC time" % ] "" make print flush ; - inline + gc-reset millis >r call gc-stats millis r> - prefix time. ; inline diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index d95cbd69ed..7ca09b89b4 100755 --- a/extra/ui/backend/backend.factor +++ b/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 -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 59adcf9af1..d1b7f22b41 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -14,18 +14,13 @@ C: handle SINGLETON: cocoa-ui-backend -SYMBOL: stop-after-last-window? - -: event-loop? ( -- ? ) - stop-after-last-window? get-global - [ windows get-global empty? not ] [ t ] if ; - -: event-loop ( -- ) - event-loop? [ +M: cocoa-ui-backend do-events ( -- ) + [ [ - [ NSApp do-events ui-wait ] ui-try - ] with-autorelease-pool event-loop - ] when ; + NSApp [ dup do-event ] [ ] [ ] while drop + ui-wait + ] 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 diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 12565235ab..e864d39f39 100755 --- a/extra/ui/ui.factor +++ b/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 ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index e3e1fc5124..5e17d02542 100755 --- a/extra/ui/windows/windows.factor +++ b/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 -- ) - { - { [ windows get empty? ] [ drop ] } - { [ dup peek-message? ] [ ui-wait event-loop ] } - { [ dup MSG-message WM_QUIT = ] [ drop ] } - [ - dup TranslateMessage drop - dup DispatchMessage drop - event-loop - ] - } cond ; +M: windows-ui-backend do-events + msg-obj get-global + dup peek-message? [ drop ui-wait ] [ + [ TranslateMessage drop ] + [ DispatchMessage drop ] bi + ] if ; : register-wndclassex ( -- class ) "WNDCLASSEX" @@ -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 ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 606a45eba5..50d383e6b8 100755 --- a/extra/ui/x11/x11.factor +++ b/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 diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor new file mode 100644 index 0000000000..11a8405b1d --- /dev/null +++ b/extra/unix/ffi/ffi.factor @@ -0,0 +1,6 @@ + +USING: alien.syntax ; + +IN: unix.ffi + +FUNCTION: int open ( char* path, int flags, int prot ) ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 9005cd2b2a..bc3e3ca162 100755 --- a/extra/unix/unix.factor +++ b/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 ) ; { diff --git a/vm/Config.unix b/vm/Config.unix index e7b19e96e1..a25d0df95e 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -1,4 +1,6 @@ -CFLAGS += -fomit-frame-pointer +ifndef DEBUG + CFLAGS += -fomit-frame-pointer +endif EXE_SUFFIX = DLL_PREFIX = lib diff --git a/vm/data_gc.c b/vm/data_gc.c index 5aa47c8c6c..f44b8a7a05 100755 --- a/vm/data_gc.c +++ b/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 - - (data_heap->segment->start >> CARD_BITS); + CELL start = data_heap->segment->start & ~(DECK_SIZE - 1); + 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); - for(; ptr < last_card; ptr++) - clear_card(ptr); + F_CARD *ptr; + for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0; +} + +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 = (c & CARD_BASE_MASK); + CELL offset = CARD_OFFSET(ptr); - if(offset == CARD_BASE_MASK) + if(offset != CARD_BASE_MASK) { - if(c == 0xff) - critical_error("bad card",(CELL)ptr); - else - return; + CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset; + 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++; + } +} + +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; - 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++; + decks_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); - CELL here = data_heap->generations[gen].here; - F_CARD *last_card = ADDR_TO_CARD(here - 1); + F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start); + F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end); - 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_time) +DEFINE_PRIMITIVE(gc_stats) { - 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); diff --git a/vm/data_gc.h b/vm/data_gc.h index be9ed159b7..20692c14e6 100755 --- a/vm/data_gc.h +++ b/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)<> 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); - *c |= (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING); + *ADDR_TO_CARD(address) = CARD_MARK_MASK; + *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 c = *ptr; - CELL b = (c & CARD_BASE_MASK); - CELL a = (address & ADDR_CARD_MASK); - *ptr = ((c & CARD_MARK_MASK) | ((b < a) ? b : a)); + F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address); + F_CARD b = *ptr; + F_CARD a = (address & ADDR_CARD_MASK); + *ptr = (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; -CELL nursery_collections; -CELL aging_collections; -CELL cards_scanned; +typedef struct { + CELL collections; + CELL gc_time; + 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); diff --git a/vm/os-linux.c b/vm/os-linux.c index 935add6714..91017fc3f8 100644 --- a/vm/os-linux.c +++ b/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 diff --git a/vm/primitives.c b/vm/primitives.c index da04870ecd..133ca38567 100755 --- a/vm/primitives.c +++ b/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, };