Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
a78a3e7b28
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -56,14 +56,25 @@ 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 [
|
||||
! Mark the card
|
||||
"obj" operand "scratch" operand card-bits SRWI
|
||||
"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
|
||||
|
||||
! 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 ;
|
||||
|
||||
\ set-slot {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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> 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 ;
|
||||
|
||||
\ set-slot {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -53,3 +53,5 @@ M: f item-check drop 0 ;
|
|||
|
||||
: binary-trees-main ( -- )
|
||||
16 binary-trees ;
|
||||
|
||||
MAIN: binary-trees-main
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
}
|
||||
|
|
@ -1,26 +1,31 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel opengl arrays sequences jamshred.tunnel
|
||||
jamshred.player math.vectors ;
|
||||
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
|
||||
IN: jamshred.game
|
||||
|
||||
TUPLE: jamshred tunnel players running ;
|
||||
TUPLE: jamshred sounds tunnel players running quit ;
|
||||
|
||||
: <jamshred> ( -- jamshred )
|
||||
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
|
||||
jamshred boa ;
|
||||
<sounds> <random-tunnel> "Player 1" pick <player>
|
||||
2dup swap play-in-tunnel 1array f f jamshred boa ;
|
||||
|
||||
: jamshred-player ( jamshred -- player )
|
||||
! TODO: support more than one player
|
||||
jamshred-players first ;
|
||||
players>> first ;
|
||||
|
||||
: jamshred-update ( jamshred -- )
|
||||
dup jamshred-running [
|
||||
dup running>> [
|
||||
jamshred-player update-player
|
||||
] [ drop ] if ;
|
||||
|
||||
: 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 -- )
|
||||
jamshred-player -rot turn-player ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,38 +1,48 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
|
||||
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
|
||||
math.vectors ;
|
||||
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 ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
|
||||
|
||||
: <jamshred-gadget> ( jamshred -- gadget )
|
||||
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
|
||||
jamshred-gadget construct-gadget swap >>jamshred ;
|
||||
|
||||
: default-width ( -- x ) 1024 ;
|
||||
: default-height ( -- y ) 768 ;
|
||||
: default-width ( -- x ) 800 ;
|
||||
: default-height ( -- y ) 600 ;
|
||||
|
||||
M: jamshred-gadget pref-dim*
|
||||
drop default-width default-height 2array ;
|
||||
|
||||
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 -- )
|
||||
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
|
||||
: jamshred-loop ( gadget -- )
|
||||
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 -- )
|
||||
[
|
||||
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
|
||||
] keep set-jamshred-gadget-alarm ;
|
||||
[ jamshred-loop ] in-thread drop ;
|
||||
|
||||
M: jamshred-gadget ungraft* ( gadget -- )
|
||||
[ jamshred-gadget-alarm cancel-alarm f ] keep
|
||||
set-jamshred-gadget-alarm ;
|
||||
jamshred>> t swap (>>quit) ;
|
||||
|
||||
: jamshred-restart ( jamshred-gadget -- )
|
||||
<jamshred> swap set-jamshred-gadget-jamshred ;
|
||||
<jamshred> >>jamshred drop ;
|
||||
|
||||
: pix>radians ( n m -- theta )
|
||||
2 / / pi 2 * * ;
|
||||
|
|
@ -46,22 +56,31 @@ M: jamshred-gadget ungraft* ( gadget -- )
|
|||
rect-dim second pix>radians ;
|
||||
|
||||
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
|
||||
over jamshred-gadget-jamshred >r
|
||||
over jamshred>> >r
|
||||
[ first swap x>radians ] 2keep second swap y>radians
|
||||
r> mouse-moved ;
|
||||
|
||||
: handle-mouse-motion ( jamshred-gadget -- )
|
||||
hand-loc get [
|
||||
over jamshred-gadget-last-hand-loc [
|
||||
over last-hand-loc>> [
|
||||
v- (handle-mouse-motion)
|
||||
] [ 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{
|
||||
{ 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{ mouse-scroll } [ handle-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: jamshred-window ( -- )
|
||||
|
|
|
|||
|
|
@ -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...
|
||||
|
|
@ -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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! 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
|
||||
|
||||
! 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.
|
||||
|
||||
TUPLE: oint location forward up left ;
|
||||
|
||||
: <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 ;
|
||||
C: <oint> oint
|
||||
|
||||
: rotation-quaternion ( theta axis -- quaternion )
|
||||
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 -- )
|
||||
rotation-quaternion dup qrecip
|
||||
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
|
||||
rotation-quaternion dup qrecip pick
|
||||
[ forward>> rotate-vector >>forward ]
|
||||
[ up>> rotate-vector >>up ]
|
||||
[ left>> rotate-vector >>left ] 3tri drop ;
|
||||
|
||||
: left-pivot ( oint theta -- )
|
||||
over oint-left rotate-oint ;
|
||||
over left>> rotate-oint ;
|
||||
|
||||
: up-pivot ( oint theta -- )
|
||||
over oint-up rotate-oint ;
|
||||
over up>> rotate-oint ;
|
||||
|
||||
: random-float+- ( n -- m )
|
||||
#! 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 ;
|
||||
|
||||
: 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 )
|
||||
oint-location swap oint-location v- ;
|
||||
[ location>> ] bi@ swap v- ;
|
||||
|
||||
: distance ( oint oint -- distance )
|
||||
distance-vector norm ;
|
||||
|
|
@ -71,6 +49,13 @@ TUPLE: oint location forward up left ;
|
|||
#! the scalar projection of v1 onto v2
|
||||
tuck v. swap norm / ;
|
||||
|
||||
: proj-perp ( u v -- w )
|
||||
dupd proj v- ;
|
||||
|
||||
: perpendicular-distance ( oint oint -- distance )
|
||||
tuck distance-vector swap 2dup oint-left scalar-projection abs
|
||||
-rot oint-up scalar-projection abs + ;
|
||||
tuck distance-vector swap 2dup left>> 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- ;
|
||||
|
|
|
|||
|
|
@ -1,38 +1,68 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: colors jamshred.oint jamshred.tunnel kernel
|
||||
math math.constants sequences ;
|
||||
USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
|
||||
IN: jamshred.player
|
||||
|
||||
TUPLE: player name tunnel nearest-segment ;
|
||||
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
||||
|
||||
: <player> ( name -- player )
|
||||
f f player boa
|
||||
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
|
||||
! speeds are in GL units / second
|
||||
: default-speed ( -- speed ) 1.0 ;
|
||||
: 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 -- )
|
||||
>r over r> left-pivot up-pivot ;
|
||||
|
||||
: to-tunnel-start ( player -- )
|
||||
dup player-tunnel first dup oint-location pick set-oint-location
|
||||
swap set-player-nearest-segment ;
|
||||
[ tunnel>> first dup location>> ]
|
||||
[ tuck (>>location) (>>nearest-segment) ] bi ;
|
||||
|
||||
: play-in-tunnel ( player segments -- )
|
||||
over set-player-tunnel to-tunnel-start ;
|
||||
>>tunnel to-tunnel-start ;
|
||||
|
||||
: update-nearest-segment ( player -- )
|
||||
dup player-tunnel over dup player-nearest-segment nearest-segment
|
||||
swap set-player-nearest-segment ;
|
||||
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
|
||||
[ (>>nearest-segment) ] tri ;
|
||||
|
||||
: max-speed ( -- speed )
|
||||
0.3 ;
|
||||
: moved ( player -- ) millis swap (>>last-move) ;
|
||||
|
||||
: player-speed ( player -- speed )
|
||||
dup player-nearest-segment fraction-from-wall sq max-speed * ;
|
||||
: speed-range ( -- range )
|
||||
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 -- )
|
||||
dup player-speed over go-forward update-nearest-segment ;
|
||||
[ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
|
||||
|
||||
: update-player ( player -- )
|
||||
dup move-player player-nearest-segment
|
||||
dup move-player nearest-segment>>
|
||||
white swap set-segment-color ;
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -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 ;
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
|
||||
IN: jamshred.tunnel.tests
|
||||
|
||||
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
|
||||
T{ segment T{ oint f { 1 1 1 } } 1 }
|
||||
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
|
||||
T{ segment f { 1 1 1 } f f f 1 }
|
||||
T{ oint f { 0 0 0.25 } }
|
||||
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
|
||||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,23 +1,20 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays float-arrays kernel jamshred.oint math math.functions
|
||||
math.ranges math.vectors math.constants random sequences vectors ;
|
||||
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 ;
|
||||
IN: jamshred.tunnel
|
||||
|
||||
: n-segments ( -- n ) 5000 ; inline
|
||||
|
||||
TUPLE: segment number color radius ;
|
||||
|
||||
: <segment> ( number color radius location forward up left -- segment )
|
||||
<oint> >r segment boa r> over set-delegate ;
|
||||
TUPLE: segment < oint number color radius ;
|
||||
C: <segment> segment
|
||||
|
||||
: segment-vertex ( theta segment -- vertex )
|
||||
tuck 2dup oint-up swap sin v*n
|
||||
>r oint-left swap cos v*n r> v+
|
||||
swap oint-location v+ ;
|
||||
tuck 2dup up>> swap sin v*n
|
||||
>r left>> swap cos v*n r> v+
|
||||
swap location>> v+ ;
|
||||
|
||||
: segment-vertex-normal ( vertex segment -- normal )
|
||||
oint-location swap v- normalize ;
|
||||
location>> swap v- normalize ;
|
||||
|
||||
: segment-vertex-and-normal ( segment theta -- vertex normal )
|
||||
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
|
||||
|
|
@ -27,7 +24,7 @@ TUPLE: segment number color radius ;
|
|||
dup [ / pi 2 * * ] curry map ;
|
||||
|
||||
: segment-number++ ( segment -- )
|
||||
dup segment-number 1+ swap set-segment-number ;
|
||||
[ number>> 1+ ] keep (>>number) ;
|
||||
|
||||
: random-color ( -- color )
|
||||
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
|
||||
|
|
@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
|
|||
: default-segment-radius ( -- r ) 1 ;
|
||||
|
||||
: 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 } <segment> ;
|
||||
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
|
||||
0 random-color default-segment-radius <segment> ;
|
||||
|
||||
: random-segments ( n -- segments )
|
||||
initial-segment 1vector swap (random-segments) ;
|
||||
|
||||
: simple-segment ( n -- segment )
|
||||
random-color default-segment-radius pick F{ 0 0 -1 } n*v
|
||||
F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
|
||||
[ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
|
||||
random-color default-segment-radius <segment> ;
|
||||
|
||||
: simple-segments ( n -- segments )
|
||||
[ simple-segment ] map ;
|
||||
|
|
@ -100,14 +97,54 @@ TUPLE: segment number color radius ;
|
|||
[ nearest-segment-forward ] 3keep
|
||||
nearest-segment-backward r> nearer-segment ;
|
||||
|
||||
: distance-from-centre ( oint segment -- distance )
|
||||
perpendicular-distance ;
|
||||
: vector-to-centre ( seg loc -- v )
|
||||
over location>> swap v- swap forward>> proj-perp ;
|
||||
|
||||
: distance-from-wall ( oint segment -- distance )
|
||||
tuck distance-from-centre swap segment-radius swap - ;
|
||||
: distance-from-centre ( seg loc -- distance )
|
||||
vector-to-centre norm ;
|
||||
|
||||
: fraction-from-centre ( oint segment -- fraction )
|
||||
tuck distance-from-centre swap segment-radius / ;
|
||||
: wall-normal ( seg oint -- n )
|
||||
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 - ;
|
||||
|
||||
:: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -15,7 +15,12 @@ C: <handle> handle
|
|||
SINGLETON: cocoa-ui-backend
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -80,14 +80,11 @@ FUNCTION: uint ntohl ( uint n ) ;
|
|||
FUNCTION: ushort ntohs ( ushort n ) ;
|
||||
FUNCTION: char* strerror ( int errno ) ;
|
||||
|
||||
TUPLE: open-error path flags prot message ;
|
||||
ERROR: open-error path flags prot message ;
|
||||
|
||||
: open ( path flags prot -- int )
|
||||
[ ] [ unix.ffi:open ] 3bi
|
||||
dup 0 >=
|
||||
[ nip nip nip ]
|
||||
[ drop err_no strerror open-error boa throw ]
|
||||
if ;
|
||||
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 ) ;
|
||||
|
|
@ -171,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 ) ;
|
||||
|
||||
{
|
||||
|
|
|
|||
194
vm/data_gc.c
194
vm/data_gc.c
|
|
@ -21,10 +21,11 @@ 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);
|
||||
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 +63,14 @@ 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->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);
|
||||
|
|
@ -105,6 +110,7 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
|
|||
free(data_heap->generations);
|
||||
free(data_heap->semispaces);
|
||||
free(data_heap->cards);
|
||||
free(data_heap->decks);
|
||||
free(data_heap);
|
||||
}
|
||||
|
||||
|
|
@ -113,20 +119,38 @@ 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 = 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_)
|
||||
{
|
||||
data_heap = data_heap_;
|
||||
nursery = data_heap->generations[NURSERY];
|
||||
init_cards_offset();
|
||||
init_card_decks();
|
||||
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,
|
||||
CELL young_size,
|
||||
CELL aging_size,
|
||||
|
|
@ -141,11 +165,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 +254,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++)
|
||||
{
|
||||
|
|
@ -283,36 +310,61 @@ 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);
|
||||
|
||||
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 +412,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 +508,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 +643,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,7 +654,9 @@ 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);
|
||||
}
|
||||
|
||||
|
|
@ -638,8 +700,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 +723,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 +810,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 +827,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 +847,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)
|
||||
|
|
|
|||
51
vm/data_gc.h
51
vm/data_gc.h
|
|
@ -46,6 +46,9 @@ typedef struct {
|
|||
|
||||
CELL *cards;
|
||||
CELL *cards_end;
|
||||
|
||||
CELL *decks;
|
||||
CELL *decks_end;
|
||||
} F_DATA_HEAP;
|
||||
|
||||
F_DATA_HEAP *data_heap;
|
||||
|
|
@ -71,17 +74,27 @@ 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);
|
||||
|
||||
#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)
|
||||
|
||||
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
|
||||
|
|
@ -89,7 +102,10 @@ 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);
|
||||
*c |= CARD_MARK_MASK;
|
||||
|
||||
F_DECK *d = ADDR_TO_DECK(address);
|
||||
*d = CARD_MARK_MASK ;
|
||||
}
|
||||
|
||||
#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
|
||||
|
|
@ -122,6 +138,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 +160,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 +390,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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in New Issue