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

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

db4
Alex Chapman 2008-05-09 16:49:18 +10:00
parent 347ba14bd1 fb605aadad
commit ee2814ae05
47 changed files with 550 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/bootstrap/primitives.factor
View File

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

3
core/checksums/checksums-docs.factor
View File

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

1
core/compiler/constants/constants.factor
View File

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

20
core/cpu/ppc/intrinsics/intrinsics.factor
View File

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

5
core/cpu/x86/32/32.factor
View File

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

5
core/cpu/x86/64/64.factor
View File

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

11
core/cpu/x86/architecture/architecture.factor
View File

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

3
core/cpu/x86/assembler/assembler-tests.factor
View File

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

202
core/cpu/x86/assembler/assembler.factor
View File

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

8
core/cpu/x86/intrinsics/intrinsics.factor
View File

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

4
core/inference/known-words/known-words.factor
View File

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

2
core/inference/state/state-tests.factor
View File

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

4
core/io/files/files-docs.factor
View File

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

4
core/io/io-docs.factor
View File

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

2
core/io/io.factor
View File

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

4
core/memory/memory-docs.factor
View File

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

2
extra/benchmark/benchmark.factor
View File

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

2
extra/benchmark/binary-trees/binary-trees.factor
View File

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

3
extra/benchmark/partial-sums/partial-sums.factor
View File

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

11
extra/checksums/adler-32/adler-32-docs.factor Executable file
View File

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

5
extra/checksums/adler-32/adler-32-tests.factor Normal file
View File

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

15
extra/checksums/adler-32/adler-32.factor Normal file
View File

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

1
extra/checksums/adler-32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

4
extra/cocoa/application/application-docs.factor
View File

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

3
extra/cocoa/application/application.factor
View File

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

2
extra/optimizer/report/report.factor
View File

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

6
extra/project-euler/ave-time/ave-time-docs.factor
View File

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

13
extra/project-euler/ave-time/ave-time.factor
View File

@ -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 [
dup second # " ms run / " % first # " ms GC ave time - " % # " trials" %
[ collect-benchmarks ] keep swap mean round [
# " ms run time - " % # " trials" %
] "" make print flush ; inline

2
extra/reports/optimizer/optimizer.factor
View File

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

2
extra/taxes/taxes-tests.factor
View File

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

2
extra/tools/deploy/config/config-docs.factor
View File

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

1
extra/tools/memory/memory.factor
View File

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

4
extra/tools/test/test.factor
View File

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

16
extra/tools/time/time-docs.factor
View File

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

56
extra/tools/time/time.factor
View File

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

2
extra/ui/backend/backend.factor
View File

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

18
extra/ui/cocoa/cocoa.factor
View File

@ -14,18 +14,13 @@ C: <handle> 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

18
extra/ui/ui.factor
View File

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

20
extra/ui/windows/windows.factor
View File

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

8
extra/ui/x11/x11.factor
View File

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

6
extra/unix/ffi/ffi.factor Normal file
View File

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

17
extra/unix/unix.factor
View File

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

4
vm/Config.unix
View File

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

219
vm/data_gc.c
View File

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

66
vm/data_gc.h
View File

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

24
vm/os-linux.c
View File

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

3
vm/primitives.c
View File

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