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

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

db4
Doug Coleman 2008-05-08 21:50:40 -05:00
parent ce76b1888e 32d5311821
commit a78a3e7b28
40 changed files with 647 additions and 336 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" } { "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" } { "(directory)" "io.files.private" }
{ "gc" "memory" } { "gc" "memory" }
{ "gc-time" "memory" } { "gc-stats" "memory" }
{ "save-image" "memory" } { "save-image" "memory" }
{ "save-image-and-exit" "memory" } { "save-image-and-exit" "memory" }
{ "datastack" "kernel" } { "datastack" "kernel" }
@ -702,6 +702,7 @@ tuple
{ "resize-float-array" "float-arrays" } { "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" } { "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" } { "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
} }
dup length [ >r first2 r> make-primitive ] 2each dup length [ >r first2 r> make-primitive ] 2each

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

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

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

@ -56,14 +56,25 @@ IN: cpu.ppc.intrinsics
: load-cards-offset ( dest -- ) : load-cards-offset ( dest -- )
"cards_offset" f pick %load-dlsym dup 0 LWZ ; "cards_offset" f pick %load-dlsym dup 0 LWZ ;
: load-decks-offset ( dest -- )
"decks_offset" f pick %load-dlsym dup 0 LWZ ;
: %write-barrier ( -- ) : %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [ "val" get operand-immediate? "obj" get fresh-object? or [
! Mark the card
"obj" operand "scratch" operand card-bits SRWI "obj" operand "scratch" operand card-bits SRWI
"val" operand load-cards-offset "val" operand load-cards-offset
"scratch" operand dup "val" operand ADD "scratch" operand dup "val" operand ADD
"val" operand "scratch" operand 0 LBZ "val" operand "scratch" operand 0 LBZ
"val" operand dup card-mark ORI "val" operand dup card-mark ORI
"val" operand "scratch" operand 0 STB "val" operand "scratch" operand 0 STB
! Mark the card deck
"obj" operand "scratch" operand deck-bits SRWI
"val" operand load-decks-offset
"scratch" operand dup "val" operand ADD
card-mark "val" operand LI
"val" operand "scratch" operand 0 STB
] unless ; ] unless ;
\ set-slot { \ set-slot {

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: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX 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

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

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

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

@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics
: generate-write-barrier ( -- ) : generate-write-barrier ( -- )
#! Mark the card pointed to by vreg. #! Mark the card pointed to by vreg.
"val" get operand-immediate? "obj" get fresh-object? or [ "val" get operand-immediate? "obj" get fresh-object? or [
! Mark the card
"obj" operand card-bits SHR "obj" operand card-bits SHR
"cards_offset" f temp-reg v>operand %alien-global "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> OR
! 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 ; ] unless ;
\ set-slot { \ 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 { } { } <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 \ save-image { string } { } <effect> set-primitive-effect
@ -372,7 +372,7 @@ M: object infer-call
t over set-effect-terminated? t over set-effect-terminated?
set-primitive-effect set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect \ data-room { } { integer integer array } <effect> set-primitive-effect
\ data-room make-flushable \ data-room make-flushable
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect \ code-room { } { integer integer integer integer } <effect> set-primitive-effect

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

@ -273,11 +273,11 @@ $nl
HELP: append-path HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $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 HELP: prepend-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Appends str1 onto str2 to form a pathname." } ; { $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
{ append-path prepend-path } related-words { append-path prepend-path } related-words

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

@ -125,7 +125,7 @@ $nl
ABOUT: "streams" ABOUT: "streams"
HELP: stream-readln 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." } { $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" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
$io-error ; $io-error ;
@ -139,7 +139,7 @@ $io-error ;
HELP: stream-read HELP: stream-read
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } { $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." } { $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 ; $io-error ;
HELP: stream-read-until 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 ; continuations assocs io.styles ;
IN: io IN: io
GENERIC: stream-readln ( stream -- str ) GENERIC: stream-readln ( stream -- str/f )
GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read ( n stream -- str/f )
GENERIC: stream-read-until ( seps stream -- str/f sep/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 ( -- ) HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ; { $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 ) HELP: data-room ( -- cards generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } { $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ; { $description "Queries the runtime for memory usage information." } ;

2
extra/benchmark/benchmark.factor
View File

@ -6,7 +6,7 @@ continuations debugger ;
IN: benchmark IN: benchmark
: run-benchmark ( vocab -- result ) : run-benchmark ( vocab -- result )
[ [ require ] [ [ run ] benchmark nip ] bi ] curry [ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ; [ error. f ] recover ;
: run-benchmarks ( -- assoc ) : 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 ( -- ) : binary-trees-main ( -- )
16 binary-trees ; 16 binary-trees ;
MAIN: binary-trees-main

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

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

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

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

12
extra/jamshred/deploy.factor Normal file
View File

@ -0,0 +1,12 @@
USING: tools.deploy.config ;
V{
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-name "Jamshred" }
}

21
extra/jamshred/game/game.factor
View File

@ -1,26 +1,31 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl arrays sequences jamshred.tunnel USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
jamshred.player math.vectors ;
IN: jamshred.game IN: jamshred.game
TUPLE: jamshred tunnel players running ; TUPLE: jamshred sounds tunnel players running quit ;
: <jamshred> ( -- jamshred ) : <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f <sounds> <random-tunnel> "Player 1" pick <player>
jamshred boa ; 2dup swap play-in-tunnel 1array f f jamshred boa ;
: jamshred-player ( jamshred -- player ) : jamshred-player ( jamshred -- player )
! TODO: support more than one player ! TODO: support more than one player
jamshred-players first ; players>> first ;
: jamshred-update ( jamshred -- ) : jamshred-update ( jamshred -- )
dup jamshred-running [ dup running>> [
jamshred-player update-player jamshred-player update-player
] [ drop ] if ; ] [ drop ] if ;
: toggle-running ( jamshred -- ) : toggle-running ( jamshred -- )
dup jamshred-running not swap set-jamshred-running ; dup running>> [
f >>running drop
] [
[ jamshred-player moved ]
[ t >>running drop ] bi
] if ;
: mouse-moved ( x-radians y-radians jamshred -- ) : mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ; jamshred-player -rot turn-player ;

59
extra/jamshred/jamshred.factor
View File

@ -1,38 +1,48 @@
! Copyright (C) 2007, 2008 Alex Chapman ! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
math.vectors ;
IN: jamshred IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
: <jamshred-gadget> ( jamshred -- gadget ) : <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; jamshred-gadget construct-gadget swap >>jamshred ;
: default-width ( -- x ) 1024 ; : default-width ( -- x ) 800 ;
: default-height ( -- y ) 768 ; : default-height ( -- y ) 600 ;
M: jamshred-gadget pref-dim* M: jamshred-gadget pref-dim*
drop default-width default-height 2array ; drop default-width default-height 2array ;
M: jamshred-gadget draw-gadget* ( gadget -- ) M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
: tick ( gadget -- ) : jamshred-loop ( gadget -- )
dup jamshred-gadget-jamshred jamshred-update relayout-1 ; dup jamshred>> quit>> [
drop
] [
dup [ jamshred>> jamshred-update ]
[ relayout-1 ] bi
yield jamshred-loop
] if ;
: fullscreen ( gadget -- )
find-world t swap set-fullscreen* ;
: no-fullscreen ( gadget -- )
find-world f swap set-fullscreen* ;
: toggle-fullscreen ( world -- )
[ fullscreen? not ] keep set-fullscreen* ;
M: jamshred-gadget graft* ( gadget -- ) M: jamshred-gadget graft* ( gadget -- )
[ [ jamshred-loop ] in-thread drop ;
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
] keep set-jamshred-gadget-alarm ;
M: jamshred-gadget ungraft* ( gadget -- ) M: jamshred-gadget ungraft* ( gadget -- )
[ jamshred-gadget-alarm cancel-alarm f ] keep jamshred>> t swap (>>quit) ;
set-jamshred-gadget-alarm ;
: jamshred-restart ( jamshred-gadget -- ) : jamshred-restart ( jamshred-gadget -- )
<jamshred> swap set-jamshred-gadget-jamshred ; <jamshred> >>jamshred drop ;
: pix>radians ( n m -- theta ) : pix>radians ( n m -- theta )
2 / / pi 2 * * ; 2 / / pi 2 * * ;
@ -46,22 +56,31 @@ M: jamshred-gadget ungraft* ( gadget -- )
rect-dim second pix>radians ; rect-dim second pix>radians ;
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
over jamshred-gadget-jamshred >r over jamshred>> >r
[ first swap x>radians ] 2keep second swap y>radians [ first swap x>radians ] 2keep second swap y>radians
r> mouse-moved ; r> mouse-moved ;
: handle-mouse-motion ( jamshred-gadget -- ) : handle-mouse-motion ( jamshred-gadget -- )
hand-loc get [ hand-loc get [
over jamshred-gadget-last-hand-loc [ over last-hand-loc>> [
v- (handle-mouse-motion) v- (handle-mouse-motion)
] [ 2drop ] if* ] [ 2drop ] if*
] 2keep swap set-jamshred-gadget-last-hand-loc ; ] 2keep >>last-hand-loc drop ;
: handle-mouse-scroll ( jamshred-gadget -- )
jamshred>> jamshred-player scroll-direction get
second neg swap change-player-speed ;
: quit ( gadget -- )
[ no-fullscreen ] [ close-window ] bi ;
USE: vocabs.loader
jamshred-gadget H{ jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] }
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
{ T{ key-down f f "q" } [ quit ] }
{ T{ motion } [ handle-mouse-motion ] } { T{ motion } [ handle-mouse-motion ] }
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures } set-gestures
: jamshred-window ( -- ) : jamshred-window ( -- )

10
extra/jamshred/log/log.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel logging ;
IN: jamshred.log
LOG: (jamshred-log) DEBUG
: with-jamshred-log ( quot -- )
"jamshred" swap with-logging ;
: jamshred-log ( message -- )
[ (jamshred-log) ] with-jamshred-log ; ! ugly...

8
extra/jamshred/oint/oint-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: jamshred.oint tools.test ;
IN: jamshred.oint-tests
[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test

59
extra/jamshred/oint/oint.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
IN: jamshred.oint IN: jamshred.oint
! An oint is a point with three linearly independent unit vectors ! An oint is a point with three linearly independent unit vectors
@ -9,47 +9,25 @@ IN: jamshred.oint
! segment's location and orientation are given by an oint. ! segment's location and orientation are given by an oint.
TUPLE: oint location forward up left ; TUPLE: oint location forward up left ;
C: <oint> oint
: <oint> ( location forward up left -- oint )
oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
! #! { { 1 0 0 }
! #! { 0 cos(theta) sin(theta) }
! #! { 0 -sin(theta) cos(theta) } }
! dup sin neg swap cos 2dup 0 -rot 3float-array >r
! swap neg 0 -rot 3float-array >r
! { 1 0 0 } r> r> 3float-array ;
!
! : y-rotation ( theta -- matrix )
! #! costruct this matrix:
! #! { { cos(theta) 0 -sin(theta) }
! #! { 0 1 0 }
! #! { sin(theta) 0 cos(theta) } }
! dup sin swap cos 2dup
! 0 swap 3float-array >r
! { 0 1 0 } >r
! 0 rot neg 3float-array r> r> 3float-array ;
: apply-to-oint ( oint quot -- )
#! apply quot to each of forward, up, and left, storing the results
over oint-forward over call pick set-oint-forward
over oint-up over call pick set-oint-up
over oint-left swap call swap set-oint-left ;
: rotation-quaternion ( theta axis -- quaternion ) : rotation-quaternion ( theta axis -- quaternion )
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
: rotate-vector ( q qrecip v -- v )
v>q swap q* q* q>v ;
: rotate-oint ( oint theta axis -- ) : rotate-oint ( oint theta axis -- )
rotation-quaternion dup qrecip rotation-quaternion dup qrecip pick
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ; [ forward>> rotate-vector >>forward ]
[ up>> rotate-vector >>up ]
[ left>> rotate-vector >>left ] 3tri drop ;
: left-pivot ( oint theta -- ) : left-pivot ( oint theta -- )
over oint-left rotate-oint ; over left>> rotate-oint ;
: up-pivot ( oint theta -- ) : up-pivot ( oint theta -- )
over oint-up rotate-oint ; over up>> rotate-oint ;
: random-float+- ( n -- m ) : random-float+- ( n -- m )
#! find a random float between -n/2 and n/2 #! find a random float between -n/2 and n/2
@ -59,10 +37,10 @@ TUPLE: oint location forward up left ;
2 / 2dup random-float+- left-pivot random-float+- up-pivot ; 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
: go-forward ( distance oint -- ) : go-forward ( distance oint -- )
tuck oint-forward n*v over oint-location v+ swap set-oint-location ; [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
: distance-vector ( oint oint -- vector ) : distance-vector ( oint oint -- vector )
oint-location swap oint-location v- ; [ location>> ] bi@ swap v- ;
: distance ( oint oint -- distance ) : distance ( oint oint -- distance )
distance-vector norm ; distance-vector norm ;
@ -71,6 +49,13 @@ TUPLE: oint location forward up left ;
#! the scalar projection of v1 onto v2 #! the scalar projection of v1 onto v2
tuck v. swap norm / ; tuck v. swap norm / ;
: proj-perp ( u v -- w )
dupd proj v- ;
: perpendicular-distance ( oint oint -- distance ) : perpendicular-distance ( oint oint -- distance )
tuck distance-vector swap 2dup oint-left scalar-projection abs tuck distance-vector swap 2dup left>> scalar-projection abs
-rot oint-up scalar-projection abs + ; -rot up>> scalar-projection abs + ;
:: reflect ( v n -- v' )
#! bounce v on a surface with normal n
v v n v. n n v. / 2 * n n*v v- ;

64
extra/jamshred/player/player.factor
View File

@ -1,38 +1,68 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: colors jamshred.oint jamshred.tunnel kernel USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
math math.constants sequences ;
IN: jamshred.player IN: jamshred.player
TUPLE: player name tunnel nearest-segment ; TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: <player> ( name -- player ) ! speeds are in GL units / second
f f player boa : default-speed ( -- speed ) 1.0 ;
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ; : max-speed ( -- speed ) 30.0 ;
: <player> ( name sounds -- player )
[ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
f f f default-speed player boa ;
: turn-player ( player x-radians y-radians -- ) : turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ; >r over r> left-pivot up-pivot ;
: to-tunnel-start ( player -- ) : to-tunnel-start ( player -- )
dup player-tunnel first dup oint-location pick set-oint-location [ tunnel>> first dup location>> ]
swap set-player-nearest-segment ; [ tuck (>>location) (>>nearest-segment) ] bi ;
: play-in-tunnel ( player segments -- ) : play-in-tunnel ( player segments -- )
over set-player-tunnel to-tunnel-start ; >>tunnel to-tunnel-start ;
: update-nearest-segment ( player -- ) : update-nearest-segment ( player -- )
dup player-tunnel over dup player-nearest-segment nearest-segment [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
swap set-player-nearest-segment ; [ (>>nearest-segment) ] tri ;
: max-speed ( -- speed ) : moved ( player -- ) millis swap (>>last-move) ;
0.3 ;
: player-speed ( player -- speed ) : speed-range ( -- range )
dup player-nearest-segment fraction-from-wall sq max-speed * ; max-speed [0,b] ;
: change-player-speed ( inc player -- )
[ + speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance )
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ;
DEFER: (move-player)
: ?bounce ( distance-remaining player -- )
over 0 > [
[ dup nearest-segment>> bounce ] [ sounds>> bang ]
[ (move-player) ] tri
] [
2drop
] if ;
: move-player-distance ( distance-remaining player distance -- distance-remaining player )
pick min tuck over go-forward [ - ] dip ;
: (move-player) ( distance-remaining player -- )
over 0 <= [
2drop
] [
dup dup nearest-segment>> distance-to-collision
move-player-distance ?bounce
] if ;
: move-player ( player -- ) : move-player ( player -- )
dup player-speed over go-forward update-nearest-segment ; [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
: update-player ( player -- ) : update-player ( player -- )
dup move-player player-nearest-segment dup move-player nearest-segment>>
white swap set-segment-color ; white swap set-segment-color ;

BIN
extra/jamshred/sound/bang.wav Normal file
View File

Binary file not shown.

13
extra/jamshred/sound/sound.factor Normal file
View File

@ -0,0 +1,13 @@
USING: accessors io.files kernel openal sequences ;
IN: jamshred.sound
TUPLE: sounds bang ;
: assign-sound ( source wav-path -- )
resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
: <sounds> ( -- sounds )
init-openal 1 gen-sources first sounds boa
dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
: bang ( sounds -- ) bang>> source-play check-error ;

31
extra/jamshred/tunnel/tunnel-tests.factor
View File

@ -3,8 +3,8 @@
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
IN: jamshred.tunnel.tests IN: jamshred.tunnel.tests
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } [ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
T{ segment T{ oint f { 1 1 1 } } 1 } T{ segment f { 1 1 1 } f f f 1 }
T{ oint f { 0 0 0.25 } } T{ oint f { 0 0 0.25 } }
nearer-segment segment-number ] unit-test nearer-segment segment-number ] unit-test
@ -15,3 +15,30 @@ IN: jamshred.tunnel.tests
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test [ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test [ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
: test-segment-oint ( -- oint )
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
: simplest-straight-ahead ( -- oint segment )
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
initial-segment ;
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
: simple-collision-up ( -- oint segment )
{ 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
initial-segment ;
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test

81
extra/jamshred/tunnel/tunnel.factor
View File

@ -1,23 +1,20 @@
! Copyright (C) 2007 Alex Chapman ! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel jamshred.oint math math.functions USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
math.ranges math.vectors math.constants random sequences vectors ;
IN: jamshred.tunnel IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline : n-segments ( -- n ) 5000 ; inline
TUPLE: segment number color radius ; TUPLE: segment < oint number color radius ;
C: <segment> segment
: <segment> ( number color radius location forward up left -- segment )
<oint> >r segment boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex ) : segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n tuck 2dup up>> swap sin v*n
>r oint-left swap cos v*n r> v+ >r left>> swap cos v*n r> v+
swap oint-location v+ ; swap location>> v+ ;
: segment-vertex-normal ( vertex segment -- normal ) : segment-vertex-normal ( vertex segment -- normal )
oint-location swap v- normalize ; location>> swap v- normalize ;
: segment-vertex-and-normal ( segment theta -- vertex normal ) : segment-vertex-and-normal ( segment theta -- vertex normal )
swap [ segment-vertex ] keep dupd segment-vertex-normal ; swap [ segment-vertex ] keep dupd segment-vertex-normal ;
@ -27,7 +24,7 @@ TUPLE: segment number color radius ;
dup [ / pi 2 * * ] curry map ; dup [ / pi 2 * * ] curry map ;
: segment-number++ ( segment -- ) : segment-number++ ( segment -- )
dup segment-number 1+ swap set-segment-number ; [ number>> 1+ ] keep (>>number) ;
: random-color ( -- color ) : random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
: default-segment-radius ( -- r ) 1 ; : default-segment-radius ( -- r ) 1 ;
: initial-segment ( -- segment ) : initial-segment ( -- segment )
0 random-color default-segment-radius F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ; 0 random-color default-segment-radius <segment> ;
: random-segments ( n -- segments ) : random-segments ( n -- segments )
initial-segment 1vector swap (random-segments) ; initial-segment 1vector swap (random-segments) ;
: simple-segment ( n -- segment ) : simple-segment ( n -- segment )
random-color default-segment-radius pick F{ 0 0 -1 } n*v [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ; random-color default-segment-radius <segment> ;
: simple-segments ( n -- segments ) : simple-segments ( n -- segments )
[ simple-segment ] map ; [ simple-segment ] map ;
@ -100,14 +97,54 @@ TUPLE: segment number color radius ;
[ nearest-segment-forward ] 3keep [ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ; nearest-segment-backward r> nearer-segment ;
: distance-from-centre ( oint segment -- distance ) : vector-to-centre ( seg loc -- v )
perpendicular-distance ; over location>> swap v- swap forward>> proj-perp ;
: distance-from-wall ( oint segment -- distance ) : distance-from-centre ( seg loc -- distance )
tuck distance-from-centre swap segment-radius swap - ; vector-to-centre norm ;
: fraction-from-centre ( oint segment -- fraction ) : wall-normal ( seg oint -- n )
tuck distance-from-centre swap segment-radius / ; location>> vector-to-centre normalize ;
: fraction-from-wall ( oint segment -- fraction ) : from ( seg loc -- radius d-f-c )
dupd location>> distance-from-centre [ radius>> ] dip ;
: distance-from-wall ( seg loc -- distance ) from - ;
: fraction-from-centre ( seg loc -- fraction ) from / ;
: fraction-from-wall ( seg loc -- fraction )
fraction-from-centre 1 swap - ; fraction-from-centre 1 swap - ;
:: collision-coefficient ( v w r -- c )
[let* | a [ v dup v. ]
b [ v w v. 2 * ]
c [ w dup v. r sq - ] |
c b a quadratic max ] ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
: collision-vector ( oint segment -- v )
[ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
swap [ collision-coefficient ] dip forward>> n*v ;
: distance-to-collision ( oint segment -- distance )
collision-vector norm ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
: bounce-left ( segment oint -- )
#! must be done after forward
[ forward>> vneg ] dip [ left>> swap reflect ]
[ forward>> proj-perp normalize ] [ (>>left) ] tri ;
: bounce-up ( segment oint -- )
#! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
: bounce ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;

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

@ -20,7 +20,7 @@ IN: optimizer.report
[ [
dup [ dup [
word-dataflow nip 1 count-optimization-passes word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array ] benchmark 2array
] { } map>assoc ] { } map>assoc
[ first ] "Worst number of optimizer passes:" results [ first ] "Worst number of optimizer passes:" results
[ second ] "Worst compile times:" 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." "This word can be used to compare performance of the non-optimizing and optimizing compilers."
$nl $nl
"First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" "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:" "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 ; math.statistics namespaces sequences tools.time ;
IN: project-euler.ave-time IN: project-euler.ave-time
<PRIVATE
: ave-benchmarks ( seq -- pair )
flip [ mean round ] map ;
PRIVATE>
: collect-benchmarks ( quot n -- seq ) : 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 [ with-datastack drop ] 2curry r> swap times call
] { } make ; ] { } make ;
: ave-time ( quot n -- ) : ave-time ( quot n -- )
[ collect-benchmarks ] keep swap ave-benchmarks [ [ collect-benchmarks ] keep swap mean round [
dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % # " ms run time - " % # " trials" %
] "" make print flush ; inline ] "" make print flush ; inline

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

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

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

@ -96,7 +96,7 @@ HELP: deploy-io
{ "2" "Basic ANSI C streams" } { "2" "Basic ANSI C streams" }
{ "3" "Non-blocking streams and networking" } { "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 HELP: deploy-reflection
{ $description "The level of reflection support required by the deployed image." { $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* [ first2 ] [ number>string "Generation " prepend ] bi*
write-total/used/free write-total/used/free
] 2each ] 2each
"Decks" write-total
"Cards" write-total ; "Cards" write-total ;
: write-labelled-size ( n string -- ) : 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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces arrays prettyprint sequences kernel USING: namespaces arrays prettyprint sequences kernel
vectors quotations words parser assocs combinators 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 vocabs.loader source-files compiler.units inspector
inference effects tools.vocabs ; inference effects tools.vocabs ;
IN: tools.test IN: tools.test
@ -19,7 +19,7 @@ SYMBOL: this-test
: (unit-test) ( what quot -- ) : (unit-test) ( what quot -- )
swap dup . flush this-test set swap dup . flush this-test set
[ time ] curry failures get [ failures get [
[ this-test get failure ] recover [ this-test get failure ] recover
] [ ] [
call call

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

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

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

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

@ -15,7 +15,12 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- ) M: cocoa-ui-backend do-events ( -- )
[ [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool ; [
[
NSApp [ dup do-event ] [ ] [ ] while drop
ui-wait
] ui-try
] with-autorelease-pool ;
TUPLE: pasteboard handle ; TUPLE: pasteboard handle ;

11
extra/unix/unix.factor
View File

@ -80,14 +80,11 @@ FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: char* strerror ( int errno ) ; FUNCTION: char* strerror ( int errno ) ;
TUPLE: open-error path flags prot message ; ERROR: open-error path flags prot message ;
: open ( path flags prot -- int ) : open ( path flags prot -- int )
[ ] [ unix.ffi:open ] 3bi 3dup unix.ffi:open
dup 0 >= dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ;
[ nip nip nip ]
[ drop err_no strerror open-error boa throw ]
if ;
FUNCTION: int pclose ( void* file ) ; FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ; FUNCTION: int pipe ( int* filedes ) ;
@ -171,8 +168,6 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{ {

184
vm/data_gc.c
View File

@ -21,10 +21,11 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
return z->end; return z->end;
} }
void init_cards_offset(void) void init_card_decks(void)
{ {
cards_offset = (CELL)data_heap->cards CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
- (data_heap->segment->start >> CARD_BITS); 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, F_DATA_HEAP *alloc_data_heap(CELL gens,
@ -62,10 +63,14 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count); data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
data_heap->semispaces = 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->cards = safe_malloc(cards_size); data_heap->cards = safe_malloc(cards_size);
data_heap->cards_end = data_heap->cards + 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; CELL alloter = data_heap->segment->start;
alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter); alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
@ -105,6 +110,7 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
free(data_heap->generations); free(data_heap->generations);
free(data_heap->semispaces); free(data_heap->semispaces);
free(data_heap->cards); free(data_heap->cards);
free(data_heap->decks);
free(data_heap); free(data_heap);
} }
@ -113,20 +119,38 @@ cleared when a generation has been cleared */
void clear_cards(CELL from, CELL to) void clear_cards(CELL from, CELL to)
{ {
/* NOTE: reverse order due to heap layout. */ /* 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 *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start); F_CARD *ptr;
for(; ptr < last_card; ptr++) for(ptr = first_card; ptr < last_card; ptr++)
clear_card(ptr); *ptr = CARD_BASE_MASK; /* invalid value */
}
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 set_data_heap(F_DATA_HEAP *data_heap_) void set_data_heap(F_DATA_HEAP *data_heap_)
{ {
data_heap = data_heap_; data_heap = data_heap_;
nursery = data_heap->generations[NURSERY]; nursery = data_heap->generations[NURSERY];
init_cards_offset(); init_card_decks();
clear_cards(NURSERY,TENURED); clear_cards(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, void init_data_heap(CELL gens,
CELL young_size, CELL young_size,
CELL aging_size, CELL aging_size,
@ -141,11 +165,13 @@ void init_data_heap(CELL gens,
extra_roots_region = alloc_segment(getpagesize()); extra_roots_region = alloc_segment(getpagesize());
extra_roots = extra_roots_region->start - CELLS; extra_roots = extra_roots_region->start - CELLS;
gc_time = 0;
aging_collections = 0;
nursery_collections = 0;
cards_scanned = 0;
secure_gc = secure_gc_; 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 */ /* Size of the object pointed to by a tagged pointer */
@ -228,6 +254,7 @@ DEFINE_PRIMITIVE(data_room)
int gen; int gen;
dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); 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++) for(gen = 0; gen < data_heap->gen_count; gen++)
{ {
@ -283,19 +310,13 @@ DEFINE_PRIMITIVE(end_scan)
} }
/* Scan all the objects in the card */ /* 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; F_CARD c = *ptr;
CELL offset = (c & CARD_BASE_MASK); CELL offset = (c & CARD_BASE_MASK);
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_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1); CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
@ -303,16 +324,47 @@ INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
card_scan = collect_next(card_scan); card_scan = collect_next(card_scan);
cards_scanned++; 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;
}
}
}
}
decks_scanned++;
} }
/* Copy all newspace objects referenced from marked cards to the destination */ /* Copy all newspace objects referenced from marked cards to the destination */
INLINE void collect_gen_cards(CELL gen) void collect_gen_cards(CELL gen)
{ {
F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start); F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
CELL here = data_heap->generations[gen].here; F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
F_CARD *last_card = ADDR_TO_CARD(here - 1);
CELL mask, unmask; F_CARD mask, unmask;
/* if we are collecting the nursery, we care about old->nursery pointers /* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */ but not old->aging pointers */
@ -360,11 +412,13 @@ INLINE void collect_gen_cards(CELL gen)
return; return;
} }
for(; ptr <= last_card; ptr++) F_DECK *ptr;
for(ptr = first_deck; ptr < last_deck; ptr++)
{ {
if(*ptr & mask) if(*ptr & mask)
{ {
collect_card(ptr,gen,here); collect_card_deck(ptr,gen,mask,unmask);
*ptr &= ~unmask; *ptr &= ~unmask;
} }
} }
@ -454,6 +508,11 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
longjmp(gc_jmp,1); longjmp(gc_jmp,1);
allot_barrier(newspace->here); allot_barrier(newspace->here);
newpointer = allot_zone(newspace,size); newpointer = allot_zone(newspace,size);
F_GC_STATS *s = &gc_stats[collecting_gen];
s->object_count++;
s->bytes_copied += size;
memcpy(newpointer,pointer,size); memcpy(newpointer,pointer,size);
return newpointer; return newpointer;
} }
@ -584,6 +643,7 @@ CELL collect_next(CELL scan)
INLINE void reset_generation(CELL i) INLINE void reset_generation(CELL i)
{ {
F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start; z->here = z->start;
if(secure_gc) if(secure_gc)
memset((void*)z->start,69,z->size); memset((void*)z->start,69,z->size);
@ -594,7 +654,9 @@ their allocation pointers and cards reset. */
void reset_generations(CELL from, CELL to) void reset_generations(CELL from, CELL to)
{ {
CELL i; 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_cards(from,to);
} }
@ -638,8 +700,15 @@ void begin_gc(CELL requested_bytes)
#endif #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) if(growing_data_heap)
{ {
dealloc_data_heap(old_data_heap); dealloc_data_heap(old_data_heap);
@ -654,29 +723,12 @@ void end_gc(void)
old-school Cheney collector */ old-school Cheney collector */
if(collecting_gen != NURSERY) if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1); 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 else
{ {
/* all generations up to and including the one /* all generations up to and including the one
collected are now empty */ collected are now empty */
reset_generations(NURSERY,collecting_gen); reset_generations(NURSERY,collecting_gen);
nursery_collections++;
} }
if(collecting_gen == TENURED) if(collecting_gen == TENURED)
@ -758,7 +810,10 @@ void garbage_collection(CELL gen,
literals from any code block which gets marked as live. literals from any code block which gets marked as live.
if we are not doing code GC, just consider all literals if we are not doing code GC, just consider all literals
as roots. */ as roots. */
code_heap_scans++;
collect_literals(); collect_literals();
if(collecting_accumulation_gen_p()) if(collecting_accumulation_gen_p())
last_code_heap_scan = collecting_gen; last_code_heap_scan = collecting_gen;
else else
@ -772,9 +827,8 @@ void garbage_collection(CELL gen,
CELL gc_elapsed = (current_millis() - start); CELL gc_elapsed = (current_millis() - start);
GC_PRINT(END_GC,gc_elapsed); GC_PRINT(END_GC,gc_elapsed);
end_gc(); end_gc(gc_elapsed);
gc_time += gc_elapsed;
performing_gc = false; performing_gc = false;
} }
@ -793,10 +847,38 @@ DEFINE_PRIMITIVE(gc)
gc(); gc();
} }
/* Push total time spent on GC */ DEFINE_PRIMITIVE(gc_stats)
DEFINE_PRIMITIVE(gc_time)
{ {
box_unsigned_8(gc_time); GROWABLE_ARRAY(stats);
CELL i;
CELL total_gc_time = 0;
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
GROWABLE_ADD(stats,allot_cell(s->collections));
GROWABLE_ADD(stats,allot_cell(s->gc_time));
GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ADD(stats,allot_cell(s->object_count));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
GROWABLE_ADD(stats,allot_cell(total_gc_time));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
GROWABLE_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_TRIM(stats);
dpush(stats);
}
DEFINE_PRIMITIVE(gc_reset)
{
gc_reset();
} }
DEFINE_PRIMITIVE(become) DEFINE_PRIMITIVE(become)

51
vm/data_gc.h
View File

@ -46,6 +46,9 @@ typedef struct {
CELL *cards; CELL *cards;
CELL *cards_end; CELL *cards_end;
CELL *decks;
CELL *decks_end;
} F_DATA_HEAP; } F_DATA_HEAP;
F_DATA_HEAP *data_heap; F_DATA_HEAP *data_heap;
@ -71,17 +74,27 @@ offset within the card */
#define CARD_BITS 6 #define CARD_BITS 6
#define ADDR_CARD_MASK (CARD_SIZE-1) #define ADDR_CARD_MASK (CARD_SIZE-1)
INLINE void clear_card(F_CARD *c)
{
*c = CARD_BASE_MASK; /* invalid value */
}
DLLEXPORT CELL cards_offset; DLLEXPORT CELL cards_offset;
void init_cards_offset(void);
#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_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) #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)
void init_card_decks(void);
/* this is an inefficient write barrier. compiled definitions use a more /* this is an inefficient write barrier. compiled definitions use a more
efficient one hand-coded in assembly. the write barrier must be called efficient one hand-coded in assembly. the write barrier must be called
any time we are potentially storing a pointer from an older generation any time we are potentially storing a pointer from an older generation
@ -89,7 +102,10 @@ to a younger one */
INLINE void write_barrier(CELL address) INLINE void write_barrier(CELL address)
{ {
F_CARD *c = ADDR_TO_CARD(address); F_CARD *c = ADDR_TO_CARD(address);
*c |= (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING); *c |= CARD_MARK_MASK;
F_DECK *d = ADDR_TO_DECK(address);
*d = CARD_MARK_MASK ;
} }
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS) #define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
@ -122,6 +138,8 @@ void collect_cards(void);
/* the oldest generation */ /* the oldest generation */
#define TENURED (data_heap->gen_count-1) #define TENURED (data_heap->gen_count-1)
#define MAX_GEN_COUNT 3
/* used during garbage collection only */ /* used during garbage collection only */
F_ZONE *newspace; F_ZONE *newspace;
@ -142,10 +160,18 @@ void init_data_heap(CELL gens,
bool secure_gc_); bool secure_gc_);
/* statistics */ /* statistics */
s64 gc_time; typedef struct {
CELL nursery_collections; CELL collections;
CELL aging_collections; CELL gc_time;
CELL cards_scanned; CELL max_gc_time;
CELL object_count;
u64 bytes_copied;
} F_GC_STATS;
F_GC_STATS gc_stats[MAX_GEN_COUNT];
u64 cards_scanned;
u64 decks_scanned;
CELL code_heap_scans;
/* only meaningful during a GC */ /* only meaningful during a GC */
bool performing_gc; bool performing_gc;
@ -364,7 +390,8 @@ INLINE void* allot_object(CELL type, CELL a)
CELL collect_next(CELL scan); CELL collect_next(CELL scan);
DECLARE_PRIMITIVE(gc); DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time); DECLARE_PRIMITIVE(gc_stats);
DECLARE_PRIMITIVE(gc_reset);
DECLARE_PRIMITIVE(become); DECLARE_PRIMITIVE(become);
CELL find_all_words(void); CELL find_all_words(void);

3
vm/primitives.c
View File

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