vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
+ vm/gc_info.o \
vm/image.o \
vm/inline_cache.o \
vm/instruction_operands.o \
!IF DEFINED(PLATFORM)
LINK_FLAGS = /nologo shell32.lib
-CL_FLAGS = /nologo /O2 /W3 /D_CRT_SECURE_NO_WARNINGS
+CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
vm\free_list.obj \
vm\full_collector.obj \
vm\gc.obj \
+ vm/gc_info.obj \
vm\image.obj \
vm\inline_cache.obj \
vm\instruction_operands.obj \
+++ /dev/null
-USING: help.markup help.syntax calendar quotations system ;\r
-IN: alarms\r
-\r
-HELP: alarm\r
-{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;\r
-\r
-HELP: start-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts an alarm." } ;\r
-\r
-HELP: restart-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;\r
-\r
-HELP: stop-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;\r
-\r
-HELP: every\r
-{ $values\r
- { "quot" quotation } { "interval-duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: later\r
-{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }\r
-{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Break's over!" print flush ] 15 minutes later drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: delayed-every\r
-{ $values\r
- { "quot" quotation } { "duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-ARTICLE: "alarms" "Alarms"\r
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
-"The alarm class:"\r
-{ $subsections alarm }\r
-"Create an alarm before starting it:"\r
-{ $subsections <alarm> }\r
-"Starting an alarm:"\r
-{ $subsections start-alarm restart-alarm }\r
-"Stopping an alarm:"\r
-{ $subsections stop-alarm }\r
-\r
-"A recurring alarm without an initial delay:"\r
-{ $subsections every }\r
-"A one-time alarm with an initial delay:"\r
-{ $subsections later }\r
-"A recurring alarm with an initial delay:"\r
-{ $subsections delayed-every } ;\r
-\r
-ABOUT: "alarms"\r
+++ /dev/null
-USING: alarms alarms.private calendar concurrency.count-downs\r
-concurrency.promises fry kernel math math.order sequences\r
-threads tools.test tools.time ;\r
-IN: alarms.tests\r
-\r
-[ ] [\r
- 1 <count-down>\r
- { f } clone 2dup\r
- [ first stop-alarm count-down ] 2curry 1 seconds later\r
- swap set-first\r
- await\r
-] unit-test\r
-\r
-[ ] [\r
- self [ resume ] curry instant later drop\r
- "test" suspend drop\r
-] unit-test\r
-\r
-[ t ] [\r
- [\r
- <promise>\r
- [ '[ t _ fulfill ] 2 seconds later drop ]\r
- [ 5 seconds ?promise-timeout drop ] bi\r
- ] benchmark 1,500,000,000 2,500,000,000 between?\r
-] unit-test\r
-\r
-[ { 3 } ] [\r
- { 3 } dup\r
- '[ 4 _ set-first ] 2 seconds later\r
- 1/2 seconds sleep\r
- stop-alarm\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
- [ stop-alarm ] [ start-alarm ] bi\r
- 4 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
- 2 seconds sleep stop-alarm\r
- 1/2 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 1 _ set-first ] 300 milliseconds later\r
- 150 milliseconds sleep\r
- [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
- 100 milliseconds sleep restart-alarm 300 milliseconds sleep\r
-] unit-test\r
-\r
-[ { 4 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
- <alarm> dup start-alarm\r
- 700 milliseconds sleep dup restart-alarm\r
- 700 milliseconds sleep stop-alarm 500 milliseconds sleep\r
-] unit-test\r
-! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar combinators.short-circuit fry
-heaps init kernel math math.functions math.parser namespaces
-quotations sequences system threads ;
+USING: ;
IN: alarms
-TUPLE: alarm
- { quot callable initial: [ ] }
- start-nanos
- delay-nanos
- interval-nanos
- iteration-start-nanos
- quotation-running?
- restart?
- thread ;
-
-<PRIVATE
-
-GENERIC: >nanoseconds ( obj -- duration/f )
-M: f >nanoseconds ;
-M: real >nanoseconds >integer ;
-M: duration >nanoseconds duration>nanoseconds >integer ;
-
-: set-next-alarm-time ( alarm -- alarm )
- ! start + delay + ceiling((now - (start + delay)) / interval) * interval
- nano-count
- over start-nanos>> -
- over delay-nanos>> [ - ] when*
- over interval-nanos>> / ceiling
- over interval-nanos>> *
- over start-nanos>> +
- over delay-nanos>> [ + ] when*
- >>iteration-start-nanos ;
-
-: stop-alarm? ( alarm -- ? )
- { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
-
-DEFER: call-alarm-loop
-
-: loop-alarm ( alarm -- )
- nano-count over
- [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
- [ set-next-alarm-time ] dip
- [ dup iteration-start-nanos>> ] [ 0 ] if
- 0 or sleep-until call-alarm-loop ;
-
-: maybe-loop-alarm ( alarm -- )
- dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1||
- [ drop ] [ loop-alarm ] if ;
-
-: call-alarm-loop ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- [
- [ t >>quotation-running? drop ]
- [ quot>> call( -- ) ]
- [ f >>quotation-running? drop ] tri
- ] keep
- maybe-loop-alarm
- ] if ;
-
-: sleep-delay ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- nano-count >>start-nanos
- delay-nanos>> [ sleep ] when*
- ] if ;
-
-: alarm-loop ( alarm -- )
- [ sleep-delay ]
- [ nano-count >>iteration-start-nanos call-alarm-loop ]
- [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ;
-
-PRIVATE>
-
-: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
- alarm new
- swap >nanoseconds >>interval-nanos
- swap >nanoseconds >>delay-nanos
- swap >>quot ; inline
-
-: start-alarm ( alarm -- )
- [
- '[ _ alarm-loop ] "Alarm execution" spawn
- ] keep thread<< ;
-
-: stop-alarm ( alarm -- )
- dup quotation-running?>> [
- f >>thread drop
- ] [
- [ [ interrupt ] when* f ] change-thread drop
- ] if ;
-
-: restart-alarm ( alarm -- )
- t >>restart?
- dup quotation-running?>> [
- drop
- ] [
- dup thread>> [ nip interrupt ] [ start-alarm ] if*
- ] if ;
-
-<PRIVATE
-
-: (start-alarm) ( quot start-duration interval-duration -- alarm )
- <alarm> [ start-alarm ] keep ;
-
-PRIVATE>
-
-: every ( quot interval-duration -- alarm )
- [ f ] dip (start-alarm) ;
-
-: later ( quot delay-duration -- alarm )
- f (start-alarm) ;
-
-: delayed-every ( quot duration -- alarm )
- dup (start-alarm) ;
+++ /dev/null
-One-time and recurring events
--- /dev/null
+USING: alien alien.c-types alien.data alien.syntax
+classes.struct kernel sequences specialized-arrays
+specialized-arrays.private tools.test compiler.units vocabs ;
+IN: alien.data.tests
+
+STRUCT: foo { a int } { b void* } { c bool } ;
+
+SPECIALIZED-ARRAY: foo
+
+[ t ] [ 0 binary-zero? ] unit-test
+[ f ] [ 1 binary-zero? ] unit-test
+[ f ] [ -1 binary-zero? ] unit-test
+[ t ] [ 0.0 binary-zero? ] unit-test
+[ f ] [ 1.0 binary-zero? ] unit-test
+[ f ] [ -0.0 binary-zero? ] unit-test
+[ t ] [ C{ 0.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ 1.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ -0.0 0.0 } binary-zero? ] unit-test
+[ f ] [ C{ 0.0 1.0 } binary-zero? ] unit-test
+[ f ] [ C{ 0.0 -0.0 } binary-zero? ] unit-test
+[ t ] [ f binary-zero? ] unit-test
+[ t ] [ 0 <alien> binary-zero? ] unit-test
+[ f ] [ 1 <alien> binary-zero? ] unit-test
+[ f ] [ B{ } binary-zero? ] unit-test
+[ t ] [ S{ foo f 0 f f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 1 f f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 0 ALIEN: 8 f } binary-zero? ] unit-test
+[ f ] [ S{ foo f 0 f t } binary-zero? ] unit-test
+[ t t f ] [
+ foo-array{
+ S{ foo f 0 f f }
+ S{ foo f 0 f f }
+ S{ foo f 1 f f }
+ } [ first binary-zero? ] [ second binary-zero? ] [ third binary-zero? ] tri
+] unit-test
+
+[ ] [
+ [
+ foo specialized-array-vocab forget-vocab
+ ] with-compilation-unit
+] unit-test
! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words
-macros combinators generalizations ;
+io.files io.streams.memory kernel libc math math.functions
+sequences words macros combinators generalizations ;
+QUALIFIED: math
IN: alien.data
GENERIC: require-c-array ( c-type -- )
: with-out-parameters ( c-types quot finish -- values )
[ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
(cleanup-allot) ; inline
+
+GENERIC: binary-zero? ( value -- ? )
+
+M: object binary-zero? drop f ; inline
+M: f binary-zero? drop t ; inline
+M: integer binary-zero? zero? ; inline
+M: math:float binary-zero? double>bits zero? ; inline
+M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
+
original-error set-global
error set-global ; inline
-
[
! We time bootstrap
nano-count
HOOK: gmt-offset os ( -- hours minutes seconds )
+HOOK: gmt os ( -- timestamp )
+
TUPLE: duration
{ year real }
{ month real }
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
-: gmt ( -- timestamp )
- #! GMT time, right now
- unix-1970 system-micros microseconds time+ ;
-
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
accessors classes.struct ;
IN: calendar.unix
-: timeval>seconds ( timeval -- seconds )
+: timeval>duration ( timeval -- duration )
[ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
- timeval>seconds since-1970 ;
+ timeval>duration since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ;
+
+M: unix gmt
+ timeval <struct> f [ gettimeofday io-error ] 2keep drop
+ timeval>unix-time ;
USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators windows.errors
-accessors classes.struct ;
+accessors classes.struct calendar.format math.functions ;
IN: calendar.windows
+: timestamp>SYSTEMTIME ( timestamp -- SYSTEMTIME )
+ {
+ [ year>> ]
+ [ month>> ]
+ [ day-of-week ]
+ [ day>> ]
+ [ hour>> ]
+ [ minute>> ]
+ [
+ second>> dup floor
+ [ nip >integer ]
+ [ - 1000 * >integer ] 2bi
+ ]
+ } cleave \ SYSTEMTIME <struct-boa> ;
+
+: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp )
+ {
+ [ wYear>> ]
+ [ wMonth>> ]
+ [ wDay>> ]
+ [ wHour>> ]
+ [ wMinute>> ]
+ [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
+ } cleave instant <timestamp> ;
+
M: windows gmt-offset ( -- hours minutes seconds )
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;
+
+M: windows gmt
+ SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
USING: accessors alien alien.c-types alien.data alien.syntax ascii
assocs byte-arrays classes.struct classes.tuple.parser
classes.tuple.private classes.tuple combinators compiler.tree.debugger
-compiler.units destructors io.encodings.utf8 io.pathnames
+compiler.units delegate destructors io.encodings.utf8 io.pathnames
io.streams.string kernel libc literals math mirrors namespaces
prettyprint prettyprint.config see sequences specialized-arrays
system tools.test parser lexer eval layouts generic.single classes
[ 12 ] [ ppc-align-test-2 heap-size ] unit-test
[ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
] when
+
+STRUCT: struct-test-delegate
+ { a int } ;
+STRUCT: struct-test-delegator
+ { del struct-test-delegate }
+ { b int } ;
+CONSULT: struct-test-delegate struct-test-delegator del>> ;
+
+[ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
+ struct-test-delegator <struct>
+ 7 >>a
+ 8 >>b
+] unit-test
+<<<<<<< HEAD
+=======
+
+>>>>>>> alien.data: make binary-zero? public and move it from classes.struct.private
namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays
stack-checker.dependencies system layouts ;
+FROM: delegate.private => group-words slot-group-words ;
QUALIFIED: math
IN: classes.struct
: struct-slots ( struct-class -- slots )
"c-type" word-prop fields>> ;
+M: struct-class group-words
+ struct-slots slot-group-words ;
+
! struct allocation
M: struct >c-ptr
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
+M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
! class definition
<PRIVATE
-GENERIC: binary-zero? ( value -- ? )
-
-M: object binary-zero? drop f ;
-M: f binary-zero? drop t ;
-M: number binary-zero? 0 = ;
-M: struct binary-zero? >c-ptr [ 0 = ] all? ;
-
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
: load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
- utf8 file-lines [ add-vocab-root ] each
+ utf8 file-lines harvest [ add-vocab-root ] each
] [ drop ] if
] when ;
[
{
[ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
+ [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
- [ caller-parameters src ##alien-indirect ]
+ [ caller-parameters src <gc-map> ##alien-indirect ]
[ emit-stack-frame ]
[ box-return* ]
tri
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
- [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
+ [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* <gc-map> ^^box ;
M: long-long-type box
- [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
+ [ first2 ] [ drop ] [ boxer>> ] tri* <gc-map> ^^box-long-long ;
M: struct-c-type box
- '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
+ '[ _ heap-size <gc-map> ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.gc-checks compiler.cfg.representations
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
-compiler.cfg.scheduling ;
+USING: kernel compiler.cfg.gc-checks
+compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.scheduling
+compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
insert-gc-checks
+ dup compute-uninitialized-sets
insert-save-contexts
destruct-ssa
linear-scan
2 \ vreg-counter set-global
-[
- V{
- T{ ##load-tagged f 3 0 }
- T{ ##replace f 3 D 0 }
- T{ ##replace f 3 R 3 }
- }
-] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
-
: gc-check? ( bb -- ? )
instructions>>
{
[
V{
- T{ ##load-tagged f 5 0 }
- T{ ##replace f 5 D 0 }
- T{ ##replace f 5 R 3 }
- T{ ##call-gc f { 0 1 2 } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
]
[
- { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+ <gc-call> instructions>>
] unit-test
30 \ vreg-counter set-global
[ ] [ cfg get needs-predecessors drop ] unit-test
-[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
[
V{
- T{ ##load-tagged f 31 0 }
- T{ ##replace f 31 D 0 }
- T{ ##replace f 31 D 1 }
- T{ ##replace f 31 D 2 }
- T{ ##call-gc f { 2 } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
] [ 2 get predecessors>> second instructions>> ] unit-test
compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.liveness
-compiler.cfg.liveness.ssa
-compiler.cfg.stacks.uninitialized ;
+compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
<PRIVATE
] bi*
] V{ } make >>instructions ;
-: wipe-locs ( uninitialized-locs -- )
- '[
- int-rep next-vreg-rep
- [ 0 ##load-tagged ]
- [ '[ [ _ ] dip ##replace ] each ] bi
- ] unless-empty ;
-
-: <gc-call> ( uninitialized-locs gc-roots -- bb )
- [ <basic-block> ] 2dip
- [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+: <gc-call> ( -- bb )
+ <basic-block>
+ [ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: insert-guard ( body check bb -- )
check predecessors>> [ bb check update-successors ] each ;
-: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+: (insert-gc-check) ( phis size bb -- )
[ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
GENERIC: allocation-size* ( insn -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
-: gc-live-in ( bb -- vregs )
- [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
- append ;
-
-: live-tagged ( bb -- vregs )
- gc-live-in [ rep-of tagged-rep? ] filter ;
-
: remove-phis ( bb -- phis )
[ [ ##phi? ] partition ] change-instructions drop ;
: insert-gc-check ( bb -- )
- {
- [ uninitialized-locs ]
- [ live-tagged ]
- [ remove-phis ]
- [ allocation-size ]
- [ ]
- } cleave
- (insert-gc-check) ;
+ [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- [
- needs-predecessors
- dup compute-ssa-live-sets
- dup compute-uninitialized-sets
- ] dip
+ [ needs-predecessors ] dip
[ insert-gc-check ] each
cfg-changed
] unless-empty ;
INSN: ##box
def: dst/tagged-rep
use: src
-literal: boxer rep ;
+literal: boxer rep gc-map ;
INSN: ##box-long-long
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
-literal: boxer ;
+literal: boxer gc-map ;
INSN: ##allot-byte-array
def: dst/tagged-rep
-literal: size ;
+literal: size gc-map ;
INSN: ##prepare-var-args ;
INSN: ##alien-invoke
-literal: symbols dll ;
+literal: symbols dll gc-map ;
INSN: ##cleanup
literal: n ;
INSN: ##alien-indirect
-use: src/int-rep ;
+use: src/int-rep
+literal: gc-map ;
INSN: ##alien-assembly
literal: quot ;
literal: size cc
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##call-gc
-literal: gc-roots ;
+INSN: ##call-gc literal: gc-map ;
! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
+! Instructions that contain subroutine calls to functions which
+! allocate memory
+UNION: gc-map-insn
+##call-gc
+##alien-invoke
+##alien-indirect
+##box
+##box-long-long
+##allot-byte-array ;
+
+M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
+
+! Each one has a gc-map slot
+TUPLE: gc-map scrub-d scrub-r gc-roots ;
+
+: <gc-map> ( -- gc-map ) gc-map new ;
+
! Instructions that clobber registers. They receive inputs and
! produce outputs in spill slots.
UNION: hairy-clobber-insn
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-M: ##call-gc assign-registers-in-insn
- dup call-next-method
- [ [ vreg>reg ] map ] change-gc-roots drop ;
+M: gc-map-insn assign-registers-in-insn
+ [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
+ [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ]
+ bi ;
M: insn assign-registers-in-insn drop ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.registers
+cpu.architecture ;
IN: compiler.cfg.liveness
! See http://en.wikipedia.org/wiki/Liveness_analysis
-! Do not run after SSA construction
+! Do not run after SSA construction; compiler.cfg.liveness.ssa
+! should be used instead. The transfer-liveness word is used
+! by SSA liveness too, so it handles ##phi instructions.
BACKWARD-ANALYSIS: live
-GENERIC: insn-liveness ( live-set insn -- )
+GENERIC: visit-insn ( live-set insn -- live-set )
: kill-defs ( live-set insn -- live-set )
- defs-vreg [ over delete-at ] when* ;
+ defs-vreg [ over delete-at ] when* ; inline
: gen-uses ( live-set insn -- live-set )
- dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
+ uses-vregs [ over conjoin ] each ; inline
+
+M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+
+: fill-gc-map ( live-set insn -- live-set )
+ gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+
+M: gc-map-insn visit-insn
+ [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
+
+M: ##phi visit-insn kill-defs ;
+
+M: insn visit-insn drop ;
: transfer-liveness ( live-set instructions -- live-set' )
- [ clone ] [ <reversed> ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ;
+ [ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
: local-live-in ( instructions -- live-set )
[ H{ } ] dip transfer-liveness keys ;
: needs-save-context? ( insns -- ? )
[
{
- [ ##call-gc? ]
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
V{
T{ ##save-context f 77 78 }
- T{ ##call-gc f { } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
} 2 test-bb
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
-[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test
+[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test
! When merging, if a location is uninitialized in one branch and
! initialized in another, we have to consider it uninitialized,
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
+[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test
! Consider the following sequence of instructions:
! ##inc-d 2
-! ##gc
+! ...
+! ##allot
! ##replace ... D 0
! ##replace ... D 1
-! The GC check runs before stack locations 0 and 1 have been initialized,
-! and it needs to zero them out so that GC doesn't try to trace them.
+! The GC check runs before stack locations 0 and 1 have been
+! initialized, and so the GC needs to scrub them so that they
+! don't get traced. This is achieved by computing uninitialized
+! locations with a dataflow analysis, and recording the
+! information in GC maps. The scrub_contexts() method on
+! vm/gc.cpp reads this information from GC maps and performs
+! the scrubbing.
<PRIVATE
] change ;
M: ##inc-d visit-insn n>> ds-loc handle-inc ;
-
M: ##inc-r visit-insn n>> rs-loc handle-inc ;
ERROR: uninitialized-peek insn ;
M: ##replace visit-insn visit-replace ;
M: ##replace-imm visit-insn visit-replace ;
+M: gc-map-insn visit-insn
+ gc-map>>
+ ds-loc get clone >>scrub-d
+ rs-loc get clone >>scrub-r
+ drop ;
+
M: insn visit-insn drop ;
: prepare ( pair -- )
: (join-sets) ( seq1 seq2 -- seq )
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
-: (uninitialized-locs) ( seq quot -- seq' )
- [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline
-
PRIVATE>
FORWARD-ANALYSIS: uninitialized
M: uninitialized-analysis join-sets ( sets analysis -- pair )
2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
-
-: uninitialized-locs ( bb -- locs )
- uninitialized-in dup [
- first2
- [ [ <ds-loc> ] (uninitialized-locs) ]
- [ [ <rs-loc> ] (uninitialized-locs) ]
- bi* append
- ] when ;
--- /dev/null
+USING: namespaces byte-arrays make compiler.codegen.fixup
+bit-arrays accessors classes.struct tools.test kernel math
+sequences alien.c-types specialized-arrays boxes
+compiler.cfg.instructions system cpu.architecture ;
+SPECIALIZED-ARRAY: uint
+IN: compiler.codegen.fixup.tests
+
+STRUCT: gc-info
+{ scrub-d-count uint }
+{ scrub-r-count uint }
+{ gc-root-count uint }
+{ return-address-count uint } ;
+
+SINGLETON: fake-cpu
+
+fake-cpu \ cpu set
+
+M: fake-cpu gc-root-offsets ;
+
+[ ] [
+ [
+ init-fixup
+
+ 50 <byte-array> %
+
+ T{ gc-map f B{ } B{ } V{ } } gc-map-here
+
+ 50 <byte-array> %
+
+ T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
+
+ emit-gc-info
+ ] B{ } make
+ "result" set
+] unit-test
+
+[ 0 ] [ "result" get length 16 mod ] unit-test
+
+[ ] [
+ [
+ 100 <byte-array> %
+
+ ! The below data is 22 bytes -- 6 bytes padding needed to
+ ! align
+ 6 <byte-array> %
+
+ ! Bitmap - 2 bytes
+ ?{
+ ! scrub-d
+ t f f f t
+ ! scrub-r
+ f t
+ ! gc-roots
+ f t f t
+ } underlying>> %
+
+ ! Return addresses - 4 bytes
+ uint-array{ 100 } underlying>> %
+
+ ! GC info footer - 16 bytes
+ S{ gc-info
+ { scrub-d-count 5 }
+ { scrub-r-count 2 }
+ { gc-root-count 4 }
+ { return-address-count 1 }
+ } (underlying)>> %
+ ] B{ } make
+ "expect" set
+] unit-test
+
+[ ] [ "result" get length "expect" get length assert= ] unit-test
+[ ] [ "result" get "expect" get assert= ] unit-test
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors generic assocs hashtables
-io.binary kernel kernel.private math namespaces make sequences
-words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise math.order combinators.smart
-accessors growable fry compiler.constants memoize ;
+USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
+hashtables io.binary kernel kernel.private math namespaces make
+sequences words quotations strings alien.accessors alien.strings
+layouts system combinators math.bitwise math.order
+combinators.short-circuit combinators.smart accessors growable
+fry memoize compiler.constants compiler.cfg.instructions
+cpu.architecture ;
IN: compiler.codegen.fixup
! Utilities
: rel-decks-offset ( class -- )
rt-decks-offset rel-fixup ;
-! And the rest
+! Labels
: compute-target ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
[ [ compute-relative-label ] map concat ]
bi* ;
-: init-fixup ( -- )
- V{ } clone parameter-table set
- V{ } clone literal-table set
- V{ } clone label-table set
- BV{ } clone relocation-table set
- V{ } clone binary-literal-table set ;
-
+! Binary literals
: alignment ( align -- n )
[ compiled-offset dup ] dip align swap - ;
: emit-binary-literals ( -- )
binary-literal-table get [ emit-data ] assoc-each ;
+! GC info
+
+! Every code block either ends with
+!
+! uint 0
+!
+! or
+!
+! bitmap, byte aligned, three subsequences:
+! - <scrubbed data stack locations>
+! - <scrubbed retain stack locations>
+! - <GC root spill slots>
+! uint[] <return addresses>
+! uint <largest scrubbed data stack location>
+! uint <largest scrubbed retain stack location>
+! uint <largest GC root spill slot>
+! uint <number of return addresses>
+
+SYMBOLS: return-addresses gc-maps ;
+
+: gc-map-needed? ( gc-map -- ? )
+ ! If there are no stack locations to scrub and no GC roots,
+ ! there's no point storing the GC map.
+ dup [
+ {
+ [ scrub-d>> empty? ]
+ [ scrub-r>> empty? ]
+ [ gc-roots>> empty? ]
+ } 1&& not
+ ] when ;
+
+: gc-map-here ( gc-map -- )
+ dup gc-map-needed? [
+ gc-maps get push
+ compiled-offset return-addresses get push
+ ] [ drop ] if ;
+
+: emit-scrub ( seqs -- n )
+ ! seqs is a sequence of sequences of 0/1
+ dup [ length ] [ max ] map-reduce
+ [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
+
+: integers>bits ( seq n -- bit-array )
+ <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
+
+: emit-gc-roots ( seqs -- n )
+ ! seqs is a sequence of sequences of integers 0..n-1
+ dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
+ [ '[ _ integers>bits % ] each ] keep ;
+
+: emit-uint ( n -- )
+ building get push-uint ;
+
+: gc-info ( -- byte-array )
+ [
+ return-addresses get empty? [ 0 emit-uint ] [
+ gc-maps get
+ [
+ [ [ scrub-d>> ] map emit-scrub ]
+ [ [ scrub-r>> ] map emit-scrub ]
+ [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri
+ ] ?{ } make underlying>> %
+ return-addresses get [ emit-uint ] each
+ [ emit-uint ] tri@
+ return-addresses get length emit-uint
+ ] if
+ ] B{ } make ;
+
+: emit-gc-info ( -- )
+ ! We want to place the GC info so that the end is aligned
+ ! on a 16-byte boundary.
+ gc-info [
+ length compiled-offset +
+ [ data-alignment get align ] keep -
+ (align-code)
+ ] [ % ] bi ;
+
+: init-fixup ( -- )
+ V{ } clone parameter-table set
+ V{ } clone literal-table set
+ V{ } clone label-table set
+ BV{ } clone relocation-table set
+ V{ } clone binary-literal-table set
+ V{ } clone return-addresses set
+ V{ } clone gc-maps set ;
+
+: check-fixup ( seq -- )
+ length data-alignment get mod 0 assert= ;
+
: with-fixup ( quot -- code )
'[
+ init-fixup
[
- init-fixup
@
emit-binary-literals
+ emit-gc-info
label-table [ compute-labels ] change
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
label-table get
] B{ } make
+ dup check-fixup
] output>array ; inline
! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques threads kernel arrays sequences alarms fry ;\r
+USING: deques threads kernel arrays sequences timers fry ;\r
IN: concurrency.conditions\r
\r
: notify-1 ( deque -- )\r
: notify-all ( deque -- )\r
[ resume-now ] slurp-deque ; inline\r
\r
-: queue-timeout ( queue timeout -- alarm )\r
- #! Add an alarm which removes the current thread from the\r
+: queue-timeout ( queue timeout -- timer )\r
+ #! Add an timer which removes the current thread from the\r
#! queue, and resumes it, passing it a value of t.\r
[\r
[ self swap push-front* ] keep '[\r
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout ] dip suspend\r
- [ wait-timeout ] [ stop-alarm ] if\r
+ [ wait-timeout ] [ stop-timer ] if\r
] [\r
[ drop queue ] dip suspend drop\r
] if ; inline\r
! %store-memory work
HOOK: complex-addressing? cpu ( -- ? )
+HOOK: gc-root-offsets cpu ( seq -- seq' )
+
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-float cpu ( reg val -- )
! GC checks
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %call-gc cpu ( gc-roots -- )
+HOOK: %call-gc cpu ( gc-map -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack
-HOOK: %box cpu ( dst src func rep -- )
+HOOK: %box cpu ( dst src func rep gc-map -- )
-HOOK: %box-long-long cpu ( dst src1 src2 func -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
-HOOK: %allot-byte-array cpu ( dst size -- )
+HOOK: %allot-byte-array cpu ( dst size gc-map -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
M: object %prepare-var-args ;
-HOOK: %alien-invoke cpu ( function library -- )
+HOOK: %alien-invoke cpu ( function library gc-map -- )
HOOK: %cleanup cpu ( n -- )
M: object %cleanup ( n -- ) drop ;
-HOOK: %alien-indirect cpu ( src -- )
+HOOK: %alien-indirect cpu ( src gc-map -- )
HOOK: %load-reg-param cpu ( dst reg rep -- )
rc-absolute-cell rel-decks-offset
building get push ;
-M:: x86.32 %dispatch ( src temp -- )
- ! Load jump table base.
- temp src HEX: ffffffff [+] LEA
- building get length :> start
- 0 rc-absolute-cell rel-here
- ! Go
- temp HEX: 7f [+] JMP
- building get length :> end
- ! Fix up the displacement above
- cell alignment
- [ end start - + building get dup pop* push ]
- [ (align-code) ]
- bi ;
-
M: x86.32 pic-tail-reg EDX ;
M: x86.32 reserved-stack-space 0 ;
EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
- func f %alien-invoke ;
+ func f f %alien-invoke ;
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
EAX out int-rep %copy
4 stack@ EAX MOV
8 save-vm-ptr
- func f %alien-invoke ;
+ func f f %alien-invoke ;
-M:: x86.32 %box ( dst src func rep -- )
+M:: x86.32 %box ( dst src func rep gc-map -- )
rep rep-size save-vm-ptr
src rep %store-return
0 stack@ rep %load-return
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %box-long-long ( dst src1 src2 func -- )
+M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
8 save-vm-ptr
EAX src1 int-rep %copy
0 stack@ EAX int-rep %copy
EAX src2 int-rep %copy
4 stack@ EAX int-rep %copy
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %allot-byte-array ( dst size -- )
+M:: x86.32 %allot-byte-array ( dst size gc-map -- )
4 save-vm-ptr
0 stack@ size MOV
- "allot_byte_array" f %alien-invoke
+ "allot_byte_array" f gc-map %alien-invoke
dst EAX tagged-rep %copy ;
-M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
+M: x86.32 %alien-invoke
+ [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
4 stack@ 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
[ EAX ] dip %load-reference
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
- "end_callback" f %alien-invoke ;
+ "end_callback" f f %alien-invoke ;
GENERIC: float-function-param ( n dst src -- )
M:: x86.32 %unary-float-function ( dst src func -- )
0 dst src float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
0 dst src1 float-function-param
8 dst src2 float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
: funny-large-struct-return? ( return abi -- ? )
M: x86.32 %cleanup ( n -- )
[ ESP swap SUB ] unless-zero ;
-M:: x86.32 %call-gc ( gc-roots -- )
- 4 save-vm-ptr
- 0 stack@ gc-roots gc-root-offsets %load-reference
- "inline_gc" f %alien-invoke ;
-
M: x86.32 dummy-stack-params? f ;
M: x86.32 dummy-int-params? f ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ ESP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
! Unwind stack frames
ESP EDX MOV
+ 0 jit-scrub-return
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
+ -4 jit-scrub-return
+
! Save ds, rs registers
jit-load-vm
jit-save-context
dup load-decks-offset
[+] card-mark <byte> MOV ;
-M:: x86.64 %dispatch ( src temp -- )
- ! Load jump table base.
- temp HEX: ffffffff MOV
- building get length :> start
- 0 rc-absolute-cell rel-here
- ! Add jump table base
- temp src ADD
- temp HEX: 7f [+] JMP
- building get length :> end
- ! Fix up the displacement above
- cell alignment
- [ end start - + building get dup pop* push ]
- [ (align-code) ]
- bi ;
-
M:: x86.64 %load-reg-param ( dst reg rep -- )
dst reg rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
- func f %alien-invoke
+ func f f %alien-invoke
dst rep %load-return ;
-M:: x86.64 %box ( dst src func rep -- )
+M:: x86.64 %box ( dst src func rep gc-map -- )
0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f %alien-invoke
+ func f gc-map %alien-invoke
dst int-rep %load-return ;
-M:: x86.64 %allot-byte-array ( dst size -- )
+M:: x86.64 %allot-byte-array ( dst size gc-map -- )
param-reg-0 size MOV
param-reg-1 %mov-vm-ptr
- "allot_byte_array" f %alien-invoke
+ "allot_byte_array" f gc-map %alien-invoke
dst int-rep %load-return ;
M: x86.64 %alien-invoke
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 CALL ;
+ [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
+ gc-map-here ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
[ param-reg-0 ] dip %load-reference
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
- "end_callback" f %alien-invoke ;
+ "end_callback" f f %alien-invoke ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %alien-invoke
dst double-rep %load-return ;
-M:: x86.64 %call-gc ( gc-roots -- )
- param-reg-0 gc-roots gc-root-offsets %load-reference
- param-reg-1 %mov-vm-ptr
- "inline_gc" f %alien-invoke ;
-
M: x86.64 long-long-on-stack? f ;
M: x86.64 float-on-stack? f ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ RSP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
! Unwind stack frames
RSP arg2 MOV
+ 0 jit-scrub-return
! Load VM pointer into vm-reg, since we're entering from
! C code
! Contexts
: jit-switch-context ( reg -- )
+ -8 jit-scrub-return
+
! Save ds, rs registers
jit-save-context
: spill@ ( n -- op ) spill-offset special-offset stack@ ;
-: gc-root-offsets ( seq -- seq' )
- [ n>> spill-offset special-offset cell + ] map f like ;
-
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
{ cc/<= [ label JG ] }
} case ;
+M: x86 gc-root-offsets
+ [ n>> spill-offset special-offset cell + cell /i ] map f like ;
+
+M: x86 %call-gc ( gc-map -- )
+ \ minor-gc %call
+ gc-map-here ;
+
M: x86 %alien-global ( dst symbol library -- )
- [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
src1 src2 (%compare-imm)
label cc %branch ;
+M:: x86 %dispatch ( src temp -- )
+ ! Load jump table base.
+ temp HEX: ffffffff MOV
+ building get length :> start
+ 0 rc-absolute-cell rel-here
+ ! Add jump table base
+ temp src HEX: 7f [++] JMP
+ building get length :> end
+ ! Fix up the displacement above
+ cell alignment
+ [ end start - + building get dup pop* push ]
+ [ (align-code) ]
+ bi ;
+
M:: x86 %spill ( src rep dst -- )
dst src rep %copy ;
M:: x86 %local-allot ( dst size align offset -- )
dst offset local-allot-offset special-offset stack@ LEA ;
-M: x86 %alien-indirect ( src -- )
- ?spill-slot CALL ;
+M: x86 %alien-indirect ( src gc-map -- )
+ [ ?spill-slot CALL ] [ gc-map-here ] bi* ;
M: x86 %loop-entry 16 alignment [ NOP ] times ;
M: standard-generic group-words
dup "combination" word-prop #>> 2array 1array ;
-M: tuple-class group-words
- all-slots [
+: slot-group-words ( slots -- words )
+ [
name>>
[ reader-word 0 2array ]
[ writer-word 0 2array ] bi
2array
] map concat ;
+M: tuple-class group-words
+ all-slots slot-group-words ;
+
: check-broadcast-group ( group -- group )
dup group-words [ first stack-effect out>> empty? ] all?
[ broadcast-words-must-have-no-outputs ] unless ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences db.tuples alarms calendar db fry
+USING: kernel sequences db.tuples timers calendar db fry
furnace.db
furnace.cache
furnace.asides
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
-destructors alarms io.sockets db db.tuples db.types
+destructors io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
--- /dev/null
+Joe Groff\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs hashtables.identity kernel literals tools.test ;\r
+IN: hashtables.identity.tests\r
+\r
+CONSTANT: the-real-slim-shady "marshall mathers"\r
+\r
+CONSTANT: will\r
+ IH{\r
+ { $ the-real-slim-shady t }\r
+ { "marshall mathers" f }\r
+ }\r
+\r
+: please-stand-up ( assoc key -- value )\r
+ swap at ;\r
+\r
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
+\r
+[ 2 ] [ will assoc-size ] unit-test\r
+[ { { "marshall mathers" f } } ] [\r
+ the-real-slim-shady will clone\r
+ [ delete-at ] [ >alist ] bi\r
+] unit-test\r
+[ t ] [\r
+ t the-real-slim-shady identity-associate\r
+ t the-real-slim-shady identity-associate =\r
+] unit-test\r
+[ f ] [\r
+ t the-real-slim-shady identity-associate\r
+ t "marshall mathers" identity-associate =\r
+] unit-test\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: accessors arrays assocs fry hashtables kernel parser\r
+sequences vocabs.loader ;\r
+IN: hashtables.identity\r
+\r
+TUPLE: identity-wrapper\r
+ { underlying read-only } ;\r
+C: <identity-wrapper> identity-wrapper\r
+\r
+M: identity-wrapper equal?\r
+ over identity-wrapper?\r
+ [ [ underlying>> ] bi@ eq? ]\r
+ [ 2drop f ] if ; inline\r
+\r
+M: identity-wrapper hashcode*\r
+ nip underlying>> identity-hashcode ; inline\r
+\r
+TUPLE: identity-hashtable\r
+ { underlying hashtable read-only } ;\r
+\r
+: <identity-hashtable> ( n -- ihash )\r
+ <hashtable> identity-hashtable boa ; inline\r
+\r
+<PRIVATE\r
+: identity@ ( key ihash -- ikey hash )\r
+ [ <identity-wrapper> ] [ underlying>> ] bi* ; inline\r
+PRIVATE>\r
+\r
+M: identity-hashtable at*\r
+ identity@ at* ; inline\r
+\r
+M: identity-hashtable clear-assoc\r
+ underlying>> clear-assoc ; inline\r
+\r
+M: identity-hashtable delete-at\r
+ identity@ delete-at ; inline\r
+\r
+M: identity-hashtable assoc-size\r
+ underlying>> assoc-size ; inline\r
+\r
+M: identity-hashtable set-at\r
+ identity@ set-at ; inline\r
+\r
+: identity-associate ( value key -- hash )\r
+ 2 <identity-hashtable> [ set-at ] keep ; inline\r
+\r
+M: identity-hashtable >alist\r
+ underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;\r
+ \r
+M: identity-hashtable clone\r
+ underlying>> clone identity-hashtable boa ; inline\r
+\r
+M: identity-hashtable equal?\r
+ over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;\r
+\r
+: >identity-hashtable ( assoc -- ihashtable )\r
+ dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;\r
+\r
+SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
+\r
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r
--- /dev/null
+USING: hashtables.identity mirrors ;\r
+IN: hashtables.identity.mirrors\r
+\r
+M: identity-hashtable make-mirror ;\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs continuations hashtables.identity kernel\r
+namespaces prettyprint.backend prettyprint.config\r
+prettyprint.custom ;\r
+IN: hashtables.identity.prettyprint\r
+\r
+M: identity-hashtable >pprint-sequence >alist ;\r
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
+\r
+M: identity-hashtable pprint*\r
+ nesting-limit inc\r
+ [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;\r
--- /dev/null
+Hashtables keyed by object identity (eq?) rather than by logical value (=)\r
: validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ;
-: pad-bitmap ( image -- image )
- dup dim>> second 4 divisor? [
- dup [ bytes-per-pixel ]
- [ dim>> first * ]
- [ dim>> first 4 mod ] tri
- '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
- ] unless ;
-
: loading-png>bitmap ( loading-png -- bytes component-order )
dup color-type>> {
{ greyscale [
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
- } cleave pad-bitmap ;
+ } cleave ;
: load-png ( stream -- loading-png )
[
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators continuations fry io io.backend
io.directories io.directories.hierarchy io.files io.pathnames
-kernel math math.bitwise math.parser namespaces random
+kernel locals math math.bitwise math.parser namespaces random
sequences system vocabs.loader ;
IN: io.files.unique
: temporary-file ( -- path ) "" unique-file ;
-: with-working-directory ( path quot -- )
- over make-directories
- dupd '[ _ _ with-temporary-directory ] with-directory ; inline
+:: cleanup-unique-working-directory ( quot -- )
+ unique-directory :> path
+ path [ path quot with-temporary-directory ] with-directory
+ path delete-tree ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
'[ _ call( -- result ) ] with-streams*
] with-destructors ;
-: <pipes> ( n -- pipes )
+GENERIC: <pipes> ( obj -- pipes )
+
+M: integer <pipes> ( n -- pipes )
[
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;
+M: sequence <pipes>
+ [ { } ] [ length 1 - <pipes> ] if-empty ;
+
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1 - <pipes> ] if ] keep
+ [ <pipes> ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
<client>
with-client
}
+"The local address of a client socket can be controlled with this word:"
+{ $subsections
+ with-local-address
+}
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsections
<server>
HELP: resolve-host
{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
{ $description "Resolves host names to IP addresses." } ;
+
+HELP: with-local-address
+{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } }
+{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." }
+{ $examples
+ { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1."
+ "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." }
+ { $code "\"127.0.0.1\" 0 <inet4> [ ] with-local-address" }
+ $nl
+ { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. "
+ "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown."
+ }
+ { $code "\"192.168.0.1\" 23000 <inet4> [ ] with-local-address" }
+} ;
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar alarms io io.encodings accessors\r
+USING: kernel calendar timers io io.encodings accessors\r
namespaces fry io.streams.null ;\r
IN: io.timeouts\r
\r
\r
GENERIC: cancel-operation ( obj -- )\r
\r
-: queue-timeout ( obj timeout -- alarm )\r
+: queue-timeout ( obj timeout -- timer )\r
[ '[ _ cancel-operation ] ] dip later ;\r
\r
: with-timeout* ( obj timeout quot -- )\r
- 3dup drop queue-timeout [ nip call ] dip stop-alarm ;\r
+ 3dup drop queue-timeout [ nip call ] dip stop-timer ;\r
inline\r
\r
: with-timeout ( obj quot -- )\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
-io.files io.streams.string namespaces make alarms assocs\r
+io.files io.streams.string namespaces make timers assocs\r
io.encodings.utf8 accessors calendar sequences ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
+{ { 2 } } [ 2 primes-upto >array ] unit-test
+{ { } } [ 1 primes-upto >array ] unit-test
{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test
{ { 4999963 4999999 5000011 5000077 5000081 } }
{ { 8999981 8999993 9000011 9000041 } }
[ 8999980 9000045 primes-between >array ] unit-test
+{ { } } [ 5 4 primes-between >array ] unit-test
+
+{ { 2 } } [ 2 2 primes-between >array ] unit-test
+
+{ { 2 } } [ 1.5 2.5 primes-between >array ] unit-test
+
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable
-: primes-between ( low high -- seq )
+<PRIVATE
+
+: (primes-between) ( low high -- seq )
[ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
[ <primes-vector> ] 2bi
[ '[ [ prime? ] _ push-if ] each ] keep clone ;
+PRIVATE>
+
+: primes-between ( low high -- seq )
+ [ ceiling >integer ] [ floor >integer ] bi*
+ {
+ { [ 2dup > ] [ 2drop V{ } clone ] }
+ { [ dup 2 = ] [ 2drop V{ 2 } clone ] }
+ { [ dup 2 < ] [ 2drop V{ } clone ] }
+ [ (primes-between) ]
+ } cond ;
+
: primes-upto ( n -- seq ) 2 swap primes-between ;
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
[ t ] [ qi qi q- q0 = ] unit-test
[ t ] [ qi qj q+ qj qi q+ = ] unit-test
[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test
+
+[ { 2 2 2 2 } ] [ { 1 1 1 1 } 2 q*n ] unit-test
+[ { 2 2 2 2 } ] [ 2 { 1 1 1 1 } n*q ] unit-test
: q/ ( u v -- u/v )
qrecip q* ; inline
-: n*q ( q n -- r )
- v*n ; inline
+: n*q ( n q -- r )
+ n*v ; inline
: q*n ( q n -- r )
v*n ; inline
--- /dev/null
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;\r
+IN: math.vectors.simd.cords.tests\r
+\r
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test\r
WHERE
: >A ( seq -- A )
- [ N head >A/2 ]
- [ N tail >A/2 ] bi cord-append ;
+ [ N head-slice >A/2 ]
+ [ N tail-slice >A/2 ] bi cord-append ;
\ A-boa
{ N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
USING: math.vectors.simd mirrors ;
IN: math.vectors.simd.mirrors
-INSTANCE: simd-128 enumerated-sequence
+INSTANCE: simd-128 inspected-sequence
INSTANCE: mirror assoc
-MIXIN: enumerated-sequence
-INSTANCE: array enumerated-sequence
-INSTANCE: vector enumerated-sequence
-INSTANCE: callable enumerated-sequence
-INSTANCE: byte-array enumerated-sequence
+MIXIN: inspected-sequence
+INSTANCE: array inspected-sequence
+INSTANCE: vector inspected-sequence
+INSTANCE: callable inspected-sequence
+INSTANCE: byte-array inspected-sequence
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
-M: enumerated-sequence make-mirror <enum> ;
+M: inspected-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alarms fry kernel models ;\r
+USING: accessors timers fry kernel models ;\r
IN: models.delay\r
\r
-TUPLE: delay < model model timeout alarm ;\r
+TUPLE: delay < model model timeout timer ;\r
\r
: update-delay-model ( delay -- )\r
[ model>> value>> ] keep set-model ;\r
[ add-dependency ] keep ;\r
\r
: stop-delay ( delay -- )\r
- alarm>> [ stop-alarm ] when* ;\r
+ timer>> [ stop-timer ] when* ;\r
\r
: start-delay ( delay -- )\r
dup\r
- [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi\r
+ [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi\r
later\r
- >>alarm drop ;\r
+ >>timer drop ;\r
\r
M: delay model-changed nip dup stop-delay start-delay ;\r
\r
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
-M: hashtable pprint* pprint-object ;
+M: hashtable pprint*
+ nesting-limit inc
+ [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
-math.order arrays classes combinators kernel functors math.functions
-math.vectors ;
+math.order arrays classes combinators kernel functors locals
+math.functions math.vectors ;
IN: sequences.cords
MIXIN: cord
[ [ head>> ] dip call ]
[ [ tail>> ] dip call ] 2bi cord-append ; inline
-: cord-2map ( cord cord quot -- cord' )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi cord-append ; inline
+:: cord-2map ( cord-a cord-b quot fallback -- cord' )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi cord-append
+ ] [ fallback call ] if ; inline
: cord-both ( cord quot -- h t )
[ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
-: cord-2both ( cord cord quot -- h t )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline
+:: cord-2both ( cord-a cord-b quot combine fallback -- result )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi combine call
+ ] [ fallback call ] if ; inline
<PRIVATE
: split-shuffle ( shuf -- sh uf )
dup length 2 /i cut* ; foldable
PRIVATE>
-M: cord v+ [ v+ ] cord-2map ; inline
-M: cord v- [ v- ] cord-2map ; inline
+M: cord v+ [ v+ ] [ call-next-method ] cord-2map ; inline
+M: cord v- [ v- ] [ call-next-method ] cord-2map ; inline
M: cord vneg [ vneg ] cord-map ; inline
-M: cord v+- [ v+- ] cord-2map ; inline
-M: cord vs+ [ vs+ ] cord-2map ; inline
-M: cord vs- [ vs- ] cord-2map ; inline
-M: cord vs* [ vs* ] cord-2map ; inline
-M: cord v* [ v* ] cord-2map ; inline
-M: cord v/ [ v/ ] cord-2map ; inline
-M: cord vmin [ vmin ] cord-2map ; inline
-M: cord vmax [ vmax ] cord-2map ; inline
-M: cord v. [ v. ] cord-2both + ; inline
+M: cord v+- [ v+- ] [ call-next-method ] cord-2map ; inline
+M: cord vs+ [ vs+ ] [ call-next-method ] cord-2map ; inline
+M: cord vs- [ vs- ] [ call-next-method ] cord-2map ; inline
+M: cord vs* [ vs* ] [ call-next-method ] cord-2map ; inline
+M: cord v* [ v* ] [ call-next-method ] cord-2map ; inline
+M: cord v/ [ v/ ] [ call-next-method ] cord-2map ; inline
+M: cord vmin [ vmin ] [ call-next-method ] cord-2map ; inline
+M: cord vmax [ vmax ] [ call-next-method ] cord-2map ; inline
+M: cord v.
+ [ v. ] [ + ] [ call-next-method ] cord-2both ; inline
M: cord vsqrt [ vsqrt ] cord-map ; inline
M: cord sum [ sum ] cord-both + ; inline
M: cord vabs [ vabs ] cord-map ; inline
-M: cord vbitand [ vbitand ] cord-2map ; inline
-M: cord vbitandn [ vbitandn ] cord-2map ; inline
-M: cord vbitor [ vbitor ] cord-2map ; inline
-M: cord vbitxor [ vbitxor ] cord-2map ; inline
+M: cord vbitand [ vbitand ] [ call-next-method ] cord-2map ; inline
+M: cord vbitandn [ vbitandn ] [ call-next-method ] cord-2map ; inline
+M: cord vbitor [ vbitor ] [ call-next-method ] cord-2map ; inline
+M: cord vbitxor [ vbitxor ] [ call-next-method ] cord-2map ; inline
M: cord vbitnot [ vbitnot ] cord-map ; inline
-M: cord vand [ vand ] cord-2map ; inline
-M: cord vandn [ vandn ] cord-2map ; inline
-M: cord vor [ vor ] cord-2map ; inline
-M: cord vxor [ vxor ] cord-2map ; inline
+M: cord vand [ vand ] [ call-next-method ] cord-2map ; inline
+M: cord vandn [ vandn ] [ call-next-method ] cord-2map ; inline
+M: cord vor [ vor ] [ call-next-method ] cord-2map ; inline
+M: cord vxor [ vxor ] [ call-next-method ] cord-2map ; inline
M: cord vnot [ vnot ] cord-map ; inline
M: cord vlshift '[ _ vlshift ] cord-map ; inline
M: cord vrshift '[ _ vrshift ] cord-map ; inline
M: cord (vmerge-head) [ head>> ] bi@ (vmerge) cord-append ; inline
M: cord (vmerge-tail) [ tail>> ] bi@ (vmerge) cord-append ; inline
-M: cord v<= [ v<= ] cord-2map ; inline
-M: cord v< [ v< ] cord-2map ; inline
-M: cord v= [ v= ] cord-2map ; inline
-M: cord v> [ v> ] cord-2map ; inline
-M: cord v>= [ v>= ] cord-2map ; inline
-M: cord vunordered? [ vunordered? ] cord-2map ; inline
+M: cord v<= [ v<= ] [ call-next-method ] cord-2map ; inline
+M: cord v< [ v< ] [ call-next-method ] cord-2map ; inline
+M: cord v= [ v= ] [ call-next-method ] cord-2map ; inline
+M: cord v> [ v> ] [ call-next-method ] cord-2map ; inline
+M: cord v>= [ v>= ] [ call-next-method ] cord-2map ; inline
+M: cord vunordered? [ vunordered? ] [ call-next-method ] cord-2map ; inline
M: cord vany? [ vany? ] cord-both or ; inline
M: cord vall? [ vall? ] cord-both and ; inline
M: cord vnone? [ vnone? ] cord-both and ; inline
!
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables assocs help.syntax
-help.markup splitting io.streams.byte-array io.encodings.string
-io.encodings.utf8 io.encodings.binary combinators accessors
-locals prettyprint compiler.units sequences.private
-classes.tuple.private vocabs.loader ;
+vectors byte-arrays quotations hashtables hashtables.identity
+assocs help.syntax help.markup splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators accessors locals prettyprint compiler.units
+sequences.private classes.tuple.private vocabs.loader ;
IN: serialize
GENERIC: (serialize) ( obj -- )
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
-TUPLE: id obj ;
-
-C: <id> id
-
-M: id hashcode* nip obj>> identity-hashcode ;
-
-M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
-
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
#! objects.
- serialized get [ assoc-size swap <id> ] keep set-at ;
+ serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
- <id> serialized get at ;
+ serialized get at ;
! Numbers are serialized as follows:
! 0 => B{ 0 }
[ (deserialize) ] with-variable ;
: serialize ( obj -- )
- H{ } clone serialized [ (serialize) ] with-variable ;
+ IH{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
USING: mirrors specialized-arrays math.vectors ;
IN: specialized-arrays.mirrors
-INSTANCE: specialized-array enumerated-sequence
+INSTANCE: specialized-array inspected-sequence
-USING: help.markup help.syntax byte-arrays alien ;
+USING: help.markup help.syntax byte-arrays alien math sequences ;
IN: specialized-arrays
HELP: SPECIALIZED-ARRAY:
{ POSTPONE: SPECIALIZED-ARRAY: POSTPONE: SPECIALIZED-ARRAYS: } related-words
+HELP: direct-slice
+{ $values { "from" integer } { "to" integer } { "seq" "a specialized array" } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the subsequence of " { $snippet "seq" } " from elements " { $snippet "from" } " up to but not including " { $snippet "to" } ". Like " { $link slice } ", raises an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
+
+HELP: direct-head
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the first " { $snippet "n" } " elements of " { $snippet "seq" } ". Like " { $link head } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-tail
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as " { $snippet "seq" } " without the first " { $snippet "n" } " elements. Like " { $link tail } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-head*
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as " { $snippet "seq" } " without the last " { $snippet "n" } " elements. Like " { $link head* } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+HELP: direct-tail*
+{ $values { "seq" "a specialized array" } { "n" integer } { "seq'" "a new specialized array" } }
+{ $description "Constructs a new specialized array of the same type as " { $snippet "seq" } " sharing the same underlying memory as the last " { $snippet "n" } " elements of " { $snippet "seq" } ". Like " { $link tail* } ", raises an error if " { $snippet "n" } " is out of bounds." } ;
+
+{ direct-slice direct-head direct-tail direct-head* direct-tail* } related-words
+
ARTICLE: "specialized-array-words" "Specialized array words"
"The " { $link POSTPONE: SPECIALIZED-ARRAY: } " and " { $link POSTPONE: SPECIALIZED-ARRAYS: } " parsing words generate specialized array types if they haven't been generated already and add the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
{ { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
{ { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
-"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } " or " { $link POSTPONE: SPECIALIZED-ARRAYS: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } " or " { $link POSTPONE: SPECIALIZED-ARRAYS: } ". This ensures that the vocabulary can get generated the first time it is needed."
+$nl
+"Additionally, special versions of the standard " { $link <slice> } ", " { $link head } ", and " { $link tail } " sequence operations are provided for specialized arrays to create a new specialized array object sharing storage with a subsequence of an existing array:"
+{ $subsections
+ direct-slice
+ direct-head
+ direct-tail
+ direct-head*
+ direct-tail*
+} ;
ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
"If a C function is declared as taking a parameter with a pointer or an array type (for example, " { $snippet "float*" } " or " { $snippet "int[3]" } "), instances of the relevant specialized array can be passed in."
\ struct-resize-test-usage forget
] with-compilation-unit
] unit-test
+
+[ int-array{ 4 5 6 } ] [ 3 6 int-array{ 1 2 3 4 5 6 7 8 } direct-slice ] unit-test
+[ int-array{ 1 2 3 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head ] unit-test
+[ int-array{ 1 2 3 4 5 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head* ] unit-test
+[ int-array{ 4 5 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail ] unit-test
+[ int-array{ 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail* ] unit-test
+
+
+[ int-array{ 1 2 3 4 55555 6 7 8 } ] [
+ int-array{ 1 2 3 4 5 6 7 8 }
+ 3 6 pick direct-slice [ 55555 1 ] dip set-nth
+] unit-test
+
<PRIVATE
+GENERIC: nth-c-ptr ( n seq -- displaced-alien )
+GENERIC: direct-like ( alien len exemplar -- seq )
+
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
+M: A direct-like drop <direct-A> ; inline
+
: <A> ( n -- specialized-array )
[ \ T <underlying> ] keep <direct-A> ; inline
M: A nth-unsafe underlying>> \ T alien-element ; inline
+M: A nth-c-ptr underlying>> \ T array-accessor drop swap <displaced-alien> ; inline
+
M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
: >A ( seq -- specialized-array ) A new clone-like ;
bi
] "" make ;
+: direct-slice-unsafe ( from to seq -- seq' )
+ [ nip nth-c-ptr ]
+ [ drop swap - ]
+ [ 2nip ] 3tri direct-like ; inline
+
PRIVATE>
+: direct-slice ( from to seq -- seq' )
+ check-slice direct-slice-unsafe ; inline
+
+: direct-head ( seq n -- seq' ) (head) direct-slice ; inline
+: direct-tail ( seq n -- seq' ) (tail) direct-slice ; inline
+: direct-head* ( seq n -- seq' ) from-end direct-head ; inline
+: direct-tail* ( seq n -- seq' ) from-end direct-tail ; inline
+
: define-array-vocab ( type -- vocab )
underlying-type
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: specialized-vectors mirrors ;
+IN: specialized-vectors.mirrors
+
+INSTANCE: specialized-vector inspected-sequence
-USING: help.markup help.syntax byte-vectors alien byte-arrays ;
+USING: help.markup help.syntax byte-vectors alien byte-arrays classes.struct ;
IN: specialized-vectors
HELP: SPECIALIZED-VECTOR:
}
"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+HELP: push-new
+{ $values { "vector" "a specialized vector of structs" } { "new" "a new value of the specialized vector's type" } }
+{ $description "Grows " { $snippet "vector" } ", increasing its length by one, and outputs a " { $link struct } " object wrapping the newly allocated storage." }
+{ $notes "This word allows struct objects to be streamed into a struct vector efficiently without excessive copying. The typical Factor idiom for pushing a new object onto a vector, when used with struct vectors, will allocate and copy a temporary struct object:"
+{ $code """foo <struct>
+ 5 >>a
+ 6 >>b
+foo-vector{ } clone push""" }
+"By using " { $snippet "push-new" } ", the new struct can be allocated directly from the vector and the intermediate copy can be avoided:"
+{ $code """foo-vector{ } clone push-new
+ 5 >>a
+ 6 >>b
+ drop""" } } ;
+
ARTICLE: "specialized-vector-c" "Passing specialized vectors to C functions"
"Each specialized vector has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
"specialized-vector-words"
"specialized-vector-c"
}
+"This vocabulary also contains special vector operations for making efficient use of specialized vector types:"
+{ $subsections
+ push-new
+}
"The " { $vocab-link "specialized-arrays" } " vocabulary provides a fixed-length version of this abstraction." ;
ABOUT: "specialized-vectors"
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.parser assocs
-compiler.units functors growable kernel lexer math namespaces
-parser prettyprint.custom sequences specialized-arrays
-specialized-arrays.private strings vocabs vocabs.parser
-vocabs.generated fry make ;
+classes compiler.units functors growable kernel lexer math
+namespaces parser prettyprint.custom sequences
+specialized-arrays specialized-arrays.private strings
+vocabs vocabs.loader vocabs.parser vocabs.generated fry make ;
+FROM: sequences.private => nth-unsafe ;
+FROM: specialized-arrays.private => nth-c-ptr direct-like ;
QUALIFIED: vectors.functor
IN: specialized-vectors
+MIXIN: specialized-vector
+
<PRIVATE
FUNCTOR: define-vector ( T -- )
-V DEFINES-CLASS ${T}-vector
+V DEFINES-CLASS ${T}-vector
-A IS ${T}-array
-<A> IS <${A}>
+A IS ${T}-array
+>A IS >${A}
+<A> IS <${A}>
+<direct-A> IS <direct-${A}>
->V DEFERS >${V}
-V{ DEFINES ${V}{
+>V DEFERS >${V}
+V{ DEFINES ${V}{
WHERE
M: V pprint* pprint-object ;
+M: V >c-ptr underlying>> underlying>> ; inline
+M: V byte-length [ length ] [ element-size ] bi * ; inline
+
+M: V direct-like drop <direct-A> ; inline
+M: V nth-c-ptr underlying>> nth-c-ptr ; inline
+
+M: A like
+ drop dup A instance? [
+ dup V instance? [ [ >c-ptr ] [ length>> ] bi <direct-A> ] [ >A ] if
+ ] unless ; inline
+
SYNTAX: V{ \ } [ >V ] parse-literal ;
+INSTANCE: V specialized-vector
INSTANCE: V growable
;FUNCTOR
PRIVATE>
+: push-new ( vector -- new )
+ [ length ] keep ensure nth-unsafe ; inline
+
: define-vector-vocab ( type -- vocab )
underlying-type
[ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
scan-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi ;
+
+{ "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when
word>> name>> "Cannot compile call to “" "”" surround ;
M: unbalanced-branches-error summary
- word>> name>>
- "The input quotations to “" "” don't match their expected effects" surround ;
+ [ word>> name>> ] [ quots>> length 1 = ] bi
+ [ "The input quotation to “" "” doesn't match its expected effect" ]
+ [ "The input quotations to “" "” don't match their expected effects" ] if
+ surround ;
M: unbalanced-branches-error error.
dup summary print
--- /dev/null
+Doug Coleman
--- /dev/null
+One-time and recurring timers for relative time offsets
--- /dev/null
+USING: help.markup help.syntax calendar quotations system ;\r
+IN: timers\r
+\r
+HELP: timer\r
+{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;\r
+\r
+HELP: start-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts a timer." } ;\r
+\r
+HELP: restart-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;\r
+\r
+HELP: stop-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;\r
+\r
+HELP: every\r
+{ $values\r
+ { "quot" quotation } { "interval-duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: later\r
+{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }\r
+{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Break's over!" print flush ] 15 minutes later drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: delayed-every\r
+{ $values\r
+ { "quot" quotation } { "duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+ARTICLE: "timers" "Alarms"\r
+"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
+"The timer class:"\r
+{ $subsections timer }\r
+"Create a timer before starting it:"\r
+{ $subsections <timer> }\r
+"Starting a timer:"\r
+{ $subsections start-timer restart-timer }\r
+"Stopping a timer:"\r
+{ $subsections stop-timer }\r
+\r
+"A recurring timer without an initial delay:"\r
+{ $subsections every }\r
+"A one-time timer with an initial delay:"\r
+{ $subsections later }\r
+"A recurring timer with an initial delay:"\r
+{ $subsections delayed-every } ;\r
+\r
+ABOUT: "timers"\r
--- /dev/null
+USING: timers timers.private calendar concurrency.count-downs\r
+concurrency.promises fry kernel math math.order sequences\r
+threads tools.test tools.time ;\r
+IN: timers.tests\r
+\r
+[ ] [\r
+ 1 <count-down>\r
+ { f } clone 2dup\r
+ [ first stop-timer count-down ] 2curry 1 seconds later\r
+ swap set-first\r
+ await\r
+] unit-test\r
+\r
+[ ] [\r
+ self [ resume ] curry instant later drop\r
+ "test" suspend drop\r
+] unit-test\r
+\r
+[ t ] [\r
+ [\r
+ <promise>\r
+ [ '[ t _ fulfill ] 2 seconds later drop ]\r
+ [ 5 seconds ?promise-timeout drop ] bi\r
+ ] benchmark 1,500,000,000 2,500,000,000 between?\r
+] unit-test\r
+\r
+[ { 3 } ] [\r
+ { 3 } dup\r
+ '[ 4 _ set-first ] 2 seconds later\r
+ 1/2 seconds sleep\r
+ stop-timer\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
+ [ stop-timer ] [ start-timer ] bi\r
+ 4 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
+ 2 seconds sleep stop-timer\r
+ 1/2 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 1 _ set-first ] 300 milliseconds later\r
+ 150 milliseconds sleep\r
+ [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
+ 100 milliseconds sleep restart-timer 300 milliseconds sleep\r
+] unit-test\r
+\r
+[ { 4 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
+ <timer> dup start-timer\r
+ 700 milliseconds sleep dup restart-timer\r
+ 700 milliseconds sleep stop-timer 500 milliseconds sleep\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators.short-circuit fry
+heaps init kernel math math.functions math.parser namespaces
+quotations sequences system threads ;
+IN: timers
+
+TUPLE: timer
+ { quot callable initial: [ ] }
+ start-nanos
+ delay-nanos
+ interval-nanos
+ iteration-start-nanos
+ quotation-running?
+ restart?
+ thread ;
+
+<PRIVATE
+
+GENERIC: >nanoseconds ( obj -- duration/f )
+M: f >nanoseconds ;
+M: real >nanoseconds >integer ;
+M: duration >nanoseconds duration>nanoseconds >integer ;
+
+: set-next-timer-time ( timer -- timer )
+ ! start + delay + ceiling((now - (start + delay)) / interval) * interval
+ nano-count
+ over start-nanos>> -
+ over delay-nanos>> [ - ] when*
+ over interval-nanos>> / ceiling
+ over interval-nanos>> *
+ over start-nanos>> +
+ over delay-nanos>> [ + ] when*
+ >>iteration-start-nanos ;
+
+: stop-timer? ( timer -- ? )
+ { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
+
+DEFER: call-timer-loop
+
+: loop-timer ( timer -- )
+ nano-count over
+ [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
+ [ set-next-timer-time ] dip
+ [ dup iteration-start-nanos>> ] [ 0 ] if
+ 0 or sleep-until call-timer-loop ;
+
+: maybe-loop-timer ( timer -- )
+ dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
+ [ drop ] [ loop-timer ] if ;
+
+: call-timer-loop ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ [
+ [ t >>quotation-running? drop ]
+ [ quot>> call( -- ) ]
+ [ f >>quotation-running? drop ] tri
+ ] keep
+ maybe-loop-timer
+ ] if ;
+
+: sleep-delay ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ nano-count >>start-nanos
+ delay-nanos>> [ sleep ] when*
+ ] if ;
+
+: timer-loop ( timer -- )
+ [ sleep-delay ]
+ [ nano-count >>iteration-start-nanos call-timer-loop ]
+ [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
+
+PRIVATE>
+
+: <timer> ( quot delay-duration/f interval-duration/f -- timer )
+ timer new
+ swap >nanoseconds >>interval-nanos
+ swap >nanoseconds >>delay-nanos
+ swap >>quot ; inline
+
+: start-timer ( timer -- )
+ [
+ '[ _ timer-loop ] "Alarm execution" spawn
+ ] keep thread<< ;
+
+: stop-timer ( timer -- )
+ dup quotation-running?>> [
+ f >>thread drop
+ ] [
+ [ [ interrupt ] when* f ] change-thread drop
+ ] if ;
+
+: restart-timer ( timer -- )
+ t >>restart?
+ dup quotation-running?>> [
+ drop
+ ] [
+ dup thread>> [ nip interrupt ] [ start-timer ] if*
+ ] if ;
+
+<PRIVATE
+
+: (start-timer) ( quot start-duration interval-duration -- timer )
+ <timer> [ start-timer ] keep ;
+
+PRIVATE>
+
+: every ( quot interval-duration -- timer )
+ [ f ] dip (start-timer) ;
+
+: later ( quot delay-duration -- timer )
+ f (start-timer) ;
+
+: delayed-every ( quot duration -- timer )
+ dup (start-timer) ;
+
+: nanos-since ( nano-count -- nanos )
+ [ nano-count ] dip - ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
$nl
-"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, timers, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
strip-io? [ io-backend , ] when
{ } {
- "alarms"
+ "timers"
"tools"
"io.launcher"
"random"
USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
{
- { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
+ {
+ [ cpu x86.32? ]
+ [
+ os windows?
+ [ [ 624 ] [ ud heap-size ] unit-test ]
+ [ [ 604 ] [ ud heap-size ] unit-test ] if
+ ]
+ }
+ { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] }
[ ]
} cond
\ No newline at end of file
{ c3 uchar }
{ inp_cache uchar[256] }
{ inp_sess uchar[64] }
- { itab_entry void* } ;
+ { have_modrm uchar }
+ { modrm uchar }
+ { user_opaque_data void* }
+ { itab_entry void* }
+ { le void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
f <model> (error-list-model) set-global
(error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
updater add-error-observer
-] "ui.tools.error-list" add-startup-hook
-
+] "tools.errors.model" add-startup-hook
vocabs.loader vocabs.metadata io combinators calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets classes
-math alien urls splitting ascii combinators.short-circuit alarms
+math alien urls splitting ascii combinators.short-circuit timers
words.symbol system summary ;
IN: tools.scaffold
<PRIVATE
-: vocab-root? ( string -- ? ) vocab-roots get member? ;
+: vocab-root? ( string -- ? )
+ trim-tail-separators
+ vocab-roots get member? ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
{ "ch" "a character" }
{ "word" word }
{ "array" array }
- { "alarm" alarm }
+ { "timers" timer }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
-USING: definitions kernel locals.definitions see see.private typed words ;
+USING: definitions kernel locals.definitions see see.private typed words
+summary make accessors classes ;
IN: typed.prettyprint
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-word definition "typed-def" word-prop ;
M: typed-word declarations. "typed-word" word-prop declarations. ;
+M: input-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected input value of type " %
+ dup expected-type>> name>> %
+ " but got " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
+
+M: output-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected to output value of type " %
+ dup expected-type>> name>> %
+ " but gave " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
-compiler.tree.debugger prettyprint definitions compiler.units ;
+quotations tools.test typed words words.symbol combinators.short-circuit
+compiler.tree.debugger prettyprint definitions compiler.units sequences ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
TYPED: dum ( x: tweedle-dum -- y )
drop \ tweedle-dum ;
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
+[ \ tweedle-dee new dum ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED: dumdum ( x -- y: tweedle-dum )
drop \ tweedle-dee new ;
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+[ f dumdum ]
+[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED:: f+locals ( a: float b: float -- c: float )
a b + ;
FROM: classes.tuple.private => tuple-layout ;
IN: typed
-ERROR: type-mismatch-error word expected-types ;
+ERROR: type-mismatch-error value expected-type word expected-types ;
ERROR: input-mismatch-error < type-mismatch-error ;
ERROR: output-mismatch-error < type-mismatch-error ;
: typed-stack-effect? ( effect -- ? )
[ object = ] all? not ;
-: input-mismatch-quot ( word types -- quot )
- [ input-mismatch-error ] 2curry ;
-
: depends-on-unboxing ( class -- )
[ dup tuple-layout depends-on-tuple-layout ]
[ depends-on-final ]
:: unboxer ( error-quot word types type -- quot )
type "coercer" word-prop [ ] or
- [ dup type instance? [ word types error-quot call ] unless ]
+ type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
type (unboxer)
compose compose ;
}
: validate-action ( world selector -- ? validated? )
- selector>action at
- [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
+ selector>action at
+ [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
CLASS: {
{ +superclass+ "NSOpenGLView" }
]
}
-! "rotateWithEvent:" void { id SEL id }}
-
{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
{ "dealloc" void { id SEL }
[
drop
- [ unregister-window ]
[ remove-observer ]
[ SUPER-> dealloc ]
- tri
+ bi
]
} ;
[
forget-rollover
2nip -> object -> contentView
- dup -> isInFullScreenMode zero?
- [ window unfocus-world ]
+ dup -> isInFullScreenMode 0 =
+ [ window [ unfocus-world ] when* ]
[ drop ] if
]
}
{ "windowWillClose:" void { id SEL id }
[
- 2nip -> object -> contentView window ungraft
+ 2nip -> object -> contentView
+ [ window ungraft ] [ unregister-window ] bi
]
} ;
[ [ execute( -- wm ) add-wm-handler ] with each ]
[ wm-handlers get-global set-at ] if ;
+: remove-wm-handler ( wm -- )
+ wm-handlers get-global delete-at ;
+
[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays assocs calendar colors.constants
+USING: accessors timers arrays assocs calendar colors.constants
combinators combinators.short-circuit documents
documents.elements fry grouping kernel locals make math
math.functions math.order math.ranges math.rectangles
TUPLE: editor < line-gadget
caret-color
caret mark
-focused? blink blink-alarm ;
+focused? blink blink-timer ;
<PRIVATE
750 milliseconds blink-interval set-global
: stop-blinking ( editor -- )
- blink-alarm>> [ stop-alarm ] when* ;
+ blink-timer>> [ stop-timer ] when* ;
: start-blinking ( editor -- )
t >>blink
- blink-alarm>> [ restart-alarm ] when* ;
+ blink-timer>> [ restart-timer ] when* ;
: restart-blinking ( editor -- )
dup focused?>> [
[ dup mark>> activate-editor-model ]
[
[
- '[ _ blink-caret ] blink-interval get dup <alarm>
- ] keep blink-alarm<<
+ '[ _ blink-caret ] blink-interval get dup <timer>
+ ] keep blink-timer<<
] tri ;
M: editor ungraft*
- [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
+ [ [ stop-blinking ] [ f >>blink-timer drop ] bi ]
[ dup caret>> deactivate-editor-model ]
[ dup mark>> deactivate-editor-model ] tri ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.textures sequences io colors combinators
-combinators.short-circuit fry math.vectors math.rectangles cache
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.pixel-formats destructors literals strings ;
+USING: accessors arrays assocs cache colors combinators
+combinators.short-circuit concurrency.promises continuations
+destructors fry io kernel literals math math.rectangles
+math.vectors models namespaces opengl opengl.textures sequences
+strings ui.backend ui.gadgets ui.gadgets.tracks ui.gestures
+ui.pixel-formats ui.render ;
IN: ui.gadgets.worlds
SYMBOLS:
window-loc
pixel-format-attributes
background-color
+ promise
window-controls
window-resources ;
f >>active?
{ 0 0 } >>window-loc
f >>grab-input?
- V{ } clone >>window-resources ;
+ V{ } clone >>window-resources
+ <promise> >>promise ;
: initial-background-color ( attributes -- color )
window-controls>> textured-background swap member-eq?
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes boxes calendar alarms combinators
+math.vectors classes.tuple classes boxes calendar timers combinators
sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ;
FROM: namespaces => set ;
[ drag-gesture ]
300 milliseconds
100 milliseconds
- <alarm>
+ <timer>
[ drag-timer get-global >box ]
- [ start-alarm ] bi
+ [ start-timer ] bi
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global ?box
- [ stop-alarm ] [ drop ] if
+ [ stop-timer ] [ drop ] if
] when ;
: fire-motion ( -- )
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
+ GL_PACK_ALIGNMENT 1 glPixelStorei
+ GL_UNPACK_ALIGNMENT 1 glPixelStorei
init-matrices
[ init-clip ]
[
error-list-model get-global [ drop all-errors ] <arrow>
<error-list-gadget> ;
+[ \ error-list-gadget reset-memoized ] "ui.tools.error-list" add-startup-hook
+
: show-error-list ( -- )
[ error-list-gadget eq? ] find-window
[ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
{ $description "Makes the native window containing the given gadget the front-most window." } ;
HELP: with-ui
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation, starting the UI first if necessary." }
-{ $notes "This combinator should be used in the " { $link POSTPONE: MAIN: } " word of a vocabulary, in order for the vocabulary to work when run from the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
-{ $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this combinator." } ;
+{ $values { "quot" { $quotation "( -- )" } } }
+{ $description "Calls the quotation, starting the UI first if necessary. If the UI is started, this word does not return." }
+{ $notes "This word should be used in the " { $link POSTPONE: MAIN: } " word of an application that uses the UI in order for the vocabulary to work when run from either the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
+{ $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this word." } ;
HELP: beep
{ $description "Plays the system beep sound." } ;
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs boxes io kernel math models namespaces make
-dlists deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables
-concurrency.flags sets accessors calendar fry destructors
-ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render strings
-classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
+USING: accessors arrays assocs boxes classes.tuple
+classes.tuple.parser combinators combinators.short-circuit
+concurrency.flags concurrency.promises continuations deques
+destructors dlists fry init kernel lexer make math namespaces
+parser sequences sets strings threads ui.backend ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser
+words ;
IN: ui
<PRIVATE
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
[ [ (close-window) f ] change-handle drop ]
[ unfocus-world ]
+ [ promise>> t swap fulfill ]
} cleave ;
: init-ui ( -- )
<flag> ui-notify-flag set-global
] "ui" add-startup-hook
-: with-ui ( quot -- )
+: with-ui ( quot: ( -- ) -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
HOOK: beep ui-backend ( -- )
FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
FUNCTION: group* getgrent ;
+FUNCTION: void endgrent ( ) ;
FUNCTION: int gethostname ( c-string name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
HELP: with-effective-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+ { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-group-cache
{ $values
HELP: with-real-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+ { "string/id/f" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
+
+HELP: ?group-id
+{ $values
+ { "string" string }
+ { "id" "a group id" }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-group-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: group-exists?
+{ $values
+ { "name/id" "a name or a group id" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the group's existence." } ;
ARTICLE: "unix.groups" "Unix groups"
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
$nl
-"Listing all groups:"
+"Listing all group structures:"
{ $subsections all-groups }
-"Real groups:"
+"Listing all group names:"
+{ $subsections all-group-names }
+"Checking if a group exists:"
+{ $subsections group-exists? }
+"Querying/setting the current real group:"
{ $subsections
real-group-name
real-group-id
set-real-group
}
-"Effective groups:"
+"Querying/setting the current effective group:"
{ $subsections
effective-group-name
effective-group-id
set-effective-group
}
+"Getting a group id from a group name or id:"
+{ $subsections
+ ?group-id
+}
"Combinators to change groups:"
{ $subsections
with-real-group
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.groups kernel strings math ;
+USING: kernel math sequences strings tools.test unix.groups ;
IN: unix.groups.tests
[ ] [ all-groups drop ] unit-test
[ ] [ real-group-id group-name drop ] unit-test
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-exists? ] unit-test
+[ "please-oh-please-don't-have-a-group-named-this123lalala" ?group-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-group ] unit-test
+[ 3 ] [ f [ 3 ] with-real-group ] unit-test
+
+[ f ]
+[ all-groups drop all-groups empty? ] unit-test
+
[ f ]
-[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ all-group-names drop all-group-names empty? ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities classes.struct unix ;
-IN: unix.groups
-
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry io.backend.unix
+io.encodings.utf8 kernel math math.parser namespaces sequences
+splitting strings unix unix.ffi unix.users unix.utilities ;
QUALIFIED: unix.ffi
-
QUALIFIED: grouping
+IN: unix.groups
TUPLE: group id name passwd members ;
: group-id ( string -- id/f )
group-struct dup [ gr_gid>> ] when ;
+ERROR: no-group string ;
+
+: ?group-id ( string -- id )
+ dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
+
<PRIVATE
: >groups ( byte-array n -- groups )
user-name (user-groups) ;
: all-groups ( -- seq )
- [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
+ [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
+ endgrent ;
+
+: all-group-names ( -- seq )
+ all-groups [ name>> ] map ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: effective-group-name ( -- string )
effective-group-id group-name ; inline
+: group-exists? ( name/id -- ? ) group-id >boolean ;
+
GENERIC: set-real-group ( obj -- )
GENERIC: set-effective-group ( obj -- )
-: with-real-group ( string/id quot -- )
+: (with-real-group) ( string/id quot -- )
'[ _ set-real-group @ ]
real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
-: with-effective-group ( string/id quot -- )
+: with-real-group ( string/id/f quot -- )
+ over [ (with-real-group) ] [ nip call ] if ; inline
+
+: (with-effective-group) ( string/id quot -- )
'[ _ set-effective-group @ ]
effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+: with-effective-group ( string/id/f quot -- )
+ over [ (with-effective-group) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-group) ( id -- )
PRIVATE>
-M: string set-real-group ( string -- )
- group-id (set-real-group) ;
-
M: integer set-real-group ( id -- )
(set-real-group) ;
+M: string set-real-group ( string -- )
+ ?group-id (set-real-group) ;
+
M: integer set-effective-group ( id -- )
(set-effective-group) ;
M: string set-effective-group ( string -- )
- group-id (set-effective-group) ;
+ ?group-id (set-effective-group) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types
-classes.struct accessors ;
+USING: accessors alien.c-types alien.syntax calendar
+classes.struct kernel math unix.types ;
IN: unix.time
STRUCT: timeval
swap >>nsec
swap >>sec ;
+STRUCT: timezone
+ { tz_minuteswest int }
+ { tz_dsttime int } ;
+
+: timestamp>timezone ( timestamp -- timezone )
+ gmt-offset>> duration>minutes
+ 1
+ \ timezone <struct-boa> ; inline
+
STRUCT: tm
{ sec int }
{ min int }
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
+FUNCTION: int settimeofday ( timeval* TP, timezone* TZP ) ;
+FUNCTION: int adjtime ( timeval* delta, timeval* olddelta ) ;
HELP: with-effective-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-user-cache
{ $values
HELP: with-real-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
{
real-user-name real-user-id set-real-user
set-effective-user
} related-words
+HELP: ?user-id
+{ $values
+ { "string" string }
+ { "id/f" "an integer or " { $link f } }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-user-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: user-exists?
+{ $values
+ { "name/id" "a string or an integer" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the user's existence." } ;
+
ARTICLE: "unix.users" "Unix users"
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
$nl
"Listing all users:"
{ $subsections all-users }
-"Real user:"
+"Listing all user names:"
+{ $subsections all-user-names }
+"Checking if a user exists:"
+{ $subsections user-exists? }
+"Querying/setting the current real user:"
{ $subsections
real-user-name
real-user-id
set-real-user
}
-"Effective user:"
+"Querying/setting the current effective user:"
{ $subsections
effective-user-name
effective-user-id
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.users kernel strings math ;
+USING: tools.test unix.users kernel strings math sequences ;
IN: unix.users.tests
[ ] [ all-users drop ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-id ] unit-test
+[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-exists? ] unit-test
+[ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" ?user-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-user ] unit-test
+[ 3 ] [ f [ 3 ] with-real-user ] unit-test
+
+[ f ]
+[ all-users drop all-users empty? ] unit-test
+
+[ f ]
+[ all-user-names drop all-user-names empty? ] unit-test
[ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
] with-pwent ;
+: all-user-names ( -- seq )
+ all-users [ user-name>> ] map ;
+
SYMBOL: user-cache
: <user-cache> ( -- assoc )
: user-id ( string -- id/f )
user-passwd dup [ uid>> ] when ;
+ERROR: no-user string ;
+
+: ?user-id ( string -- id/f )
+ dup user-passwd [ nip uid>> ] [ no-user ] if* ;
+
: real-user-id ( -- id )
unix.ffi:getuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
+: user-exists? ( name/id -- ? ) user-id >boolean ;
+
GENERIC: set-real-user ( string/id -- )
GENERIC: set-effective-user ( string/id -- )
-: with-real-user ( string/id quot -- )
+: (with-real-user) ( string/id quot -- )
'[ _ set-real-user @ ]
real-user-id '[ _ set-real-user ]
[ ] cleanup ; inline
-: with-effective-user ( string/id quot -- )
+: with-real-user ( string/id/f quot -- )
+ over [ (with-real-user) ] [ nip call ] if ; inline
+
+: (with-effective-user) ( string/id quot -- )
'[ _ set-effective-user @ ]
effective-user-id '[ _ set-effective-user ]
[ ] cleanup ; inline
+: with-effective-user ( string/id/f quot -- )
+ over [ (with-effective-user) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-user) ( id -- )
PRIVATE>
-M: string set-real-user ( string -- )
- user-id (set-real-user) ;
-
M: integer set-real-user ( id -- )
(set-real-user) ;
+M: string set-real-user ( string -- )
+ ?user-id (set-real-user) ;
+
M: integer set-effective-user ( id -- )
(set-effective-user) ;
M: string set-effective-user ( string -- )
- user-id (set-effective-user) ;
+ ?user-id (set-effective-user) ;
os {
{ [ dup bsd? ] [ drop "unix.users.bsd" require ] }
! FUNCTION: SetProcessWorkingSetSize
! FUNCTION: SetStdHandle
! FUNCTION: SetSystemPowerState
-! FUNCTION: SetSystemTime
+FUNCTION: BOOL SetSystemTime ( SYSTEMTIME* lpSystemTime ) ;
! FUNCTION: SetSystemTimeAdjustment
! FUNCTION: SetTapeParameters
! FUNCTION: SetTapePosition
] each-interpolated drop ;
: >search-hash ( seq -- hash )
- [ dup search ] H{ } map>assoc ;
+ [ dup parse-word ] H{ } map>assoc ;
: extract-variables ( xml -- seq )
[ [ var>> , ] each-interpolated ] { } make ;
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 sorting accessors xml.data
-xml.traversal xml.syntax ;
+words globs combinators io.encodings.utf8 io.pathnames sorting
+accessors regexp unicode.case xml.data xml.traversal
+xml.syntax ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
{ "FILE_NAME_GLOB" f file-name-glob<< }
{ "FIRST_LINE_GLOB" f first-line-glob<< }
} init-from-tag
+ [ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
+ [ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
] dip
rot set-at ;
: reset-modes ( -- )
\ (load-mode) reset-memoized ;
-: ?glob-matches ( string glob/f -- ? )
- dup [ glob-matches? ] [ 2drop f ] if ;
+: ?matches ( string glob/f -- ? )
+ [ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
: suitable-mode? ( file-name first-line mode -- ? )
- [ nip ] 2keep first-line-glob>> ?glob-matches
- [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
+ [ nip ] 2keep first-line-glob>> ?matches
+ [ 2drop t ] [ file-name-glob>> ?matches ] if ;
-: find-mode ( file-name first-line -- mode )
+: ?find-mode ( file-name first-line -- mode/f )
+ [ file-name ] dip
modes
[ nip [ 2dup ] dip suitable-mode? ] assoc-find
- 2drop [ 2drop ] dip [ "text" ] unless* ;
+ 2drop [ 2drop ] dip ;
+
+: find-mode ( file-name first-line -- mode )
+ ?find-mode "text" or ; inline
FILE_NAME_GLOB="*.{cfm,dbm,cfc}" />\r
\r
<MODE NAME="c++" FILE="cplusplus.xml"\r
- FILE_NAME_GLOB="*.{cc,cpp,hh,hpp,cxx}" />\r
+ FILE_NAME_GLOB="*.{cc,cpp,hh,hpp,cxx,inl,mm}" />\r
+\r
+<MODE NAME="cuda" FILE="cuda.xml"\r
+ FILE_NAME_GLOB="*.{cu,gpu,cuh}" />\r
\r
<MODE NAME="c#" FILE="csharp.xml"\r
FILE_NAME_GLOB="*.cs" />\r
--- /dev/null
+<?xml version="1.0"?>\r
+\r
+<!DOCTYPE MODE SYSTEM "xmode.dtd">\r
+\r
+<!-- Extension of cplusplus.xml to add CUDA specific syntax. -->\r
+<MODE>\r
+ <PROPS>\r
+ <PROPERTY NAME="commentStart" VALUE="/*" />\r
+ <PROPERTY NAME="commentEnd" VALUE="*/" />\r
+ <PROPERTY NAME="lineComment" VALUE="//" />\r
+ <PROPERTY NAME="wordBreakChars" VALUE=",+-=<>/?^&*" />\r
+\r
+\r
+ <!-- Auto indent -->\r
+ <PROPERTY NAME="indentOpenBrackets" VALUE="{" />\r
+ <PROPERTY NAME="indentCloseBrackets" VALUE="}" />\r
+ <PROPERTY NAME="unalignedOpenBrackets" VALUE="(" />\r
+ <PROPERTY NAME="unalignedCloseBrackets" VALUE=")" />\r
+ <PROPERTY NAME="indentNextLine"\r
+ VALUE="(?!^\s*(#|//)).*(\b(if|while|for)\s*\(.*\)|\b(else|do)\b)[^{;]*$" />\r
+ <PROPERTY NAME="unindentThisLine"\r
+ VALUE="^\s*((case\b.*|[\p{Alpha}_][\p{Alnum}_]*)\s*:(?!:)).*$" />\r
+ <PROPERTY NAME="electricKeys" VALUE=":" />\r
+ </PROPS>\r
+\r
+ <RULES\r
+ ESCAPE="\" IGNORE_CASE="FALSE"\r
+ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="[0-9][0-9a-zA-Z]*">\r
+ <EOL_SPAN TYPE="KEYWORD2" AT_WHITESPACE_END="TRUE" DELEGATE="CPP">#</EOL_SPAN>\r
+\r
+ <IMPORT DELEGATE="LEX"/>\r
+ <IMPORT DELEGATE="CORE"/>\r
+ </RULES>\r
+\r
+ <!-- Core C++ language -->\r
+ <RULES SET="LEX"\r
+ ESCAPE="\" IGNORE_CASE="FALSE"\r
+ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="[0-9][0-9a-zA-Z]*">\r
+\r
+ <IMPORT DELEGATE="c::LEX"/>\r
+ <IMPORT DELEGATE="c++::LEX"/>\r
+\r
+ <SEQ TYPE="OPERATOR"><<<</SEQ>\r
+ <SEQ TYPE="OPERATOR">>>></SEQ>\r
+ </RULES>\r
+\r
+ <!-- Extra CUDA keywords -->\r
+ <RULES SET="CORE"\r
+ ESCAPE="\" IGNORE_CASE="FALSE"\r
+ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="[0-9][0-9a-zA-Z]*">\r
+\r
+ <IMPORT DELEGATE="c::CORE"/>\r
+ <IMPORT DELEGATE="c++::CORE"/>\r
+\r
+ <KEYWORDS>\r
+ <KEYWORD1>__device__</KEYWORD1>\r
+ <KEYWORD2>__host__</KEYWORD2>\r
+ <KEYWORD2>__global__</KEYWORD2>\r
+ <KEYWORD2>__local__</KEYWORD2>\r
+ <KEYWORD2>__constant__</KEYWORD2>\r
+ <KEYWORD2>__shared__</KEYWORD2>\r
+ <KEYWORD1>__inline__</KEYWORD1>\r
+ <KEYWORD1>__restrict__</KEYWORD1>\r
+ <KEYWORD4>blockIdx</KEYWORD4>\r
+ <KEYWORD4>threadIdx</KEYWORD4>\r
+ <KEYWORD4>gridDim</KEYWORD4>\r
+ <KEYWORD4>blockDim</KEYWORD4>\r
+ <KEYWORD3>char1</KEYWORD3>\r
+ <KEYWORD3>char2</KEYWORD3>\r
+ <KEYWORD3>char3</KEYWORD3>\r
+ <KEYWORD3>char4</KEYWORD3>\r
+ <KEYWORD3>uchar1</KEYWORD3>\r
+ <KEYWORD3>uchar2</KEYWORD3>\r
+ <KEYWORD3>uchar3</KEYWORD3>\r
+ <KEYWORD3>uchar4</KEYWORD3>\r
+ <KEYWORD3>short1</KEYWORD3>\r
+ <KEYWORD3>short2</KEYWORD3>\r
+ <KEYWORD3>short3</KEYWORD3>\r
+ <KEYWORD3>short4</KEYWORD3>\r
+ <KEYWORD3>ushort1</KEYWORD3>\r
+ <KEYWORD3>ushort2</KEYWORD3>\r
+ <KEYWORD3>ushort3</KEYWORD3>\r
+ <KEYWORD3>ushort4</KEYWORD3>\r
+ <KEYWORD3>int1</KEYWORD3>\r
+ <KEYWORD3>int2</KEYWORD3>\r
+ <KEYWORD3>int3</KEYWORD3>\r
+ <KEYWORD3>int4</KEYWORD3>\r
+ <KEYWORD3>uint1</KEYWORD3>\r
+ <KEYWORD3>uint2</KEYWORD3>\r
+ <KEYWORD3>uint3</KEYWORD3>\r
+ <KEYWORD3>uint4</KEYWORD3>\r
+ <KEYWORD3>long1</KEYWORD3>\r
+ <KEYWORD3>long2</KEYWORD3>\r
+ <KEYWORD3>long3</KEYWORD3>\r
+ <KEYWORD3>long4</KEYWORD3>\r
+ <KEYWORD3>ulong1</KEYWORD3>\r
+ <KEYWORD3>ulong2</KEYWORD3>\r
+ <KEYWORD3>ulong3</KEYWORD3>\r
+ <KEYWORD3>ulong4</KEYWORD3>\r
+ <KEYWORD3>longlong1</KEYWORD3>\r
+ <KEYWORD3>longlong2</KEYWORD3>\r
+ <KEYWORD3>longlong3</KEYWORD3>\r
+ <KEYWORD3>longlong4</KEYWORD3>\r
+ <KEYWORD3>ulonglong1</KEYWORD3>\r
+ <KEYWORD3>ulonglong2</KEYWORD3>\r
+ <KEYWORD3>ulonglong3</KEYWORD3>\r
+ <KEYWORD3>ulonglong4</KEYWORD3>\r
+ <KEYWORD3>float1</KEYWORD3>\r
+ <KEYWORD3>float2</KEYWORD3>\r
+ <KEYWORD3>float3</KEYWORD3>\r
+ <KEYWORD3>float4</KEYWORD3>\r
+ <KEYWORD3>double1</KEYWORD3>\r
+ <KEYWORD3>double2</KEYWORD3>\r
+ <KEYWORD3>double3</KEYWORD3>\r
+ <KEYWORD3>double4</KEYWORD3>\r
+ <KEYWORD3>dim1</KEYWORD3>\r
+ <KEYWORD3>dim2</KEYWORD3>\r
+ <KEYWORD3>dim3</KEYWORD3>\r
+ <KEYWORD3>dim4</KEYWORD3>\r
+ <KEYWORD3>texture</KEYWORD3>\r
+ </KEYWORDS>\r
+ </RULES>\r
+\r
+ <!-- Preprocessor specific rules -->\r
+ <RULES SET="CPP"\r
+ ESCAPE="\" IGNORE_CASE="FALSE"\r
+ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="[0-9][0-9a-zA-Z]*">\r
+\r
+ <EOL_SPAN_REGEXP HASH_CHAR="include" TYPE="MARKUP" DELEGATE="c::INCLUDE">include\b</EOL_SPAN_REGEXP>\r
+ <EOL_SPAN_REGEXP HASH_CHAR="define" TYPE="MARKUP" DELEGATE="DEFINE">define\b</EOL_SPAN_REGEXP>\r
+ <EOL_SPAN_REGEXP HASH_CHAR="endif" TYPE="MARKUP" DELEGATE="c::LEX">endif\b</EOL_SPAN_REGEXP>\r
+ <EOL_SPAN_REGEXP HASH_CHAR="elif" TYPE="MARKUP" DELEGATE="c::CONDITION">elif\b</EOL_SPAN_REGEXP>\r
+ <EOL_SPAN_REGEXP HASH_CHAR="if" TYPE="MARKUP" DELEGATE="c::CONDITION">if\b</EOL_SPAN_REGEXP>\r
+\r
+ <IMPORT DELEGATE="LEX"/>\r
+\r
+ <!-- Directives -->\r
+ <KEYWORDS>\r
+ <MARKUP>ifdef</MARKUP>\r
+ <MARKUP>ifndef</MARKUP>\r
+ <MARKUP>else</MARKUP>\r
+ <MARKUP>error</MARKUP>\r
+ <MARKUP>line</MARKUP>\r
+ <MARKUP>pragma</MARKUP>\r
+ <MARKUP>undef</MARKUP>\r
+ <MARKUP>warning</MARKUP>\r
+ </KEYWORDS>\r
+ </RULES>\r
+\r
+ <!-- After #define directive -->\r
+ <!-- Almost same as the normal code,\r
+ except two additional operators # and ##. -->\r
+ <RULES SET="DEFINE"\r
+ ESCAPE="\" IGNORE_CASE="FALSE"\r
+ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="[0-9][0-9a-zA-Z]*">\r
+ <SEQ TYPE="OPERATOR">#</SEQ>\r
+ <IMPORT DELEGATE="LEX"/>\r
+ <IMPORT DELEGATE="CORE"/>\r
+ </RULES>\r
+\r
+</MODE>\r
+\r
if Err.Number = 0 then\r
if http.Status = 200 then\r
dim dest_stream\r
- set dest_stream = CreateObject("ADODB.Stream")\r
+ odd = "DOD"\r
+ set dest_stream = CreateObject("A"+odd+"B"+".Stream")\r
\r
Err.Clear\r
dest_stream.Type = 1 ' adTypeBinary\r
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
{ "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
- { "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
{ "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
ARTICLE: "set-operations" "Operations on sets"
"To test if an object is a member of a set:"
-{ $subsections member? }
+{ $subsections in? }
"All sets can be represented as a sequence, without duplicates, of their members:"
{ $subsections members }
"Sets can have members added or removed destructively:"
$nl
"The second way is to create a configuration file. You can list additional vocabulary roots in a file that Factor reads at startup:"
{ $subsections "factor-roots" }
-"Finally, you can add vocabulary roots dynamically using a word:"
+"Finally, you can add vocabulary roots by calling a word from your " { $snippet "factor-rc" } " file (see " { $link "factor-rc" } "):"
{ $subsections add-vocab-root } ;
ARTICLE: "vocabs.roots" "Vocabulary roots"
] "vocabs.loader" add-startup-hook
: add-vocab-root ( root -- )
+ trim-tail-separators
[ vocab-roots get adjoin ]
[ add-vocab-root-hook get-global call( root -- ) ] bi ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.handles alien.syntax
+destructors kernel math tools.test ;
+IN: alien.handles.tests
+
+TUPLE: thingy { x integer } ;
+C: <thingy> thingy
+
+CALLBACK: int thingy-callback ( uint thingy-handle ) ;
+CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ;
+
+: test-thingy-callback ( -- alien )
+ [ alien-handle> x>> 1 + ] thingy-callback ;
+
+: test-thingy-ptr-callback ( -- alien )
+ [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ;
+
+: invoke-test-thingy-callback ( thingy -- n )
+ test-thingy-callback int { uint } cdecl alien-indirect ;
+: invoke-test-thingy-ptr-callback ( thingy -- n )
+ test-thingy-ptr-callback int { void* } cdecl alien-indirect ;
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle> &release-alien-handle [ alien-handle? ] keep ] with-destructors
+ alien-handle?
+] unit-test
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors
+ alien-handle-ptr?
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle> &release-alien-handle
+ invoke-test-thingy-callback
+ ] with-destructors
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr
+ invoke-test-thingy-ptr-callback
+ ] with-destructors
+] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien alien.destructors assocs kernel math math.bitwise
+namespaces ;
+IN: alien.handles
+
+<PRIVATE
+
+SYMBOLS: alien-handle-counter alien-handles ;
+
+alien-handle-counter [ 0 ] initialize
+alien-handles [ H{ } clone ] initialize
+
+: biggest-handle ( -- n )
+ -1 32 bits ; inline
+
+: (next-handle) ( -- n )
+ alien-handle-counter [ 1 + biggest-handle bitand dup ] change-global ; inline
+
+: next-handle ( -- n )
+ [ (next-handle) dup alien-handles get-global key? ] [ drop ] while ;
+
+PRIVATE>
+
+: <alien-handle> ( object -- int )
+ next-handle [ alien-handles get-global set-at ] keep ; inline
+: alien-handle> ( int -- object )
+ alien-handles get-global at ; inline
+
+: alien-handle? ( int -- ? )
+ alien-handles get-global key? >boolean ; inline
+
+: release-alien-handle ( int -- )
+ alien-handles get-global delete-at ; inline
+
+DESTRUCTOR: release-alien-handle
+
+: <alien-handle-ptr> ( object -- void* )
+ <alien-handle> <alien> ; inline
+: alien-handle-ptr> ( void* -- object )
+ alien-address alien-handle> ; inline
+
+: alien-handle-ptr? ( alien -- ? )
+ alien-address alien-handle? ; inline
+
+: release-alien-handle-ptr ( alien -- )
+ alien-address release-alien-handle ; inline
+
+DESTRUCTOR: release-alien-handle-ptr
+
--- /dev/null
+Generate integer handle values to allow Factor object references to be passed through the FFI
! (c)2009 Joe Groff bsd license
-USING: accessors alien audio classes.struct fry calendar alarms
+USING: accessors alien audio classes.struct fry calendar timers
combinators combinators.short-circuit destructors generalizations
kernel literals locals math openal sequences
sequences.generalizations specialized-arrays strings ;
listener
{ next-source integer }
clips
- update-alarm ;
+ update-timer ;
TUPLE: audio-clip < disposable
{ audio-engine audio-engine }
: start-audio ( audio-engine -- )
dup start-audio*
- dup '[ _ update-audio ] 20 milliseconds every >>update-alarm
+ dup '[ _ update-audio ] 20 milliseconds every >>update-timer
drop ;
: stop-audio ( audio-engine -- )
dup al-sources>> [
{
[ make-engine-current ]
- [ update-alarm>> [ stop-alarm ] when* ]
+ [ update-timer>> [ stop-timer ] when* ]
[ clips>> clone [ dispose ] each ]
[ al-sources>> free-sources ]
[
f >>al-sources
f >>clips
- f >>update-alarm
+ f >>update-timer
drop
]
[ al-context>> alcSuspendContext ]
! (c)2009 Joe Groff bsd license
-USING: accessors alarms audio audio.engine audio.loader calendar
+USING: accessors timers audio audio.engine audio.loader calendar
destructors io kernel locals math math.functions math.ranges specialized-arrays
sequences random math.vectors ;
FROM: alien.c-types => short ;
] when
engine update-audio
- ] 20 milliseconds every :> alarm
+ ] 20 milliseconds every :> timer
"Press Enter to stop the test." print
readln drop
- alarm stop-alarm
+ timer stop-timer
engine dispose ;
MAIN: audio-engine-test
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types classes.struct kernel memory
+system vm ;
+IN: benchmark.struct
+
+STRUCT: benchmark-data
+ { time ulonglong }
+ { data-room data-heap-room }
+ { code-room mark-sweep-sizes } ;
+
+STRUCT: benchmark-data-pair
+ { start benchmark-data }
+ { stop benchmark-data } ;
+
+: <benchmark-data> ( -- benchmark-data )
+ \ benchmark-data <struct>
+ nano-count >>time
+ code-room >>code-room
+ data-room >>data-room ; inline
+
+: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
+ \ benchmark-data-pair <struct>
+ swap >>stop
+ swap >>start ; inline
+
+: with-benchmarking ( ... quot -- ... benchmark-data-pair )
+ <benchmark-data>
+ [ call ] dip
+ <benchmark-data> <benchmark-data-pair> ; inline
+
-USING: bson.reader bson.writer byte-arrays io.encodings.binary
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests
: turnaround ( value -- value )
- assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+ assoc>bv >byte-array binary [ H{ } clone stream>assoc ] with-byte-reader ;
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
[ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
+
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } }
]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader ;
IN: bson
-USING: accessors constructors kernel strings uuid ;
-
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators
+combinators.short-circuit constructors kernel linked-assocs
+math math.bitwise random strings uuid ;
IN: bson.constants
: <objid> ( -- objid )
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
-TUPLE: objref ns objid ;
+: <oid> ( -- oid )
+ oid new
+ now timestamp>micros >>a
+ 8 random-bits 16 shift HEX: FF0000 mask
+ 16 random-bits HEX: FFFF mask
+ bitor >>b ;
+
+TUPLE: dbref ref id db ;
+
+TUPLE: mongo-timestamp incr seconds ;
+
+: <mongo-timestamp> ( incr seconds -- mongo-timestamp )
+ mongo-timestamp boa ;
+
+TUPLE: mongo-scoped-code code object ;
+
+: <mongo-scoped-code> ( code object -- mongo-scoped-code )
+ mongo-scoped-code boa ;
+
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
+
+: dbref>assoc ( dbref -- assoc )
+ [ <linked-hash> ] dip over
+ {
+ [ [ ref>> "$ref" ] [ set-at ] bi* ]
+ [ [ id>> "$id" ] [ set-at ] bi* ]
+ [ over db>> [
+ [ db>> "$db" ] [ set-at ] bi*
+ ] [ 2drop ] if ]
+ } 2cleave ; inline
+
+: assoc>dbref ( assoc -- dbref )
+ [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
+ dbref boa ; inline
-CONSTRUCTOR: objref ( ns objid -- objref ) ;
+: dbref-assoc? ( assoc -- ? )
+ { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
TUPLE: mdbregexp { regexp string } { options string } ;
CONSTANT: MDB_OID_FIELD "_id"
CONSTANT: MDB_META_FIELD "_mfd"
-CONSTANT: T_EOO 0
-CONSTANT: T_Double 1
-CONSTANT: T_Integer 16
-CONSTANT: T_Boolean 8
-CONSTANT: T_String 2
-CONSTANT: T_Object 3
-CONSTANT: T_Array 4
-CONSTANT: T_Binary 5
-CONSTANT: T_Undefined 6
-CONSTANT: T_OID 7
-CONSTANT: T_Date 9
-CONSTANT: T_NULL 10
-CONSTANT: T_Regexp 11
-CONSTANT: T_DBRef 12
-CONSTANT: T_Code 13
-CONSTANT: T_ScopedCode 17
-CONSTANT: T_Symbol 14
-CONSTANT: T_JSTypeMax 16
-CONSTANT: T_MaxKey 127
-
-CONSTANT: T_Binary_Function 1
-CONSTANT: T_Binary_Bytes 2
-CONSTANT: T_Binary_UUID 3
-CONSTANT: T_Binary_MD5 5
-CONSTANT: T_Binary_Custom 128
+CONSTANT: T_EOO 0
+CONSTANT: T_Double HEX: 1
+CONSTANT: T_String HEX: 2
+CONSTANT: T_Object HEX: 3
+CONSTANT: T_Array HEX: 4
+CONSTANT: T_Binary HEX: 5
+CONSTANT: T_Undefined HEX: 6
+CONSTANT: T_OID HEX: 7
+CONSTANT: T_Boolean HEX: 8
+CONSTANT: T_Date HEX: 9
+CONSTANT: T_NULL HEX: A
+CONSTANT: T_Regexp HEX: B
+CONSTANT: T_DBRef HEX: C
+CONSTANT: T_Code HEX: D
+CONSTANT: T_Symbol HEX: E
+CONSTANT: T_ScopedCode HEX: F
+CONSTANT: T_Integer HEX: 10
+CONSTANT: T_Timestamp HEX: 11
+CONSTANT: T_Integer64 HEX: 12
+CONSTANT: T_MinKey HEX: FF
+CONSTANT: T_MaxKey HEX: 7F
+CONSTANT: T_Binary_Function HEX: 1
+CONSTANT: T_Binary_Bytes HEX: 2
+CONSTANT: T_Binary_UUID HEX: 3
+CONSTANT: T_Binary_MD5 HEX: 5
+CONSTANT: T_Binary_Custom HEX: 80
-USING: accessors assocs bson.constants calendar fry io io.binary
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize locals ;
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants calendar combinators
+combinators.short-circuit io io.binary kernel math locals
+namespaces sequences serialize strings vectors byte-arrays ;
-FROM: kernel.private => declare ;
-FROM: io.encodings.private => (read-until) ;
+FROM: io.encodings.binary => binary ;
+FROM: io.streams.byte-array => with-byte-reader ;
+FROM: typed => TYPED: ;
IN: bson.reader
+SYMBOL: state
+
+DEFER: stream>assoc
+
<PRIVATE
-TUPLE: element { type integer } name ;
-TUPLE: state
- { size initial: -1 } exemplar
- result scope element ;
-
-: <state> ( exemplar -- state )
- [ state new ] dip
- [ clone >>exemplar ] keep
- clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
- V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
-
-PREDICATE: bson-not-eoo < integer T_EOO > ;
-PREDICATE: bson-eoo < integer T_EOO = ;
-
-PREDICATE: bson-string < integer T_String = ;
-PREDICATE: bson-object < integer T_Object = ;
-PREDICATE: bson-oid < integer T_OID = ;
-PREDICATE: bson-array < integer T_Array = ;
-PREDICATE: bson-integer < integer T_Integer = ;
-PREDICATE: bson-double < integer T_Double = ;
-PREDICATE: bson-date < integer T_Date = ;
-PREDICATE: bson-binary < integer T_Binary = ;
-PREDICATE: bson-boolean < integer T_Boolean = ;
-PREDICATE: bson-regexp < integer T_Regexp = ;
-PREDICATE: bson-null < integer T_NULL = ;
-PREDICATE: bson-ref < integer T_DBRef = ;
-PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
-PREDICATE: bson-binary-function < integer T_Binary_Function = ;
-PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
-PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
-
-GENERIC: element-read ( type -- cont? )
-GENERIC: element-data-read ( type -- object )
-GENERIC: element-binary-read ( length type -- object )
-
-: get-state ( -- state )
- state get ; inline
+DEFER: read-elements
: read-int32 ( -- int32 )
4 read signed-le> ; inline
read-byte-raw first ; inline
: read-cstring ( -- string )
- "\0" read-until drop "" like ; inline
+ "\0" read-until drop >string ; inline
: read-sized-string ( length -- string )
- read 1 head-slice* "" like ; inline
-
-: read-element-type ( -- type )
- read-byte ; inline
-
-: push-element ( type name -- )
- element boa get-state element>> push ; inline
-
-: pop-element ( -- element )
- get-state element>> pop ; inline
-
-: peek-scope ( -- ht )
- get-state scope>> last ; inline
+ read 1 head-slice* >string ; inline
+
+: read-timestamp ( -- timestamp )
+ 8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
+
+: object-result ( quot -- object )
+ [
+ state get clone
+ [ clear-assoc ] [ ] [ ] tri state
+ ] dip with-variable ; inline
+
+: bson-object-data-read ( -- )
+ read-int32 drop read-elements ; inline recursive
+
+: bson-binary-read ( -- binary )
+ read-int32 read-byte
+ {
+ { T_Binary_Bytes [ read ] }
+ { T_Binary_Custom [ read bytes>object ] }
+ { T_Binary_Function [ read ] }
+ [ drop read >string ]
+ } case ; inline
+
+TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
+ mdbregexp new
+ read-cstring >>regexp read-cstring >>options ; inline
+
+TYPED: bson-oid-read ( -- oid: oid )
+ read-longlong read-int32 oid boa ; inline
+
+: check-object ( assoc -- object )
+ dup dbref-assoc? [ assoc>dbref ] when ; inline
+
+TYPED: element-data-read ( type: integer -- object )
+ {
+ { T_OID [ bson-oid-read ] }
+ { T_String [ read-int32 read-sized-string ] }
+ { T_Integer [ read-int32 ] }
+ { T_Integer64 [ read-longlong ] }
+ { T_Binary [ bson-binary-read ] }
+ { T_Object [ [ bson-object-data-read ] object-result check-object ] }
+ { T_Array [ [ bson-object-data-read ] object-result values ] }
+ { T_Double [ read-double ] }
+ { T_Boolean [ read-byte 1 = ] }
+ { T_Date [ read-longlong millis>timestamp ] }
+ { T_Regexp [ bson-regexp-read ] }
+ { T_Timestamp [ read-timestamp ] }
+ { T_Code [ read-int32 read-sized-string ] }
+ { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
+ { T_NULL [ f ] }
+ } case ; inline recursive
+
+TYPED: (read-object) ( type: integer name: string -- )
+ [ element-data-read ] dip state get set-at ; inline recursive
+
+TYPED: (element-read) ( type: integer -- cont?: boolean )
+ dup T_EOO >
+ [ read-cstring (read-object) t ]
+ [ drop f ] if ; inline recursive
: read-elements ( -- )
- read-element-type
- element-read
+ read-byte (element-read)
[ read-elements ] when ; inline recursive
-GENERIC: fix-result ( assoc type -- result )
-
-M: bson-object fix-result ( assoc type -- result )
- drop ;
-
-M: bson-array fix-result ( assoc type -- result )
- drop values ;
-
-GENERIC: end-element ( type -- )
-
-M: bson-object end-element ( type -- )
- drop ;
-
-M: bson-array end-element ( type -- )
- drop ;
-
-M: object end-element ( type -- )
- pop-element 2drop ;
-
-M:: bson-eoo element-read ( type -- cont? )
- pop-element :> element
- get-state scope>>
- [ pop element type>> fix-result ] [ empty? ] bi
- [ [ get-state ] dip >>result drop f ]
- [ element name>> peek-scope set-at t ] if ;
-
-M:: bson-not-eoo element-read ( type -- cont? )
- peek-scope :> scope
- type read-cstring [ push-element ] 2keep
- [ [ element-data-read ] [ end-element ] bi ]
- [ scope set-at t ] bi* ;
-
-: [scope-changer] ( state -- state quot )
- dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
-
-: (object-data-read) ( type -- object )
- drop
- read-int32 drop
- get-state
- [scope-changer] change-scope
- scope>> last ; inline
-
-M: bson-object element-data-read ( type -- object )
- (object-data-read) ;
-
-M: bson-string element-data-read ( type -- object )
- drop
- read-int32 read-sized-string ;
-
-M: bson-array element-data-read ( type -- object )
- (object-data-read) ;
-
-M: bson-integer element-data-read ( type -- object )
- drop
- read-int32 ;
-
-M: bson-double element-data-read ( type -- double )
- drop
- read-double ;
-
-M: bson-boolean element-data-read ( type -- boolean )
- drop
- read-byte 1 = ;
-
-M: bson-date element-data-read ( type -- timestamp )
- drop
- read-longlong millis>timestamp ;
-
-M: bson-binary element-data-read ( type -- binary )
- drop
- read-int32 read-byte element-binary-read ;
-
-M: bson-regexp element-data-read ( type -- mdbregexp )
- drop mdbregexp new
- read-cstring >>regexp read-cstring >>options ;
-
-M: bson-null element-data-read ( type -- bf )
- drop f ;
-
-M: bson-oid element-data-read ( type -- oid )
- drop
- read-longlong
- read-int32 oid boa ;
-
-M: bson-binary-bytes element-binary-read ( size type -- bytes )
- drop read ;
-
-M: bson-binary-custom element-binary-read ( size type -- quot )
- drop read bytes>object ;
-
PRIVATE>
-USE: tools.continuations
-
: stream>assoc ( exemplar -- assoc )
- <state> dup state
- [ read-int32 >>size read-elements ] with-variable
- result>> ;
+ clone [
+ state [ bson-object-data-read ] with-variable
+ ] keep ;
-BSON reader and writer
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
-! Copyright (C) 2008 Sascha Matzke.
+! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bson.constants byte-arrays byte-vectors
-calendar fry io io.binary io.encodings io.encodings.binary
-io.encodings.utf8 io.streams.byte-array kernel math math.parser
-namespaces quotations sequences sequences.private serialize strings
-words combinators.short-circuit literals ;
-
-FROM: io.encodings.utf8.private => char>utf8 ;
-FROM: kernel.private => declare ;
-
+USING: accessors arrays assocs bson.constants byte-arrays
+calendar combinators.short-circuit fry hashtables io io.binary
+kernel linked-assocs literals math math.parser namespaces byte-vectors
+quotations sequences serialize strings vectors dlists alien.accessors ;
+FROM: words => word? word ;
+FROM: typed => TYPED: ;
+FROM: combinators => cond ;
IN: bson.writer
<PRIVATE
-SYMBOL: shared-buffer
-
-CONSTANT: CHAR-SIZE 1
-CONSTANT: INT32-SIZE 4
-CONSTANT: INT64-SIZE 8
+CONSTANT: INT32-SIZE { 0 1 2 3 }
+CONSTANT: INT64-SIZE { 0 1 2 3 4 5 6 7 }
-: (buffer) ( -- buffer )
- shared-buffer get
- [ BV{ } clone [ shared-buffer set ] keep ] unless*
- { byte-vector } declare ; inline
-
PRIVATE>
-: reset-buffer ( buffer -- )
- 0 >>length drop ; inline
-
-: ensure-buffer ( -- )
- (buffer) drop ; inline
+TYPED: get-output ( -- stream: byte-vector )
+ output-stream get ; inline
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
- [ (buffer) [ reset-buffer ] keep dup ] dip
- with-output-stream* ; inline
-
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
- [ (buffer) [ length ] keep ] dip
+TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
+ [ get-output [ length ] [ ] bi ] dip
call length swap [ - ] keep ; inline
-: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
+: (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
- [ call ] dip (buffer) copy ; inline
+ [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE >le ] (with-length-prefix) ; inline
+: with-length-prefix ( quot: ( .. -- .. ) -- )
+ [ ] (with-length-prefix) ; inline
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
+: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
+ [ 4 - ] (with-length-prefix) ; inline
+
+: (>le) ( x n -- )
+ [ nth-byte write1 ] with each ; inline
<PRIVATE
-GENERIC: bson-type? ( obj -- type )
-GENERIC: bson-write ( obj -- )
+TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline
-M: t bson-type? ( boolean -- type ) drop T_Boolean ;
-M: f bson-type? ( boolean -- type ) drop T_Boolean ;
+TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
-M: string bson-type? ( string -- type ) drop T_String ;
-M: integer bson-type? ( integer -- type ) drop T_Integer ;
-M: assoc bson-type? ( assoc -- type ) drop T_Object ;
-M: real bson-type? ( real -- type ) drop T_Double ;
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+TYPED: write-cstring ( string: string -- )
+ get-output [ length ] [ ] bi copy 0 write1 ; inline
-M: oid bson-type? ( word -- type ) drop T_OID ;
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
-M: word bson-type? ( word -- type ) drop T_Binary ;
-M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
-M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
-
-: write-int32 ( int -- ) INT32-SIZE >le write ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
-: write-longlong ( object -- ) INT64-SIZE >le write ; inline
+: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
-
-M: string bson-write ( obj -- )
- '[ _ write-cstring ] with-length-prefix-excl ;
-M: f bson-write ( f -- )
- drop 0 write1 ;
+TYPED: write-header ( name: string object type: integer -- object )
+ write1 [ write-cstring ] dip ; inline
-M: t bson-write ( t -- )
- drop 1 write1 ;
+DEFER: write-pair
-M: integer bson-write ( num -- )
- write-int32 ;
+TYPED: write-byte-array ( binary: byte-array -- )
+ [ length write-int32 ]
+ [ T_Binary_Bytes write1 write ] bi ; inline
-M: real bson-write ( num -- )
- >float write-double ;
-
-M: timestamp bson-write ( timestamp -- )
- timestamp>millis write-longlong ;
-
-M: byte-array bson-write ( binary -- )
- [ length write-int32 ] keep
- T_Binary_Bytes write1
- write ;
-
-M: oid bson-write ( oid -- )
- [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: mdbregexp bson-write ( regexp -- )
+TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
- [ options>> write-cstring ] bi ;
-
-M: sequence bson-write ( array -- )
- '[ _ [ [ write-type ] dip number>string
- write-cstring bson-write ] each-index
- write-eoo ] with-length-prefix ;
-
-: write-oid ( assoc -- )
- [ MDB_OID_FIELD ] dip at
- [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
-
-: skip-field? ( name -- boolean )
- { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
-
-M: assoc bson-write ( assoc -- )
- '[
- _ [ write-oid ] keep
- [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
- write-eoo
- ] with-length-prefix ;
-
-: (serialize-code) ( code -- )
- object>bytes [ length write-int32 ] keep
- T_Binary_Custom write1
- write ;
+ [ options>> write-cstring ] bi ; inline
-M: quotation bson-write ( quotation -- )
- (serialize-code) ;
-
-M: word bson-write ( word -- )
- (serialize-code) ;
+TYPED: write-sequence ( array: sequence -- )
+ '[
+ _ [ number>string swap write-pair ] each-index
+ write-eoo
+ ] with-length-prefix ; inline recursive
+
+TYPED: write-oid ( oid: oid -- )
+ [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
+
+: write-oid-field ( assoc -- )
+ [ MDB_OID_FIELD dup ] dip at
+ [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
+ [ drop ] if* ; inline
+
+: skip-field? ( name value -- name value boolean )
+ over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
+
+UNION: hashtables hashtable linked-assoc ;
+
+TYPED: write-assoc ( assoc: hashtables -- )
+ '[ _ [ write-oid-field ] [
+ [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ ] bi write-eoo
+ ] with-length-prefix ; inline recursive
+
+UNION: code word quotation ;
+
+TYPED: (serialize-code) ( code: code -- )
+ object>bytes
+ [ length write-int32 ]
+ [ T_Binary_Custom write1 write ] bi ; inline
+
+TYPED: write-string ( string: string -- )
+ '[ _ write-cstring ] with-length-prefix-excl ; inline
+
+TYPED: write-boolean ( bool: boolean -- )
+ [ 1 write1 ] [ 0 write1 ] if ; inline
+
+TYPED: write-pair ( name: string obj -- )
+ {
+ {
+ [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
+ [ T_Object write-header write-assoc ]
+ } {
+ [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
+ [ T_Array write-header write-sequence ]
+ } {
+ [ dup byte-array? ]
+ [ T_Binary write-header write-byte-array ]
+ } {
+ [ dup string? ]
+ [ T_String write-header write-string ]
+ } {
+ [ dup oid? ]
+ [ T_OID write-header write-oid ]
+ } {
+ [ dup integer? ]
+ [ T_Integer write-header write-int32 ]
+ } {
+ [ dup boolean? ]
+ [ T_Boolean write-header write-boolean ]
+ } {
+ [ dup real? ]
+ [ T_Double write-header >float write-double ]
+ } {
+ [ dup timestamp? ]
+ [ T_Date write-header timestamp>millis write-longlong ]
+ } {
+ [ dup mdbregexp? ]
+ [ T_Regexp write-header write-mdbregexp ]
+ } {
+ [ dup quotation? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup word? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup dbref? ]
+ [ T_Object write-header dbref>assoc write-assoc ]
+ } {
+ [ dup f = ]
+ [ T_NULL write-header drop ]
+ }
+ } cond ;
PRIVATE>
-: assoc>bv ( assoc -- byte-vector )
- [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
+ [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
-: assoc>stream ( assoc -- )
- { assoc } declare bson-write ; inline
+TYPED: assoc>stream ( assoc: hashtables -- )
+ write-assoc ; inline
-: mdb-special-value? ( value -- ? )
+TYPED: mdb-special-value? ( value -- ?: boolean )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ; inline
+ [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
--- /dev/null
+Joe Groff
+Doug Coleman
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs calendar calendar.format
+combinators combinators.short-circuit fry io io.backend
+io.directories io.encodings.binary io.encodings.detect
+io.encodings.utf8 io.files io.files.info io.files.types
+io.files.unique io.launcher io.pathnames kernel locals math
+math.parser namespaces sequences sorting strings system
+unicode.categories xml.syntax xml.writer xmode.catalog
+xmode.marker xmode.tokens ;
+IN: codebook
+
+! Usage: "my/source/tree" codebook
+! Writes tree.opf, tree.ncx, and tree.html to a temporary directory
+! Writes tree.mobi to resource:codebooks
+! Requires kindlegen to compile tree.mobi for Kindle
+
+CONSTANT: codebook-style
+ {
+ { COMMENT1 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT2 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT3 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT4 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { DIGIT [ [XML <font color="#333333"><-></font> XML] ] }
+ { FUNCTION [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD1 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD2 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD3 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD4 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { LABEL [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { LITERAL1 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL2 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL3 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL4 [ [XML <font color="#333333"><-></font> XML] ] }
+ { MARKUP [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { OPERATOR [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ [ drop ]
+ }
+
+: first-line ( filename encoding -- line )
+ [ readln ] with-file-reader ;
+
+TUPLE: code-file
+ name encoding mode ;
+
+: include-file-name? ( name -- ? )
+ {
+ [ path-components [ "." head? ] any? not ]
+ [ link-info type>> +regular-file+ = ]
+ } 1&& ;
+
+: code-files ( dir -- files )
+ '[
+ [ include-file-name? ] filter [
+ dup detect-file dup binary?
+ [ f ] [ 2dup dupd first-line find-mode ] if
+ code-file boa
+ ] map [ mode>> ] filter [ name>> ] sort-with
+ ] with-directory-tree-files ;
+
+: html-name-char ( char -- str )
+ {
+ { [ dup alpha? ] [ 1string ] }
+ { [ dup digit? ] [ 1string ] }
+ [ >hex 6 CHAR: 0 pad-head "_" "_" surround ]
+ } cond ;
+
+: file-html-name ( name -- name )
+ [ html-name-char ] { } map-as concat ".html" append ;
+
+: toc-list ( files -- list )
+ [ name>> ] map natural-sort [
+ [ file-html-name ] keep
+ [XML <li><a href=<->><-></a></li> XML]
+ ] map ;
+
+! insert zero-width non-joiner between all characters so words can wrap anywhere
+: zwnj ( string -- s|t|r|i|n|g )
+ [ CHAR: \u00200c "" 2sequence ] { } map-as concat ;
+
+! We wrap every line in <tt> because Kindle tends to forget the font when
+! moving back pages
+: htmlize-tokens ( tokens line# -- html-tokens )
+ swap [
+ [ str>> zwnj ] [ id>> ] bi codebook-style case
+ ] map [XML <tt><font size="-2" color="#666666"><-></font> <-></tt> XML]
+ "\n" 2array ;
+
+: line#>string ( i line#len -- i-string )
+ [ number>string ] [ CHAR: \s pad-head ] bi* ;
+
+:: code>html ( dir file -- page )
+ file name>> :> name
+ "Generating HTML for " write name write "..." print flush
+ dir [ file [ name>> ] [ encoding>> ] bi file-lines ] with-directory :> lines
+ lines length 1 + number>string length :> line#len
+ file mode>> load-mode :> rules
+ f lines [| l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
+ map-index concat nip :> html-lines
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h2><-name-></h2>
+ <pre><-html-lines-></pre>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML> ;
+
+:: code>toc-html ( dir name files -- html )
+ "Generating HTML table of contents" print flush
+
+ now timestamp>rfc822 :> timestamp
+ dir absolute-path :> source
+ dir [
+ files toc-list :> toc
+
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h1><-name-></h1>
+ <font size="-2">Generated from<br/>
+ <b><tt><-source-></tt></b><br/>
+ at <-timestamp-></font><br/>
+ <br/>
+ <ul><-toc-></ul>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML>
+ ] with-directory ;
+
+:: code>ncx ( dir name files -- xml )
+ "Generating NCX table of contents" print flush
+
+ files [| file i |
+ file name>> :> name
+ name file-html-name :> filename
+ i 2 + number>string :> istr
+
+ [XML <navPoint class="book" id=<-filename-> playOrder=<-istr->>
+ <navLabel><text><-name-></text></navLabel>
+ <content src=<-filename-> />
+ </navPoint> XML]
+ ] map-index :> file-nav-points
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
+ <navMap>
+ <navPoint class="book" id="toc" playOrder="1">
+ <navLabel><text>Table of Contents</text></navLabel>
+ <content src="_toc.html" />
+ </navPoint>
+ <-file-nav-points->
+ </navMap>
+ </ncx> XML> ;
+
+:: code>opf ( dir name files -- xml )
+ "Generating OPF manifest" print flush
+ name ".ncx" append :> ncx-name
+
+ files [
+ name>> file-html-name dup
+ [XML <item id=<-> href=<-> media-type="text/html" /> XML]
+ ] map :> html-manifest
+
+ files [ name>> file-html-name [XML <itemref idref=<-> /> XML] ] map :> html-spine
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <package
+ version="2.0"
+ xmlns="http://www.idpf.org/2007/opf"
+ unique-identifier=<-name->>
+ <metadata xmlns:dc="http://purl.org/dc/elements/1.1/">
+ <dc:title><-name-></dc:title>
+ <dc:language>en</dc:language>
+ <meta name="cover" content="my-cover-image" />
+ </metadata>
+ <manifest>
+ <item href="cover.jpg" id="my-cover-image" media-type="image/jpeg" />
+ <item id="html-toc" href="_toc.html" media-type="text/html" />
+ <-html-manifest->
+ <item id="toc" href=<-ncx-name-> media-type="application/x-dtbncx+xml" />
+ </manifest>
+ <spine toc="toc">
+ <itemref idref="html-toc" />
+ <-html-spine->
+ </spine>
+ <guide>
+ <reference type="toc" title="Table of Contents" href="_toc.html" />
+ </guide>
+ </package> XML> ;
+
+: write-dest-file ( xml dest-dir name ext -- )
+ append append-path utf8 [ write-xml ] with-file-writer ;
+
+SYMBOL: kindlegen-path
+kindlegen-path [ "kindlegen" ] initialize
+
+SYMBOL: codebook-output-path
+codebook-output-path [ "resource:codebooks" ] initialize
+
+: kindlegen ( path -- )
+ [ kindlegen-path get "-unicode" ] dip 3array try-process ;
+
+: kindle-path ( directory name extension -- path )
+ [ append-path ] dip append ;
+
+:: codebook ( src-dir -- )
+ codebook-output-path get normalize-path :> dest-dir
+
+ "Generating ebook for " write src-dir write " in " write dest-dir print flush
+
+ dest-dir make-directories
+ [
+ current-temporary-directory get :> temp-dir
+ src-dir file-name :> name
+ src-dir code-files :> files
+
+ src-dir name files code>opf
+ temp-dir name ".opf" write-dest-file
+
+ "vocab:codebook/cover.jpg" temp-dir copy-file-into
+
+ src-dir name files code>ncx
+ temp-dir name ".ncx" write-dest-file
+
+ src-dir name files code>toc-html
+ temp-dir "_toc.html" "" write-dest-file
+
+ files [| file |
+ src-dir file code>html
+ temp-dir file name>> file-html-name "" write-dest-file
+ ] each
+
+ temp-dir name ".opf" kindle-path kindlegen
+ temp-dir name ".mobi" kindle-path dest-dir copy-file-into
+
+ dest-dir name ".mobi" kindle-path :> mobi-path
+
+ "Job's finished: " write mobi-path print flush
+ ] cleanup-unique-working-directory ;
USING: ui ui.gadgets sequences kernel arrays math colors
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
accessors fry ui.gadgets.packs game.input ui.gadgets.labels
-ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
+ui.gadgets.borders timers calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: game.input.demos.joysticks
COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
-TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
+TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ;
: add-gadget-with-border ( parent child -- parent )
{ 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: kill-update-axes ( gadget -- )
COLOR: gray <solid> >>interior
- [ [ stop-alarm ] when* f ] change-alarm
+ [ [ stop-timer ] when* f ] change-timer
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
- dup '[ _ update-axes ] FREQUENCY every >>alarm
+ dup '[ _ update-axes ] FREQUENCY every >>timer
drop ;
M: joystick-demo-gadget ungraft*
- alarm>> [ stop-alarm ] when* ;
+ timer>> [ stop-timer ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
-words arrays assocs math calendar fry alarms ui
+words arrays assocs math calendar fry timers ui
ui.gadgets.borders ui.gestures literals ;
IN: game.input.demos.key-caps
CONSTANT: KEYBOARD-SIZE { 230 65 }
CONSTANT: FREQUENCY $[ 1/30 seconds ]
-TUPLE: key-caps-gadget < gadget keys alarm ;
+TUPLE: key-caps-gadget < gadget keys timer ;
: make-key-gadget ( scancode dim array -- )
[
M: key-caps-gadget graft*
open-game-input
- dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
+ dup '[ _ update-key-caps-state ] FREQUENCY every >>timer
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ stop-alarm ] when*
+ timer>> [ stop-timer ] when*
close-game-input ;
M: key-caps-gadget handle-gesture
{ <game-loop> <game-loop*> } related-words
-HELP: benchmark-frames-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link draw* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-HELP: benchmark-ticks-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words
-
HELP: draw*
{ $values
{ "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
}
{ $description "If an uncaught error is thrown from inside a game loop delegate's " { $link tick* } " or " { $link draw* } ", the game loop will catch the error, stop the game loop, and rethrow an error of this class." } ;
-HELP: reset-loop-benchmark
-{ $values
- { "loop" game-loop }
-}
-{ $description "Resets the benchmark counters on a " { $link game-loop } ". Subsequent calls to " { $link benchmark-frames-per-second } " and " { $link benchmark-ticks-per-second } " will measure their values from the point " { $snippet "reset-loop-benchmark" } " was called." } ;
-
HELP: start-loop
{ $values
{ "loop" game-loop }
start-loop
stop-loop
}
-"The game loop maintains performance counters:"
-{ $subsections
- reset-loop-benchmark
- benchmark-frames-per-second
- benchmark-ticks-per-second
-}
"The game loop catches errors that occur in the delegate's methods during the course of the game loop:"
{ $subsections
game-loop-error
! (c)2009 Joe Groff bsd license
-USING: accessors alarms calendar continuations destructors fry
-kernel math math.order namespaces system ui ui.gadgets.worlds ;
+USING: accessors timers alien.c-types calendar classes.struct
+continuations destructors fry kernel math math.order memory
+namespaces sequences specialized-vectors system
+tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays
+benchmark.struct locals ;
IN: game.loop
TUPLE: game-loop
{ tick-interval-nanos integer read-only }
tick-delegate
draw-delegate
- { last-tick integer }
{ running? boolean }
- { tick-number integer }
- { frame-number integer }
- { benchmark-time integer }
- { benchmark-tick-number integer }
- { benchmark-frame-number integer }
- alarm ;
+ { tick# integer }
+ { frame# integer }
+ tick-timer
+ draw-timer
+ benchmark-data ;
-GENERIC: tick* ( delegate -- )
-GENERIC: draw* ( tick-slice delegate -- )
-
-SYMBOL: game-loop
+STRUCT: game-loop-benchmark
+ { benchmark-data-pair benchmark-data-pair }
+ { tick# ulonglong }
+ { frame# ulonglong } ;
-: since-last-tick ( loop -- nanos )
- last-tick>> nano-count swap - ;
+SPECIALIZED-VECTOR: game-loop-benchmark
-: tick-slice ( loop -- slice )
- [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
+: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
+ \ game-loop-benchmark <struct>
+ swap >>frame#
+ swap >>tick#
+ swap >>benchmark-data-pair ; inline
-CONSTANT: MAX-FRAMES-TO-SKIP 5
+GENERIC: tick* ( delegate -- )
+GENERIC: draw* ( tick-slice delegate -- )
DEFER: stop-loop
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
: fps ( fps -- nanos )
- 1,000,000,000 swap /i ; inline
+ [ 1,000,000,000 ] dip /i ; inline
<PRIVATE
+: record-benchmarking ( benchark-data-pair loop -- )
+ [ tick#>> ]
+ [ frame#>> <game-loop-benchmark> ]
+ [ benchmark-data>> ] tri push ;
+
+: last-tick-percent-offset ( loop -- float )
+ [ draw-timer>> iteration-start-nanos>> nano-count swap - ]
+ [ tick-interval-nanos>> ] bi /f 1.0 min ;
+
: redraw ( loop -- )
- [ 1 + ] change-frame-number
- [ tick-slice ] [ draw-delegate>> ] bi draw* ;
+ [ 1 + ] change-frame#
+ [
+ [ last-tick-percent-offset ] [ draw-delegate>> ] bi
+ [ draw* ] with-benchmarking
+ ] keep record-benchmarking ;
: tick ( loop -- )
- tick-delegate>> tick* ;
+ [
+ [ tick-delegate>> tick* ] with-benchmarking
+ ] keep record-benchmarking ;
: increment-tick ( loop -- )
- [ 1 + ] change-tick-number
- dup tick-interval-nanos>> [ + ] curry change-last-tick
+ [ 1 + ] change-tick#
drop ;
-: ?tick ( loop count -- )
- [ nano-count >>last-tick drop ] [
- over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
- [ 2drop ] if
- ] if-zero ;
+PRIVATE>
-: benchmark-nanos ( loop -- nanos )
- nano-count swap benchmark-time>> - ;
+:: when-running ( loop quot -- )
+ [
+ loop
+ dup running?>> quot [ drop ] if
+ ] [
+ loop game-loop-error
+ ] recover ; inline
-PRIVATE>
+: tick-iteration ( loop -- )
+ [ [ tick ] [ increment-tick ] bi ] when-running ;
-: reset-loop-benchmark ( loop -- loop )
- nano-count >>benchmark-time
- dup tick-number>> >>benchmark-tick-number
- dup frame-number>> >>benchmark-frame-number ;
-
-: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
-: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
-
-: (game-tick) ( loop -- )
- dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
- [ drop ] if ;
-
-: game-tick ( loop -- )
- dup game-loop [
- [ (game-tick) ] [ game-loop-error ] recover
- ] with-variable ;
+: frame-iteration ( loop -- )
+ [ redraw ] when-running ;
: start-loop ( loop -- )
- nano-count >>last-tick
t >>running?
- reset-loop-benchmark
- [
- [ '[ _ game-tick ] f ]
- [ tick-interval-nanos>> nanoseconds ] bi
- <alarm>
- ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
+
+ dup
+ [ '[ _ tick-iteration ] f ]
+ [ tick-interval-nanos>> nanoseconds ] bi <timer> >>tick-timer
+
+ dup '[ _ frame-iteration ] f 1 milliseconds <timer> >>draw-timer
+
+ [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ;
: stop-loop ( loop -- )
f >>running?
- alarm>> stop-alarm ;
+ [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
- nano-count f 0 0 nano-count 0 0 f
+ f 0 0 f f
+ game-loop-benchmark-vector{ } clone
game-loop boa ;
: <game-loop> ( tick-interval-nanos delegate -- loop )
M: game-loop dispose
stop-loop ;
-USE: vocabs.loader
-
{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
! (c)2009 Joe Groff bsd license
-USING: accessors combinators fry game.input game.loop generic kernel math
-parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads
-words audio.engine destructors ;
+USING: accessors audio.engine combinators concurrency.promises
+destructors fry game.input game.loop generic kernel math parser
+sequences threads ui ui.gadgets ui.gadgets.worlds ui.gestures
+words words.constant ;
IN: game.worlds
TUPLE: game-world < world
[ >>game-loop begin-game-world ] keep start-loop ;
M: game-world end-world
- [ [ stop-loop ] when* f ] change-game-loop
+ dup game-loop>> [ stop-loop ] when*
[ end-game-world ]
[ audio-engine>> [ dispose ] when* ]
[ use-game-input?>> [ close-game-input ] when ] tri ;
[ call-next-method ]
} cleave ;
+: start-game ( attributes -- game-world )
+ f swap open-window* ;
+
+: wait-game ( attributes -- game-world )
+ f swap open-window* dup promise>> ?promise drop ;
+
+: define-attributes-word ( word tuple -- )
+ [ name>> "-attributes" append create-in ] dip define-constant ;
+
SYNTAX: GAME:
CREATE
game-attributes parse-main-window-attributes
+ 2dup define-attributes-word
parse-definition
define-main-window ;
--- /dev/null
+Joe Groff\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: byte-arrays byte-arrays.hex io.encodings.8-bit.koi8-r\r
+io.encodings.8-bit.latin1 io.encodings.binary\r
+io.encodings.detect io.encodings.utf16 io.encodings.utf32\r
+io.encodings.utf8 namespaces tools.test ;\r
+IN: io.encodings.detect.tests\r
+\r
+! UTF encodings with BOMs\r
+[ utf16be ] [ HEX{ FEFF 0031 0032 0033 } detect-byte-array ] unit-test\r
+[ utf16le ] [ HEX{ FFFE 3100 3200 3300 } detect-byte-array ] unit-test\r
+[ utf32be ] [ HEX{ 0000FEFF 00000031 00000032 00000033 } detect-byte-array ] unit-test\r
+[ utf32le ] [ HEX{ FFFE0000 31000000 32000000 33000000 } detect-byte-array ] unit-test\r
+[ utf8 ] [ HEX{ EF BB BF 31 32 33 } detect-byte-array ] unit-test\r
+\r
+! XML prolog\r
+[ utf8 ]\r
+[ """<?xml version="1.0"?>""" >byte-array detect-byte-array ]\r
+unit-test\r
+\r
+[ utf8 ]\r
+[ """<?xml version="1.0" encoding="UTF-8"?>""" >byte-array detect-byte-array ]\r
+unit-test\r
+\r
+[ latin1 ]\r
+[ """<?xml version='1.0' encoding='ISO-8859-1'?>""" >byte-array detect-byte-array ]\r
+unit-test\r
+\r
+[ latin1 ]\r
+[ """<?xml version='1.0' encoding="ISO-8859-1" """ >byte-array detect-byte-array ]\r
+unit-test\r
+\r
+! Default to utf8 if decoding succeeds and there are no nulls\r
+[ utf8 ] [ HEX{ } detect-byte-array ] unit-test\r
+[ utf8 ] [ HEX{ 31 32 33 } detect-byte-array ] unit-test\r
+[ utf8 ] [ HEX{ 31 32 C2 A0 33 } detect-byte-array ] unit-test\r
+[ latin1 ] [ HEX{ 31 32 A0 33 } detect-byte-array ] unit-test\r
+[ koi8-r ] [\r
+ koi8-r default-8bit-encoding [\r
+ HEX{ 31 32 A0 33 } detect-byte-array\r
+ ] with-variable\r
+] unit-test\r
+\r
+[ binary ] [ HEX{ 31 32 33 C2 A0 00 } detect-byte-array ] unit-test\r
+[ binary ] [ HEX{ 31 32 33 C2 A0 00 30 } detect-byte-array ] unit-test\r
+\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: accessors byte-arrays byte-arrays.hex combinators\r
+continuations fry io io.encodings io.encodings.8-bit.latin1\r
+io.encodings.ascii io.encodings.binary io.encodings.iana\r
+io.encodings.string io.encodings.utf16 io.encodings.utf32\r
+io.encodings.utf8 io.files io.streams.string kernel literals\r
+math namespaces sequences strings ;\r
+IN: io.encodings.detect\r
+\r
+SYMBOL: default-8bit-encoding\r
+default-8bit-encoding [ latin1 ] initialize\r
+\r
+<PRIVATE\r
+\r
+: prolog-tag ( bytes -- string )\r
+ CHAR: > over index [ 1 + ] [ dup length ] if* head-slice >string ;\r
+\r
+: prolog-encoding ( string -- iana-encoding )\r
+ '[\r
+ _ "encoding=" over start\r
+ 10 + swap [ [ 1 - ] dip nth ] [ index-from ] [ swapd subseq ] 2tri\r
+ ] [ drop "UTF-8" ] recover ;\r
+\r
+: detect-xml-prolog ( bytes -- encoding )\r
+ prolog-tag prolog-encoding name>encoding [ ascii ] unless* ;\r
+\r
+: valid-utf8? ( bytes -- ? )\r
+ utf8 decode 1 head-slice* replacement-char swap member? not ;\r
+\r
+PRIVATE>\r
+\r
+: detect-byte-array ( bytes -- encoding )\r
+ {\r
+ { [ dup HEX{ 0000FEFF } head? ] [ drop utf32be ] }\r
+ { [ dup HEX{ FFFE0000 } head? ] [ drop utf32le ] }\r
+ { [ dup HEX{ FEFF } head? ] [ drop utf16be ] }\r
+ { [ dup HEX{ FFFE } head? ] [ drop utf16le ] }\r
+ { [ dup HEX{ EF BB BF } head? ] [ drop utf8 ] }\r
+ { [ dup $[ "<?xml" >byte-array ] head? ] [ detect-xml-prolog ] }\r
+ { [ 0 over member? ] [ drop binary ] }\r
+ { [ dup empty? ] [ drop utf8 ] }\r
+ { [ dup valid-utf8? ] [ drop utf8 ] }\r
+ [ drop default-8bit-encoding get ]\r
+ } cond ;\r
+\r
+: detect-stream ( stream -- sample encoding )\r
+ 256 swap stream-read dup detect-byte-array ;\r
+\r
+: detect-file ( file -- encoding )\r
+ binary [ input-stream get detect-stream nip ] with-file-reader ;\r
--- /dev/null
+Heuristic auto-detection of text encodings and binary files\r
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.launcher io splitting
-make mason.common mason.updates calendar math alarms
+make mason.common mason.updates calendar math timers
io.encodings.8-bit.latin1 debugger ;
IN: irc.gitbot
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms bit-arrays calendar game.input io
+USING: accessors timers bit-arrays calendar game.input io
io.binary io.encodings.binary io.files kernel literals math
namespaces system threads ;
IN: key-logger
] unless ;
: stop-key-logger ( -- )
- key-logger get-global [ stop-alarm ] when*
+ key-logger get-global [ stop-timer ] when*
f key-logger set-global
close-game-input ;
IN: mason.common.tests
USING: prettyprint mason.common mason.config
-namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
+namespaces calendar tools.test io.files
+io.files.temp io.encodings.utf8 sequences ;
[ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test
] with-scope
] unit-test
-[ "/home/bobby/builds/2008-09-11-12-23" ] [
+[ t ] [
[
"/home/bobby/builds" builds-dir set
T{ timestamp
} datestamp stamp set
build-dir
] with-scope
+ "/home/bobby/builds/2008-09-11-12-23" head?
] unit-test
[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
[ day>> , ]
[ hour>> , ]
[ minute>> , ]
+ [ drop nano-count , ]
} cleave
] { } make [ pad-00 ] map "-" join ;
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.launcher bootstrap.image.download
-mason.common mason.platform ;
+USING: bootstrap.image.download combinators.short-circuit
+io.directories io.launcher kernel mason.common mason.platform ;
IN: mason.updates
+: git-reset-cmd ( -- cmd )
+ {
+ "git"
+ "reset"
+ "--hard"
+ "HEAD"
+ } ;
+
: git-pull-cmd ( -- cmd )
{
"git"
} ;
: updates-available? ( -- ? )
+ ".git/index" delete-file
+ git-reset-cmd short-running-process
git-id
git-pull-cmd short-running-process
git-id
boot-image-name maybe-download-image ;
: new-code-available? ( -- ? )
- updates-available?
- new-image-available?
- or ;
\ No newline at end of file
+ { [ updates-available? ] [ new-image-available? ] } 0|| ;
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
- [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
+ [ execute( -- ) ] each _ execute( quot -- quot ) gc
+ benchmark ] with-result ] each
print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
: run-benchmarks ( -- )
- "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+ "db" "db" get* "host" "127.0.0.1" get* "port" 27017 get* ensure-number <mdb>
[ print-header
! serialization
{ small-doc-prepare medium-doc-prepare
--- /dev/null
+USING: accessors assocs hashtables kernel linked-assocs strings ;
+IN: mongodb.cmd
+
+<PRIVATE
+
+TUPLE: mongodb-cmd
+ { name string }
+ { const? boolean }
+ { admin? boolean }
+ { auth? boolean }
+ { assoc assoc }
+ { norep? boolean } ;
+
+PRIVATE>
+
+CONSTANT: buildinfo-cmd
+ T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
+
+CONSTANT: list-databases-cmd
+ T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
+
+! Options: { "async" t }
+CONSTANT: fsync-cmd
+ T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
+
+! Value: { "clone" from_host }
+CONSTANT: clone-db-cmd
+ T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
+
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
+CONSTANT: copy-db-cmd
+ T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
+
+CONSTANT: shutdown-cmd
+ T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
+
+CONSTANT: reseterror-cmd
+ T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
+
+CONSTANT: getlasterror-cmd
+ T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
+
+CONSTANT: getpreverror-cmd
+ T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
+
+CONSTANT: forceerror-cmd
+ T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
+
+CONSTANT: drop-db-cmd
+ T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
+
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
+CONSTANT: repair-db-cmd
+ T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
+
+! Options: -1 gets the current profile level; 0-2 set the profile level
+CONSTANT: profile-cmd
+ T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
+
+CONSTANT: server-status-cmd
+ T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
+
+CONSTANT: assertinfo-cmd
+ T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
+
+CONSTANT: getoptime-cmd
+ T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
+
+CONSTANT: oplog-cmd
+ T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
+
+! Value: { "deleteIndexes" collection-name }
+! Options: { "index" index_name or "*" }
+CONSTANT: delete-index-cmd
+ T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
+
+! Value: { "create" collection-name }
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
+CONSTANT: create-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
+
+! Value { "drop" collection-name }
+CONSTANT: drop-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
+
+! Value { "count" collection-name }
+! Options: { "query" query-object }
+CONSTANT: count-cmd
+ T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
+
+! Value { "validate" collection-name }
+CONSTANT: validate-cmd
+ T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
+
+! Value { "collstats" collection-name }
+CONSTANT: collstats-cmd
+ T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
+
+! Value: { "distinct" collection-name }
+! Options: { "key" key-name }
+CONSTANT: distinct-cmd
+ T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
+
+! Value: { "filemd5" oid }
+! Options: { "root" bucket-name }
+CONSTANT: filemd5-cmd
+ T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
+
+CONSTANT: getnonce-cmd
+ T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
+
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
+CONSTANT: authenticate-cmd
+ T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
+
+CONSTANT: logout-cmd
+ T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
+
+! Value: { "findandmodify" collection-name }
+! Options: { { "query" selector } { "sort" sort-spec }
+! { "remove" t/f } { "update" modified-object }
+! { "new" t/f } }
+CONSTANT: findandmodify-cmd
+ T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
+
+: make-cmd ( cmd-stub -- cmd-assoc )
+ dup const?>> [ ] [
+ clone [ clone <linked-assoc> ] change-assoc
+ ] if ; inline
+
+: set-cmd-opt ( cmd value key -- cmd )
+ pick assoc>> set-at ; inline
-USING: accessors assocs fry io.encodings.binary io.sockets kernel math
-math.parser mongodb.msg mongodb.operations namespaces destructors
-constructors sequences splitting checksums checksums.md5
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
-arrays hashtables sequences.deep vectors locals ;
-
+USING: accessors arrays assocs byte-vectors checksums
+checksums.md5 constructors destructors fry hashtables
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.sockets io.streams.duplex kernel locals math math.parser
+mongodb.cmd mongodb.msg namespaces sequences
+splitting ;
IN: mongodb.connection
: md5-checksum ( string -- digest )
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
-TUPLE: mdb-connection instance node handle remote local ;
+TUPLE: mdb-connection instance node handle remote local buffer ;
+
+: connection-buffer ( -- buffer )
+ mdb-connection get buffer>> 0 >>length ; inline
+
+USE: mongodb.operations
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: check-ok ( result -- errmsg ? )
[ [ "errmsg" ] dip at ]
- [ [ "ok" ] dip at >integer 1 = ] bi ; inline
+ [ [ "ok" ] dip at ] bi ; inline
: <mdb-db> ( name nodes -- mdb-db )
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
nodes>> f swap at ;
: with-connection ( connection quot -- * )
- [ mdb-connection set ] prepose with-scope ; inline
+ [ mdb-connection ] dip with-variable ; inline
: mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "system.namespaces" "." glue ; inline
-: cmd-collection ( -- ns )
- mdb-instance name>> "$cmd" "." glue ; inline
+: cmd-collection ( cmd -- ns )
+ admin?>> [ "admin" ] [ mdb-instance name>> ] if
+ "$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "." glue ; inline
'[ _ write-message read-message ] with-stream* ;
: send-query-1result ( collection assoc -- result )
- <mdb-query-msg>
- 1 >>return#
- send-query-plain objects>>
- [ f ] [ first ] if-empty ;
+ <mdb-query-msg> -1 >>return# send-query-plain
+ objects>> [ f ] [ first ] if-empty ;
+
+: send-cmd ( cmd -- result )
+ [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
<PRIVATE
: get-nonce ( -- nonce )
- cmd-collection H{ { "getnonce" 1 } } send-query-1result
+ getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ;
: auth? ( mdb -- ? )
[ pwd-digest>> ] bi
3array concat md5-checksum ; inline
-: build-auth-query ( -- query-assoc )
- { "authenticate" 1 }
- "user" mdb-instance username>> 2array
- "nonce" get-nonce 2array
- 3array >hashtable
- [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
- [ set-at ] keep ;
+: build-auth-cmd ( cmd -- cmd )
+ mdb-instance username>> "user" set-cmd-opt
+ get-nonce [ "nonce" set-cmd-opt ] [ ] bi
+ calculate-key-digest "key" set-cmd-opt ; inline
: perform-authentication ( -- )
- cmd-collection build-auth-query send-query-1result
+ authenticate-cmd make-cmd
+ build-auth-cmd send-cmd
check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client>
- [ >>handle ] dip >>local ;
+ [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
-
+
PRIVATE>
:: verify-nodes ( mdb -- )
USING: accessors arrays assocs bson.constants combinators
-combinators.smart constructors destructors formatting fry hashtables
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
-sequences sets splitting strings
-tools.continuations uuid memoize locals ;
-
+combinators.smart constructors destructors fry hashtables io
+io.pools io.sockets kernel linked-assocs locals math
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
+prettyprint prettyprint.custom prettyprint.sections sequences
+sets splitting strings ;
+FROM: ascii => ascii? ;
IN: mongodb.driver
TUPLE: mdb-pool < pool mdb ;
TUPLE: mdb-collection
{ name string }
-{ capped boolean initial: f }
-{ size integer initial: -1 }
-{ max integer initial: -1 } ;
+{ capped boolean }
+{ size integer }
+{ max integer } ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
query>> update-query ;
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
- over cursor>> 0 >
+ over cursor>> 0 >
[ [ update-query ]
[ [ cursor>> ] dip <mdb-cursor> ] 2bi
] [ 2drop f ] if ;
[ make-cursor ] 2tri
swap objects>> ;
-: make-collection-assoc ( collection assoc -- )
- [ [ name>> "create" ] dip set-at ]
- [ [ [ capped>> ] keep ] dip
- '[ _ _
- [ [ drop t "capped" ] dip set-at ]
- [ [ size>> "size" ] dip set-at ]
- [ [ max>> "max" ] dip set-at ] 2tri ] when
- ] 2bi ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
-: with-db ( mdb quot -- * )
+: with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
-
+
+: with-mdb ( mdb quot -- )
+ [ <mdb-pool> ] dip
+ [ mdb-pool swap with-variable ] curry with-disposal ; inline
+
+: with-mdb-connection ( quot -- )
+ [ mdb-pool get ] dip
+ '[ _ with-connection ] with-pooled-connection ; inline
+
: >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
H{ } clone [ set-at ] keep ;
M: string create-collection
<mdb-collection> create-collection ;
-M: mdb-collection create-collection
- [ [ cmd-collection ] dip
- <linked-hash> [ make-collection-assoc ] keep
- <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
- [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+M: mdb-collection create-collection ( collection -- )
+ create-cmd make-cmd over
+ {
+ [ name>> "create" set-cmd-opt ]
+ [ capped>> [ "capped" set-cmd-opt ] when* ]
+ [ max>> [ "max" set-cmd-opt ] when* ]
+ [ size>> [ "size" set-cmd-opt ] when* ]
+ } cleave send-cmd check-ok
+ [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
+ [ throw ] if ;
: load-collection-list ( -- collection-list )
namespaces-collection
<PRIVATE
: ensure-valid-collection-name ( collection -- )
- [ ";$." intersect length 0 > ] keep
- '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+ [
+ [ ";$." intersect length 0 > ] keep
+ '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
+ ] [
+ [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
+ ] bi ; inline
: build-collection-map ( -- assoc )
H{ } clone load-collection-list
dup empty? [ drop f ] [ first ] if ;
: count ( mdb-query-msg -- result )
- [ collection>> "count" H{ } clone [ set-at ] keep ] keep
- query>> [ over [ "query" ] dip set-at ] when*
- [ cmd-collection ] dip <mdb-query-msg> find-one
+ [ count-cmd make-cmd ] dip
+ [ collection>> "count" set-cmd-opt ]
+ [ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error )
- cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
- find-one [ "err" ] dip at ;
+ getlasterror-cmd make-cmd send-cmd
+ [ "err" ] dip at ;
GENERIC: validate. ( collection -- )
M: string validate.
- [ cmd-collection ] dip
- "validate" H{ } clone [ set-at ] keep
- <mdb-query-msg> find-one [ check-ok nip ] keep
+ [ validate-cmd make-cmd ] dip
+ "validate" set-cmd-opt send-cmd
+ [ check-ok nip ] keep
'[ "result" _ at print ] [ ] if ;
M: mdb-collection validate.
<mdb-insert-msg> send-message ;
: ensure-index ( index-spec -- )
- <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+ <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
[ [ key>> "key" ] dip set-at ]
[ index-collection ] dip save ;
: drop-index ( collection name -- )
- H{ } clone
- [ [ "index" ] dip set-at ] keep
- [ [ "deleteIndexes" ] dip set-at ] keep
- [ cmd-collection ] dip <mdb-query-msg>
- find-one drop ;
+ [ delete-index-cmd make-cmd ] 2dip
+ [ "deleteIndexes" set-cmd-opt ]
+ [ "index" set-cmd-opt ] bi* send-cmd drop ;
: <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ;
: update-unsafe ( mdb-update-msg -- )
send-message ;
-
+
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
+ [ findandmodify-cmd make-cmd ] 3dip
+ [ "findandmodify" set-cmd-opt ]
+ [ "query" set-cmd-opt ]
+ [ "update" set-cmd-opt ] tri* ; inline
+
+: run-cmd ( cmd -- result )
+ send-cmd ; inline
+
: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
check-collection drop ;
: drop-collection ( name -- )
- [ cmd-collection ] dip
- "drop" H{ } clone [ set-at ] keep
- <mdb-query-msg> find-one drop ;
+ [ drop-cmd make-cmd ] dip
+ "drop" set-cmd-opt send-cmd drop ;
--- /dev/null
+USING: accessors arrays assocs base64 bson.constants
+byte-arrays byte-vectors calendar combinators
+combinators.short-circuit destructors formatting fry hashtables
+io kernel linked-assocs locals math math.parser mongodb.cmd
+mongodb.connection mongodb.driver mongodb.msg namespaces
+sequences splitting strings ;
+FROM: mongodb.driver => update ;
+IN: mongodb.gridfs
+
+CONSTANT: default-chunk-size 262144
+
+TUPLE: gridfs
+ { bucket string }
+ { files string }
+ { chunks string } ;
+
+
+<PRIVATE
+
+: gridfs> ( -- gridfs )
+ gridfs get ; inline
+
+: files-collection ( -- str ) gridfs> files>> ; inline
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
+
+
+: init-gridfs ( gridfs -- )
+ chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } }
+ <index-spec> ensure-index ; inline
+
+PRIVATE>
+
+: <gridfs> ( bucket -- gridfs )
+ [ ]
+ [ "files" "%s.%s" sprintf ]
+ [ "chunks" "%s.%s" sprintf ] tri
+ gridfs boa [ init-gridfs ] keep ;
+
+: with-gridfs ( gridfs quot -- * )
+ [ gridfs ] dip with-variable ; inline
+
+TUPLE: entry
+ { id oid }
+ { filename string }
+ { content-type string }
+ { length integer }
+ { chunk-size integer }
+ { created timestamp }
+ { aliases array }
+ { metadata hashtable }
+ { md5 string } ;
+
+<PRIVATE
+
+: id>base64 ( id -- str )
+ [ a>> >hex ] [ b>> >hex ] bi
+ 2array "#" join >base64 >string ; inline
+
+: base64>id ( str -- objid )
+ base64> >string "#" split
+ [ first ] [ second ] bi
+ [ hex> ] bi@ oid boa ; inline
+
+PRIVATE>
+
+: <entry> ( name content-type -- entry )
+ entry new
+ swap >>content-type swap >>filename
+ <oid> >>id 0 >>length default-chunk-size >>chunk-size
+ now >>created ; inline
+
+<PRIVATE
+
+TUPLE: chunk
+ { id oid }
+ { fileid oid }
+ { n integer }
+ { data byte-array } ;
+
+: at> ( assoc key -- value/f )
+ swap at ; inline
+
+:: >set-at ( assoc value key -- )
+ value key assoc set-at ; inline
+
+: (update-file) ( entry assoc -- entry )
+ {
+ [ "_id" at> >>id ]
+ [ "filename" at> >>filename ]
+ [ "contentType" at> >>content-type ]
+ [ "length" at> >>length ]
+ [ "chunkSize" at> >>chunk-size ]
+ [ "uploadDate" at> >>created ]
+ [ "aliases" at> >>aliases ]
+ [ "metadata" at> >>metadata ]
+ [ "md5" at> >>md5 ]
+ } cleave ; inline
+
+: assoc>chunk ( assoc -- chunk )
+ [ chunk new ] dip
+ {
+ [ "_id" at> >>id ]
+ [ "files_id" at> >>fileid ]
+ [ "n" at> >>n ]
+ [ "data" at> >>data ]
+ } cleave ;
+
+: assoc>entry ( assoc -- entry )
+ [ entry new ] dip (update-file) ;
+
+: entry>assoc ( entry -- assoc )
+ [ H{ } clone ] dip
+ {
+ [ id>> "_id" >set-at ]
+ [ filename>> "filename" >set-at ]
+ [ content-type>> "contentType" >set-at ]
+ [ length>> "length" >set-at ]
+ [ chunk-size>> "chunkSize" >set-at ]
+ [ created>> "uploadDate" >set-at ]
+ [ aliases>> "aliases" >set-at ]
+ [ metadata>> "metadata" >set-at ]
+ [ md5>> "md5" >set-at ]
+ [ drop ]
+ } 2cleave ; inline
+
+: create-entry ( entry -- entry )
+ [ [ files-collection ] dip entry>assoc save ] [ ] bi ;
+
+TUPLE: state bytes count ;
+
+: <state> ( -- state )
+ 0 0 state boa ; inline
+
+: get-state ( -- n )
+ state get ; inline
+
+: with-state ( quot -- state )
+ [ <state> state ] dip
+ [ get-state ] compose
+ with-variable ; inline
+
+: update-state ( bytes -- )
+ [ get-state ] dip
+ '[ _ + ] change-bytes
+ [ 1 + ] change-count drop ; inline
+
+:: store-chunk ( chunk entry n -- )
+ entry id>> :> id
+ H{ { "files_id" id }
+ { "n" n } { "data" chunk } }
+ [ chunks-collection ] dip save ; inline
+
+:: write-chunks ( stream entry -- length )
+ entry chunk-size>> :> chunk-size
+ [
+ [
+ chunk-size stream stream-read dup [
+ [ entry get-state count>> store-chunk ]
+ [ length update-state ] bi
+ ] when*
+ ] loop
+ ] with-state bytes>> ;
+
+: (entry-selector) ( entry -- selector )
+ id>> "_id" associate ; inline
+
+:: file-md5 ( id -- md5-str )
+ filemd5-cmd make-cmd
+ id "filemd5" set-cmd-opt
+ gridfs> bucket>> "root" set-cmd-opt
+ send-cmd "md5" at> ; inline
+
+: update-entry ( bytes entry -- entry )
+ [ swap >>length dup id>> file-md5 >>md5 ]
+ [ nip [ (entry-selector) ] [ ] bi
+ [ length>> "length" associate "$set" associate
+ [ files-collection ] 2dip <update> update ]
+ [ md5>> "md5" associate "$set" associate
+ [ files-collection ] 2dip <update> update ] 2bi
+ ] 2bi ;
+
+TUPLE: gridfs-input-stream entry chunk n offset cpos ;
+
+: <gridfs-input-stream> ( entry -- stream )
+ [ gridfs-input-stream new ] dip
+ >>entry 0 >>offset 0 >>cpos -1 >>n ;
+
+PRIVATE>
+
+: write-entry ( input-stream entry -- entry )
+ create-entry [ write-chunks ] keep update-entry ;
+
+: get-entry ( id -- entry )
+ [ files-collection ] dip
+ "_id" associate <query> find-one assoc>entry ;
+
+: open-entry ( entry -- input-stream )
+ <gridfs-input-stream> ;
+
+: entry-contents ( entry -- bytearray )
+ <gridfs-input-stream> stream-contents ;
+
+<PRIVATE
+
+: load-chunk ( stream -- chunk/f )
+ [ entry>> id>> "files_id" associate ]
+ [ n>> "n" associate ] bi assoc-union
+ [ chunks-collection ] dip
+ <query> find-one dup [ assoc>chunk ] when ;
+
+: exhausted? ( stream -- boolean )
+ [ offset>> ] [ entry>> length>> ] bi = ; inline
+
+: fresh? ( stream -- boolean )
+ [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
+
+: data-available ( stream -- int/f )
+ [ cpos>> ] [ chunk>> data>> length ] bi
+ 2dup < [ swap - ] [ 2drop f ] if ; inline
+
+: next-chunk ( stream -- available chunk/f )
+ 0 >>cpos [ 1 + ] change-n
+ [ ] [ load-chunk ] bi >>chunk
+ [ data-available ] [ chunk>> ] bi ; inline
+
+: ?chunk ( stream -- available chunk/f )
+ dup fresh? [ next-chunk ] [
+ dup exhausted? [ drop 0 f ] [
+ dup data-available [ swap chunk>> ] [ next-chunk ] if*
+ ] if
+ ] if ; inline
+
+: set-stream ( n stream -- )
+ swap {
+ [ >>offset drop ]
+ [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
+ [ drop dup load-chunk >>chunk drop ]
+ } 2cleave ; inline
+
+:: advance-stream ( n stream -- )
+ stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
+
+: read-part ( n stream chunk -- seq/f )
+ [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
+ [ drop advance-stream ] 3bi ; inline
+
+:: (stream-read-partial) ( n stream -- seq/f )
+ stream ?chunk :> chunk :> available
+ chunk [
+ n available <
+ [ n ] [ available ] if
+ stream chunk read-part
+ ] [ f ] if ; inline
+
+:: (stream-read) ( n stream acc -- )
+ n stream (stream-read-partial)
+ {
+ { [ dup not ] [ drop ] }
+ { [ dup length n = ] [ acc push-all ] }
+ { [ dup length n < ] [
+ [ acc push-all ] [ length ] bi
+ n swap - stream acc (stream-read) ]
+ }
+ } cond ; inline recursive
+
+PRIVATE>
+
+M: gridfs-input-stream stream-element-type drop +byte+ ;
+
+M: gridfs-input-stream stream-read ( n stream -- seq/f )
+ over <byte-vector> [ (stream-read) ] [ ] bi
+ dup empty? [ drop f ] [ >byte-array ] if ;
+
+M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
+ (stream-read-partial) ;
+
+M: gridfs-input-stream stream-tell ( stream -- n )
+ offset>> ;
+
+M: gridfs-input-stream stream-seek ( n seek-type stream -- )
+ swap seek-absolute =
+ [ set-stream ]
+ [ "seek-type not supported" throw ] if ;
+
+M: gridfs-input-stream dispose drop ;
"USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
- " [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+ " [ \"ageIdx\" [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
" [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
"" }
{ $heading "Highlevel tuple integration" }
CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
TUPLE: mdb-msg
-{ opcode integer }
-{ req-id integer initial: 0 }
-{ resp-id integer initial: 0 }
-{ length integer initial: 0 }
-{ flags integer initial: 0 } ;
+ { opcode integer }
+ { req-id integer initial: 0 }
+ { resp-id integer initial: 0 }
+ { length integer initial: 0 }
+ { flags integer initial: 0 } ;
TUPLE: mdb-query-msg < mdb-msg
-{ collection string }
-{ skip# integer initial: 0 }
-{ return# integer initial: 0 }
-{ query assoc }
-{ returnfields assoc }
-{ orderby assoc }
-explain hint ;
+ { collection string }
+ { skip# integer initial: 0 }
+ { return# integer initial: 0 }
+ { query assoc }
+ { returnfields assoc }
+ { orderby assoc }
+ explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
-{ collection string }
-{ objects sequence } ;
+ { collection string }
+ { objects sequence } ;
TUPLE: mdb-update-msg < mdb-msg
-{ collection string }
-{ upsert? integer initial: 0 }
-{ selector assoc }
-{ object assoc } ;
+ { collection string }
+ { upsert? integer initial: 0 }
+ { selector assoc }
+ { object assoc } ;
TUPLE: mdb-delete-msg < mdb-msg
-{ collection string }
-{ selector assoc } ;
+ { collection string }
+ { selector assoc } ;
TUPLE: mdb-getmore-msg < mdb-msg
-{ collection string }
-{ return# integer initial: 0 }
-{ cursor integer initial: 0 }
-{ query mdb-query-msg } ;
+ { collection string }
+ { return# integer initial: 0 }
+ { cursor integer initial: 0 }
+ { query mdb-query-msg } ;
TUPLE: mdb-killcursors-msg < mdb-msg
-{ cursors# integer initial: 0 }
-{ cursors sequence } ;
+ { cursors# integer initial: 0 }
+ { cursors sequence } ;
TUPLE: mdb-reply-msg < mdb-msg
-{ collection string }
-{ cursor integer initial: 0 }
-{ start# integer initial: 0 }
-{ requested# integer initial: 0 }
-{ returned# integer initial: 0 }
-{ objects sequence } ;
+ { collection string }
+ { cursor integer initial: 0 }
+ { start# integer initial: 0 }
+ { requested# integer initial: 0 }
+ { returned# integer initial: 0 }
+ { objects sequence } ;
CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
USING: accessors assocs bson.reader bson.writer byte-arrays
-byte-vectors combinators formatting fry io io.binary
-io.encodings.private io.encodings.binary io.encodings.string
-io.encodings.utf8 io.encodings.utf8.private io.files kernel
-locals math mongodb.msg namespaces sequences uuid
-bson.writer.private ;
+byte-vectors combinators formatting fry io io.binary io.encodings.private
+io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
+kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
+
+FROM: mongodb.connection => connection-buffer ;
+FROM: alien => byte-length ;
+
IN: mongodb.operations
+M: byte-vector byte-length length ;
+
<PRIVATE
PREDICATE: mdb-reply-op < integer OP_Reply = ;
PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
-PRIVATE>
-
-GENERIC: write-message ( message -- )
-
-<PRIVATE
-
CONSTANT: MSG-HEADER-SIZE 16
SYMBOL: msg-bytes-read
: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
: read-byte ( -- byte ) read-byte-raw first ; inline
-: (read-cstring) ( acc -- )
- [ read-byte ] dip ! b acc
- 2dup push ! b acc
- [ 0 = ] dip ! bool acc
- '[ _ (read-cstring) ] unless ; inline recursive
-
-: read-cstring ( -- string )
- BV{ } clone
- [ (read-cstring) ] keep
- [ zero? ] trim-tail
- >byte-array utf8 decode ; inline
-
-GENERIC: (read-message) ( message opcode -- message )
-
: copy-header ( message msg-stub -- message )
- [ length>> ] keep [ >>length ] dip
- [ req-id>> ] keep [ >>req-id ] dip
- [ resp-id>> ] keep [ >>resp-id ] dip
- [ opcode>> ] keep [ >>opcode ] dip
- flags>> >>flags ;
-
-M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
- drop
+ {
+ [ length>> >>length ]
+ [ req-id>> >>req-id ]
+ [ resp-id>> >>resp-id ]
+ [ opcode>> >>opcode ]
+ [ flags>> >>flags ]
+ } cleave ; inline
+
+: reply-read-message ( msg-stub -- message )
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } stream>assoc ] collector [ times ] dip >>objects ;
+ [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;
+
+: (read-message) ( message opcode -- message )
+ OP_Reply =
+ [ reply-read-message ]
+ [ "unknown message type" throw ] if ; inline
: read-header ( message -- message )
read-int32 >>length
read-int32 >>flags ; inline
: write-header ( message -- )
- [ req-id>> write-int32 ] keep
- [ resp-id>> write-int32 ] keep
- opcode>> write-int32 ; inline
+ [ req-id>> write-int32 ]
+ [ resp-id>> write-int32 ]
+ [ opcode>> write-int32 ] tri ; inline
PRIVATE>
: read-message ( -- message )
- mdb-msg new
- 0 >bytes-read
- read-header
- [ ] [ opcode>> ] bi (read-message) ;
+ [
+ mdb-msg new 0 >bytes-read read-header
+ [ ] [ opcode>> ] bi (read-message)
+ ] with-scope ;
<PRIVATE
-USE: tools.walker
-
-: dump-to-file ( array -- )
- [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
- '[ _ write ] with-file-writer ;
-
-: (write-message) ( message quot -- )
- '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
- ! [ dump-to-file ] keep
- write flush ; inline
+: (write-message) ( message quot -- )
+ [ connection-buffer dup ] 2dip
+ '[
+ [ _ [ write-header ] [ @ ] bi ] with-length-prefix
+ ] with-output-stream* write flush ; inline
:: build-query-object ( query -- selector )
H{ } clone :> selector
- query { [ orderby>> [ "$orderby" selector set-at ] when* ]
- [ explain>> [ "$explain" selector set-at ] when* ]
- [ hint>> [ "$hint" selector set-at ] when* ]
- [ query>> "query" selector set-at ]
- } cleave
- selector ;
+ query {
+ [ orderby>> [ "$orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave selector ; inline
+
+: write-query-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ skip#>> write-int32 ]
+ [ return#>> write-int32 ]
+ [ build-query-object assoc>stream ]
+ [ returnfields>> [ assoc>stream ] when* ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-insert-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ objects>> [ assoc>stream ] each ] tri
+ ] (write-message) ; inline
+
+: write-update-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ upsert?>> write-int32 ]
+ [ selector>> assoc>stream ]
+ [ object>> assoc>stream ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-delete-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ 0 write-int32 selector>> assoc>stream ] tri
+ ] (write-message) ; inline
+
+: write-getmore-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ return#>> write-int32 ]
+ [ cursor>> write-longlong ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-killcursors-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ cursors#>> write-int32 ]
+ [ cursors>> [ write-longlong ] each ] tri
+ ] (write-message) ; inline
PRIVATE>
-M: mdb-query-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ skip#>> write-int32 ] keep
- [ return#>> write-int32 ] keep
- [ build-query-object assoc>stream ] keep
- returnfields>> [ assoc>stream ] when*
- ] (write-message) ;
-
-M: mdb-insert-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- objects>> [ assoc>stream ] each
- ] (write-message) ;
-
-M: mdb-update-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ upsert?>> write-int32 ] keep
- [ selector>> assoc>stream ] keep
- object>> assoc>stream
- ] (write-message) ;
-
-M: mdb-delete-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- 0 write-int32
- selector>> assoc>stream
- ] (write-message) ;
-
-M: mdb-getmore-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ return#>> write-int32 ] keep
- cursor>> write-longlong
- ] (write-message) ;
-
-M: mdb-killcursors-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ cursors#>> write-int32 ] keep
- cursors>> [ write-longlong ] each
- ] (write-message) ;
-
+: write-message ( message -- )
+ {
+ { [ dup mdb-query-msg? ] [ write-query-message ] }
+ { [ dup mdb-insert-msg? ] [ write-insert-message ] }
+ { [ dup mdb-update-msg? ] [ write-update-message ] }
+ { [ dup mdb-delete-msg? ] [ write-delete-message ] }
+ { [ dup mdb-getmore-msg? ] [ write-getmore-message ] }
+ { [ dup mdb-killcursors-msg? ] [ write-killcursors-message ] }
+ } cond ;
swap set-at ; inline
: write-field? ( tuple key value -- ? )
- pick mdb-persistent? [
+ pick mdb-persistent? [
{ [ [ 2drop ] dip not ]
[ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
- [ tuple-collection name>> ] [ id>> ] bi <objref> ;
+ [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' )
<cond-value> {
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
H{ } clone swap [ <mirror> ] keep pick ; inline
-: ensure-mdb-info ( tuple -- tuple )
- dup id>> [ <objid> >>id ] unless ; inline
-
: with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline
GENERIC: tuple>storable ( tuple -- storable )
+: ensure-oid ( tuple -- tuple )
+ dup id>> [ <oid> >>id ] unless ; inline
+
M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
'[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
M: mdb-persistent tuple>assoc ( tuple -- assoc )
- ensure-mdb-info (tuple>assoc) ;
+ ensure-oid (tuple>assoc) ;
M: tuple tuple>assoc ( tuple -- assoc )
(tuple>assoc) ;
: update-tuple ( tuple -- )
[ tuple-collection name>> ]
- [ id-selector ]
+ [ ensure-oid id-selector ]
[ tuple>assoc ] tri
- <update> update ;
+ <update> >upsert update ;
: save-tuple ( tuple -- )
update-tuple ;
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax kernel
-sequences words system combinators opengl.gl ;
+sequences words system combinators opengl.gl alien.destructors ;
IN: opengl.glu
<<
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+DESTRUCTOR: gluDeleteNurbsRenderer
+DESTRUCTOR: gluDeleteQuadric
+DESTRUCTOR: gluDeleteTess
+
+CALLBACK: void GLUtessBeginCallback ( GLenum type ) ;
+CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ;
+CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ;
+CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ;
+CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ;
+CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ;
+CALLBACK: void GLUtessEndCallback ( ) ;
+CALLBACK: void GLUtessEndDataCallback ( void* data ) ;
+CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ;
+CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ;
+CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ;
+
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
! Copyright (C) 2009 Elie Chaftari.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises namespaces kernel pop3 pop3.server
-sequences tools.test accessors ;
+sequences tools.test accessors calendar ;
IN: pop3.tests
FROM: pop3 => count delete ;
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p1" get ?promise >>port
+ "p1" get 5 seconds ?promise-timeout >>port
connect
] unit-test
[ ] [ "username@host.com" >user ] unit-test
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p2" get ?promise >>port
+ "p2" get 5 seconds ?promise-timeout >>port
"username@host.com" >>user
"password" >>pwd
connect
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar combinators
+USING: accessors timers arrays calendar combinators
combinators.smart continuations debugger http.client fry
init io.streams.string kernel locals math math.parser db
namespaces sequences site-watcher.db site-watcher.email ;
] unless ;
: stop-site-watcher ( -- )
- running-site-watcher get [ stop-alarm ] when* ;
+ running-site-watcher get [ stop-timer ] when* ;
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
: sky-gradient ( world -- t )
- game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+ game-loop>> tick#>> SKY-PERIOD mod SKY-PERIOD /f ;
: sky-theta ( world -- theta )
- game-loop>> tick-number>> SKY-SPEED * ;
+ game-loop>> tick#>> SKY-SPEED * ;
M: terrain-world begin-game-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+USING: accessors timers arrays calendar kernel make math math.rectangles
+math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets
+ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
+ui.render ui ;
FROM: tetris.game => level>> ;
IN: tetris
-TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
+TUPLE: tetris-gadget < gadget { tetris tetris } { timer } ;
: <tetris-gadget> ( tetris -- gadget )
tetris-gadget new swap >>tetris ;
[ tetris>> ?update ] [ relayout-1 ] bi ;
M: tetris-gadget graft* ( gadget -- )
- [ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
+ [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
M: tetris-gadget ungraft* ( gadget -- )
- [ stop-alarm f ] change-alarm drop ;
+ [ stop-timer f ] change-timer drop ;
: tetris-window ( -- )
[
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.data calendar calendar.unix classes.struct
+io.files.info.unix.private kernel system time unix unix.time ;
+IN: time.macosx
+
+M: macosx adjust-time-monotonic
+ timestamp>timeval
+ \ timeval <struct>
+ [ adjtime io-error ] keep dup binary-zero? [
+ drop instant
+ ] [
+ timeval>duration since-1970 now time-
+ ] if ;
+
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel system vocabs.loader ;
+IN: time
+
+HOOK: set-time os ( timestamp -- )
+HOOK: adjust-time-monotonic os ( timestamp -- seconds )
+
+os {
+ { [ dup macosx? ] [ drop "time.macosx" require ] }
+ { [ dup windows? ] [ drop "time.windows" require ] }
+ { [ dup unix? ] [ drop "time.unix" require ] }
+ [ drop ]
+} cond
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel math system time unix unix.time ;
+IN: time.unix
+
+M: unix set-time
+ [ unix-1970 time- duration>microseconds >integer make-timeval ]
+ [ timestamp>timezone ] bi
+ settimeofday io-error ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.windows system time windows.errors
+windows.kernel32 kernel classes.struct calendar ;
+IN: time.windows
+
+M: windows set-time
+ >gmt
+ timestamp>SYSTEMTIME SetSystemTime win32-error=0/f ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math math.order
-calendar alarms logging concurrency.combinators namespaces
+calendar timers logging concurrency.combinators namespaces
db.types db.tuples db fry locals hashtables
syndication urls xml.writer validators
html.forms
(ratio constant "ratios")
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
+ (error-form warning "ERROR: ... ; form")
(parsing-word keyword "parsing words")
(postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
+ (,fuel-syntax--alien-function-alias-regex (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-word))
(,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-word)
+ (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-type-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--rename-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-vocabulary-name)
(3 'factor-font-lock-word)
(,fuel-syntax--float-regex . 'factor-font-lock-number)
(,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
+ (,fuel-syntax--error-regex 2 'factor-font-lock-error-form)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--before-definition-regex (1 'factor-font-lock-type-name)
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"\r
"ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"\r
"B" "BEFORE:" "BIN:"\r
- "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
- "DEFER:"\r
- "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"\r
- "f" "FORGET:" "FROM:" "FUNCTION:"\r
+ "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
+ "DEFER:" "DESTRUCTOR:"\r
+ "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:"\r
+ "f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:"\r
"GAME:" "GENERIC#" "GENERIC:"\r
"GLSL-SHADER:" "GLSL-PROGRAM:"\r
"HELP:" "HEX:" "HOOK:"\r
(fuel-syntax--second-word-regex\r
'("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:")))\r
\r
+(defconst fuel-syntax--error-regex\r
+ (fuel-syntax--second-word-regex '("ERROR:")))\r
+\r
(defconst fuel-syntax--tuple-decl-regex\r
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")\r
\r
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")\r
\r
(defconst fuel-syntax--alien-function-regex\r
- "\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<FUNCTION: +\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
+\r
+(defconst fuel-syntax--alien-function-alias-regex\r
+ "\\_<FUNCTION-ALIAS: +\\(\\w+\\)[\n ]+\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
\r
(defconst fuel-syntax--alien-callback-regex\r
- "\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<CALLBACK: +\\(\\w+\\) +\\(\\w+\\)")\r
\r
(defconst fuel-syntax--indent-def-starts '("" ":"\r
"AFTER" "BEFORE"\r
- "ENUM" "COM-INTERFACE" "CONSULT"\r
- "FROM" "FUNCTION:"\r
+ "COM-INTERFACE" "CONSULT"\r
+ "ENUM" "ERROR"\r
+ "FROM" "FUNCTION:" "FUNCTION-ALIAS:"\r
"INTERSECTION:"\r
"M" "M:" "MACRO" "MACRO:"\r
"MEMO" "MEMO:" "METHOD"\r
(defconst fuel-syntax--single-liner-regex\r
(regexp-opt '("ABOUT:"\r
"ALIAS:"\r
- "CONSTANT:" "C:" "C-TYPE:"\r
- "DEFER:"\r
+ "CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:"\r
+ "DEFER:" "DESTRUCTOR:"\r
"FORGET:"\r
- "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" \r
+ "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"\r
"HEX:" "HOOK:"\r
"IN:" "INSTANCE:"\r
"LIBRARY:"\r
(defconst fuel-syntax--typedef-regex\r
"\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
\r
+(defconst fuel-syntax--c-global-regex\r
+ "\\_<C-GLOBAL: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
+\r
+(defconst fuel-syntax--c-type-regex\r
+ "\\_<C-TYPE: +\\(\\w+\\)\\( .*\\)?$")\r
+\r
(defconst fuel-syntax--rename-regex\r
"\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")\r
\r
return x;
}
+inline bool bitmap_p(u8 *bitmap, cell index)
+{
+ cell byte = index >> 3;
+ cell bit = index & 7;
+ return (bitmap[byte] & (1 << bit)) != 0;
+}
+
}
ctx->push(tag<byte_array>(reallot_array(array.untagged(),capacity)));
}
-void growable_byte_array::append_bytes(void *elts, cell len)
+void growable_byte_array::grow_bytes(cell len)
{
- cell new_size = count + len;
- factor_vm *parent = elements.parent;
- if(new_size >= array_capacity(elements.untagged()))
- elements = parent->reallot_array(elements.untagged(),new_size * 2);
-
- memcpy(&elements->data<u8>()[count],elts,len);
-
count += len;
+ if(count >= array_capacity(elements.untagged()))
+ elements = elements.parent->reallot_array(elements.untagged(),count * 2);
+}
+
+void growable_byte_array::append_bytes(void *elts, cell len)
+{
+ cell old_count = count;
+ grow_bytes(len);
+ memcpy(&elements->data<u8>()[old_count],elts,len);
}
void growable_byte_array::append_byte_array(cell byte_array_)
explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { }
+ void grow_bytes(cell len);
void append_bytes(void *elts, cell len);
void append_byte_array(cell elts);
return (stack_frame *)((cell)frame - frame->size);
}
-/* Allocates memory */
+cell factor_vm::frame_offset(stack_frame *frame)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ char *return_address = (char *)FRAME_RETURN_ADDRESS(frame,this);
+ if(return_address)
+ return return_address - entry_point;
+ else
+ return (cell)-1;
+}
+
+void factor_vm::set_frame_offset(stack_frame *frame, cell offset)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ if(offset == (cell)-1)
+ FRAME_RETURN_ADDRESS(frame,this) = NULL;
+ else
+ FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
+}
+
cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
obj = obj.as<word>()->def;
if(obj.type_p(QUOTATION_TYPE))
- {
- char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
- char *quot_entry_point = (char *)frame_code(frame)->entry_point();
-
- return tag_fixnum(quot_code_offset_to_scan(
- obj.value(),(cell)(return_addr - quot_entry_point)));
- }
+ return tag_fixnum(quot_code_offset_to_scan(obj.value(),frame_offset(frame)));
else
return false_object;
}
}
}
-namespace
-{
-
struct stack_frame_accumulator {
factor_vm *parent;
growable_array frames;
}
};
-}
-
void factor_vm::primitive_callstack_to_array()
{
data_root<callstack> callstack(ctx->pop(),this);
jit_compile_quot(quot.value(),true);
stack_frame *inner = innermost_stack_frame(callstack.untagged());
- cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point;
+ cell offset = frame_offset(inner);
inner->entry_point = quot->entry_point;
- FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
+ set_frame_offset(inner,offset);
}
void factor_vm::primitive_callstack_bounds()
- visit_context_code_blocks()
- visit_callback_code_blocks() */
-template<typename Visitor> struct code_block_visitor {
+template<typename Fixup> struct code_block_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit code_block_visitor(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit code_block_visitor(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
code_block *visit_code_block(code_block *compiled);
void visit_object_code_block(object *obj);
void visit_uninitialized_code_blocks();
};
-template<typename Visitor>
-code_block *code_block_visitor<Visitor>::visit_code_block(code_block *compiled)
+template<typename Fixup>
+code_block *code_block_visitor<Fixup>::visit_code_block(code_block *compiled)
{
- return visitor(compiled);
+ return fixup.fixup_code(compiled);
}
-template<typename Visitor>
+template<typename Fixup>
struct call_frame_code_block_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit call_frame_code_block_visitor(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit call_frame_code_block_visitor(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
void operator()(stack_frame *frame)
{
- cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->entry_point;
-
- code_block *new_block = visitor(parent->frame_code(frame));
- frame->entry_point = new_block->entry_point();
-
- FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->entry_point + offset);
+ cell offset = parent->frame_offset(frame);
+ code_block *compiled = fixup.fixup_code(parent->frame_code(frame));
+ frame->entry_point = compiled->entry_point();
+ parent->set_frame_offset(frame,offset);
}
};
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_object_code_block(object *obj)
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_object_code_block(object *obj)
{
switch(obj->type())
{
{
word *w = (word *)obj;
if(w->code)
- w->code = visitor(w->code);
+ w->code = visit_code_block(w->code);
if(w->profiling)
- w->profiling = visitor(w->profiling);
+ w->profiling = visit_code_block(w->profiling);
parent->update_word_entry_point(w);
break;
{
quotation *q = (quotation *)obj;
if(q->code)
- parent->set_quot_entry_point(q,visitor(q->code));
+ parent->set_quot_entry_point(q,visit_code_block(q->code));
break;
}
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)obj;
- call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ call_frame_code_block_visitor<Fixup> call_frame_visitor(parent,fixup);
parent->iterate_callstack_object(stack,call_frame_visitor);
break;
}
}
}
-template<typename Visitor>
+template<typename Fixup>
struct embedded_code_pointers_visitor {
- Visitor visitor;
+ Fixup fixup;
- explicit embedded_code_pointers_visitor(Visitor visitor_) : visitor(visitor_) {}
+ explicit embedded_code_pointers_visitor(Fixup fixup_) : fixup(fixup_) {}
void operator()(instruction_operand op)
{
if(type == RT_ENTRY_POINT
|| type == RT_ENTRY_POINT_PIC
|| type == RT_ENTRY_POINT_PIC_TAIL)
- op.store_code_block(visitor(op.load_code_block()));
+ op.store_code_block(fixup.fixup_code(op.load_code_block()));
}
};
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_embedded_code_pointers(code_block *compiled)
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_embedded_code_pointers(code_block *compiled)
{
if(!parent->code->uninitialized_p(compiled))
{
- embedded_code_pointers_visitor<Visitor> visitor(this->visitor);
- compiled->each_instruction_operand(visitor);
+ embedded_code_pointers_visitor<Fixup> operand_visitor(fixup);
+ compiled->each_instruction_operand(operand_visitor);
}
}
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_context_code_blocks()
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_context_code_blocks()
{
- call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ call_frame_code_block_visitor<Fixup> call_frame_visitor(parent,fixup);
parent->iterate_active_callstacks(call_frame_visitor);
}
-template<typename Visitor>
-void code_block_visitor<Visitor>::visit_uninitialized_code_blocks()
+template<typename Fixup>
+void code_block_visitor<Fixup>::visit_uninitialized_code_blocks()
{
std::map<code_block *, cell> *uninitialized_blocks = &parent->code->uninitialized_blocks;
std::map<code_block *, cell>::const_iterator iter = uninitialized_blocks->begin();
for(; iter != end; iter++)
{
new_uninitialized_blocks.insert(std::make_pair(
- visitor(iter->first),
+ fixup.fixup_code(iter->first),
iter->second));
}
return size;
}
+ template<typename Fixup> cell size(Fixup fixup) const
+ {
+ return size();
+ }
+
void *entry_point() const
{
return (void *)(this + 1);
}
+ /* GC info is stored at the end of the block */
+ gc_info *block_gc_info() const
+ {
+ return (gc_info *)((u8 *)this + size() - sizeof(gc_info));
+ }
+
void flush_icache()
{
factor::flush_icache((cell)this,size());
struct must_start_gc_again {};
-template<typename TargetGeneration, typename Policy> struct data_workhorse {
+template<typename TargetGeneration, typename Policy> struct gc_workhorse : no_fixup {
factor_vm *parent;
TargetGeneration *target;
Policy policy;
+ code_heap *code;
- explicit data_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
+ explicit gc_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
target(target_),
- policy(policy_) {}
+ policy(policy_),
+ code(parent->code) {}
object *resolve_forwarding(object *untagged)
{
return newpointer;
}
- object *operator()(object *obj)
+ object *fixup_data(object *obj)
{
+ parent->check_data_pointer(obj);
+
if(!policy.should_copy_p(obj))
{
policy.visited_object(obj);
return forwarding;
}
}
-};
-template<typename TargetGeneration, typename Policy>
-inline static slot_visitor<data_workhorse<TargetGeneration,Policy> > make_data_visitor(
- factor_vm *parent,
- TargetGeneration *target,
- Policy policy)
-{
- return slot_visitor<data_workhorse<TargetGeneration,Policy> >(parent,
- data_workhorse<TargetGeneration,Policy>(parent,target,policy));
-}
+ code_block *fixup_code(code_block *compiled)
+ {
+ if(!code->marked_p(compiled))
+ {
+ code->set_marked_p(compiled);
+ parent->mark_stack.push_back((cell)compiled + 1);
+ }
+
+ return compiled;
+ }
+};
struct dummy_unmarker {
void operator()(card *ptr) {}
data_heap *data;
code_heap *code;
TargetGeneration *target;
- slot_visitor<data_workhorse<TargetGeneration,Policy> > data_visitor;
+ gc_workhorse<TargetGeneration,Policy> workhorse;
+ slot_visitor<gc_workhorse<TargetGeneration,Policy> > data_visitor;
cell cards_scanned;
cell decks_scanned;
cell code_blocks_scanned;
data(parent_->data),
code(parent_->code),
target(target_),
- data_visitor(make_data_visitor(parent_,target_,policy_)),
+ workhorse(parent,target,policy_),
+ data_visitor(parent,workhorse),
cards_scanned(0),
decks_scanned(0),
code_blocks_scanned(0) {}
namespace factor {
-template<typename Block> struct forwarder {
- mark_bits<Block> *forwarding_map;
+struct compaction_fixup {
+ mark_bits<object> *data_forwarding_map;
+ mark_bits<code_block> *code_forwarding_map;
+ const object **data_finger;
+ const code_block **code_finger;
- explicit forwarder(mark_bits<Block> *forwarding_map_) :
- forwarding_map(forwarding_map_) {}
+ explicit compaction_fixup(
+ mark_bits<object> *data_forwarding_map_,
+ mark_bits<code_block> *code_forwarding_map_,
+ const object **data_finger_,
+ const code_block **code_finger_) :
+ data_forwarding_map(data_forwarding_map_),
+ code_forwarding_map(code_forwarding_map_),
+ data_finger(data_finger_),
+ code_finger(code_finger_) {}
- Block *operator()(Block *block)
+ object *fixup_data(object *obj)
{
- return forwarding_map->forward_block(block);
+ return data_forwarding_map->forward_block(obj);
}
-};
-
-static inline cell tuple_size_with_forwarding(mark_bits<object> *forwarding_map, object *obj)
-{
- /* The tuple layout may or may not have been forwarded already. Tricky. */
- object *layout_obj = (object *)UNTAG(((tuple *)obj)->layout);
- tuple_layout *layout;
- if(layout_obj < obj)
+ code_block *fixup_code(code_block *compiled)
{
- /* It's already been moved up; dereference through forwarding
- map to get the size */
- layout = (tuple_layout *)forwarding_map->forward_block(layout_obj);
+ return code_forwarding_map->forward_block(compiled);
}
- else
+
+ object *translate_data(const object *obj)
{
- /* It hasn't been moved up yet; dereference directly */
- layout = (tuple_layout *)layout_obj;
+ if(obj < *data_finger)
+ return fixup_data((object *)obj);
+ else
+ return (object *)obj;
}
- return tuple_size(layout);
-}
-
-struct compaction_sizer {
- mark_bits<object> *forwarding_map;
+ code_block *translate_code(const code_block *compiled)
+ {
+ if(compiled < *code_finger)
+ return fixup_code((code_block *)compiled);
+ else
+ return (code_block *)compiled;
+ }
- explicit compaction_sizer(mark_bits<object> *forwarding_map_) :
- forwarding_map(forwarding_map_) {}
+ cell size(object *obj)
+ {
+ if(data_forwarding_map->marked_p(obj))
+ return obj->size(*this);
+ else
+ return data_forwarding_map->unmarked_block_size(obj);
+ }
- cell operator()(object *obj)
+ cell size(code_block *compiled)
{
- if(!forwarding_map->marked_p(obj))
- return forwarding_map->unmarked_block_size(obj);
- else if(obj->type() == TUPLE_TYPE)
- return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
+ if(code_forwarding_map->marked_p(compiled))
+ return compiled->size(*this);
else
- return obj->size();
+ return code_forwarding_map->unmarked_block_size(compiled);
}
};
struct object_compaction_updater {
factor_vm *parent;
- mark_bits<code_block> *code_forwarding_map;
- mark_bits<object> *data_forwarding_map;
+ compaction_fixup fixup;
object_start_map *starts;
- explicit object_compaction_updater(factor_vm *parent_,
- mark_bits<object> *data_forwarding_map_,
- mark_bits<code_block> *code_forwarding_map_) :
+ explicit object_compaction_updater(factor_vm *parent_, compaction_fixup fixup_) :
parent(parent_),
- code_forwarding_map(code_forwarding_map_),
- data_forwarding_map(data_forwarding_map_),
+ fixup(fixup_),
starts(&parent->data->tenured->starts) {}
void operator()(object *old_address, object *new_address, cell size)
{
- cell payload_start;
- if(old_address->type() == TUPLE_TYPE)
- payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
- else
- payload_start = old_address->binary_payload_start();
-
- memmove(new_address,old_address,size);
+ slot_visitor<compaction_fixup> slot_forwarder(parent,fixup);
+ slot_forwarder.visit_slots(new_address);
- slot_visitor<forwarder<object> > slot_forwarder(parent,forwarder<object>(data_forwarding_map));
- slot_forwarder.visit_slots(new_address,payload_start);
-
- code_block_visitor<forwarder<code_block> > code_forwarder(parent,forwarder<code_block>(code_forwarding_map));
+ code_block_visitor<compaction_fixup> code_forwarder(parent,fixup);
code_forwarder.visit_object_code_block(new_address);
starts->record_object_start_offset(new_address);
}
};
-template<typename SlotForwarder>
+template<typename Fixup>
struct code_block_compaction_relocation_visitor {
factor_vm *parent;
code_block *old_address;
- slot_visitor<SlotForwarder> slot_forwarder;
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ Fixup fixup;
explicit code_block_compaction_relocation_visitor(factor_vm *parent_,
code_block *old_address_,
- slot_visitor<SlotForwarder> slot_forwarder_,
- code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ Fixup fixup_) :
parent(parent_),
old_address(old_address_),
- slot_forwarder(slot_forwarder_),
- code_forwarder(code_forwarder_) {}
+ fixup(fixup_) {}
void operator()(instruction_operand op)
{
switch(op.rel_type())
{
case RT_LITERAL:
- op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
- break;
+ {
+ cell value = op.load_value(old_offset);
+ if(immediate_p(value))
+ op.store_value(value);
+ else
+ op.store_value(RETAG(fixup.fixup_data(untag<object>(value)),TAG(value)));
+ break;
+ }
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
- op.store_code_block(code_forwarder.visit_code_block(op.load_code_block(old_offset)));
- break;
case RT_HERE:
- op.store_value(op.load_value(old_offset) - (cell)old_address + (cell)op.parent_code_block());
- break;
+ {
+ cell value = op.load_value(old_offset);
+ cell offset = TAG(value);
+ code_block *compiled = (code_block *)UNTAG(value);
+ op.store_value((cell)fixup.fixup_code(compiled) + offset);
+ break;
+ }
case RT_THIS:
case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET:
}
};
-template<typename SlotForwarder>
+template<typename Fixup>
struct code_block_compaction_updater {
factor_vm *parent;
- slot_visitor<SlotForwarder> slot_forwarder;
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ Fixup fixup;
+ slot_visitor<Fixup> data_forwarder;
+ code_block_visitor<Fixup> code_forwarder;
explicit code_block_compaction_updater(factor_vm *parent_,
- slot_visitor<SlotForwarder> slot_forwarder_,
- code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ Fixup fixup_,
+ slot_visitor<Fixup> data_forwarder_,
+ code_block_visitor<Fixup> code_forwarder_) :
parent(parent_),
- slot_forwarder(slot_forwarder_),
+ fixup(fixup_),
+ data_forwarder(data_forwarder_),
code_forwarder(code_forwarder_) {}
void operator()(code_block *old_address, code_block *new_address, cell size)
{
- memmove(new_address,old_address,size);
+ data_forwarder.visit_code_block_objects(new_address);
- slot_forwarder.visit_code_block_objects(new_address);
-
- code_block_compaction_relocation_visitor<SlotForwarder> visitor(parent,old_address,slot_forwarder,code_forwarder);
+ code_block_compaction_relocation_visitor<Fixup> visitor(parent,old_address,fixup);
new_address->each_instruction_operand(visitor);
}
};
data_forwarding_map->compute_forwarding();
code_forwarding_map->compute_forwarding();
- slot_visitor<forwarder<object> > slot_forwarder(this,forwarder<object>(data_forwarding_map));
- code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+ const object *data_finger = tenured->first_block();
+ const code_block *code_finger = code->allocator->first_block();
+
+ compaction_fixup fixup(data_forwarding_map,code_forwarding_map,&data_finger,&code_finger);
+ slot_visitor<compaction_fixup> data_forwarder(this,fixup);
+ code_block_visitor<compaction_fixup> code_forwarder(this,fixup);
code_forwarder.visit_uninitialized_code_blocks();
/* Slide everything in tenured space up, and update data and code heap
pointers inside objects. */
- object_compaction_updater object_updater(this,data_forwarding_map,code_forwarding_map);
- compaction_sizer object_sizer(data_forwarding_map);
- tenured->compact(object_updater,object_sizer);
+ object_compaction_updater object_updater(this,fixup);
+ tenured->compact(object_updater,fixup,&data_finger);
/* Slide everything in the code heap up, and update data and code heap
pointers inside code blocks. */
- code_block_compaction_updater<forwarder<object> > code_block_updater(this,slot_forwarder,code_forwarder);
- standard_sizer<code_block> code_block_sizer;
- code->allocator->compact(code_block_updater,code_block_sizer);
+ code_block_compaction_updater<compaction_fixup> code_block_updater(this,fixup,data_forwarder,code_forwarder);
+ code->allocator->compact(code_block_updater,fixup,&code_finger);
- slot_forwarder.visit_roots();
+ data_forwarder.visit_roots();
if(trace_contexts_p)
{
- slot_forwarder.visit_contexts();
+ data_forwarder.visit_contexts();
code_forwarder.visit_context_code_blocks();
}
current_gc->event->ended_compaction();
}
+struct code_compaction_fixup {
+ mark_bits<code_block> *code_forwarding_map;
+ const code_block **code_finger;
+
+ explicit code_compaction_fixup(mark_bits<code_block> *code_forwarding_map_,
+ const code_block **code_finger_) :
+ code_forwarding_map(code_forwarding_map_),
+ code_finger(code_finger_) {}
+
+ object *fixup_data(object *obj)
+ {
+ return obj;
+ }
+
+ code_block *fixup_code(code_block *compiled)
+ {
+ return code_forwarding_map->forward_block(compiled);
+ }
+
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
+
+ code_block *translate_code(const code_block *compiled)
+ {
+ if(compiled >= *code_finger)
+ return fixup_code((code_block *)compiled);
+ else
+ return (code_block *)compiled;
+ }
+
+ cell size(object *obj)
+ {
+ return obj->size();
+ }
+
+ cell size(code_block *compiled)
+ {
+ if(code_forwarding_map->marked_p(compiled))
+ return compiled->size(*this);
+ else
+ return code_forwarding_map->unmarked_block_size(compiled);
+ }
+};
+
struct object_grow_heap_updater {
- code_block_visitor<forwarder<code_block> > code_forwarder;
+ code_block_visitor<code_compaction_fixup> code_forwarder;
- explicit object_grow_heap_updater(code_block_visitor<forwarder<code_block> > code_forwarder_) :
+ explicit object_grow_heap_updater(code_block_visitor<code_compaction_fixup> code_forwarder_) :
code_forwarder(code_forwarder_) {}
void operator()(object *obj)
}
};
-struct dummy_slot_forwarder {
- object *operator()(object *obj) { return obj; }
-};
-
/* Compact just the code heap, after growing the data heap */
void factor_vm::collect_compact_code_impl(bool trace_contexts_p)
{
mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
code_forwarding_map->compute_forwarding();
- slot_visitor<dummy_slot_forwarder> slot_forwarder(this,dummy_slot_forwarder());
- code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+ const code_block *code_finger = code->allocator->first_block();
+
+ code_compaction_fixup fixup(code_forwarding_map,&code_finger);
+ slot_visitor<code_compaction_fixup> data_forwarder(this,fixup);
+ code_block_visitor<code_compaction_fixup> code_forwarder(this,fixup);
code_forwarder.visit_uninitialized_code_blocks();
code_forwarder.visit_context_code_blocks();
/* Update code heap references in data heap */
- object_grow_heap_updater updater(code_forwarder);
- each_object(updater);
+ object_grow_heap_updater object_updater(code_forwarder);
+ each_object(object_updater);
/* Slide everything in the code heap up, and update code heap
pointers inside code blocks. */
- code_block_compaction_updater<dummy_slot_forwarder> code_block_updater(this,slot_forwarder,code_forwarder);
- standard_sizer<code_block> code_block_sizer;
- code->allocator->compact(code_block_updater,code_block_sizer);
+ code_block_compaction_updater<code_compaction_fixup> code_block_updater(this,fixup,data_forwarder,code_forwarder);
+ code->allocator->compact(code_block_updater,fixup,&code_finger);
update_code_roots_for_compaction();
callbacks->update();
reset_retainstack();
}
+void context::scrub_stacks(gc_info *info, cell index)
+{
+ u8 *bitmap = info->gc_info_bitmap();
+
+ {
+ cell base = info->scrub_d_base(index);
+
+ for(int loc = 0; loc < info->scrub_d_count; loc++)
+ {
+ if(bitmap_p(bitmap,base + loc))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing datastack location " << loc << std::endl;
+#endif
+ *((cell *)datastack - loc) = 0;
+ }
+ }
+ }
+
+ {
+ cell base = info->scrub_r_base(index);
+
+ for(int loc = 0; loc < info->scrub_r_count; loc++)
+ {
+ if(bitmap_p(bitmap,base + loc))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing retainstack location " << loc << std::endl;
+#endif
+ *((cell *)retainstack - loc) = 0;
+ }
+ }
+ }
+}
+
context::~context()
{
delete datastack_seg;
void reset_context_objects();
void reset();
void fix_stacks();
+ void scrub_stacks(gc_info *info, cell index);
cell peek()
{
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
}
-/* Size of the object pointed to by an untagged pointer */
-cell object::size() const
-{
- if(free_p()) return ((free_heap_block *)this)->size();
-
- switch(type())
- {
- case ARRAY_TYPE:
- return align(array_size((array*)this),data_alignment);
- case BIGNUM_TYPE:
- return align(array_size((bignum*)this),data_alignment);
- case BYTE_ARRAY_TYPE:
- return align(array_size((byte_array*)this),data_alignment);
- case STRING_TYPE:
- return align(string_size(string_capacity((string*)this)),data_alignment);
- case TUPLE_TYPE:
- {
- tuple_layout *layout = (tuple_layout *)UNTAG(((tuple *)this)->layout);
- return align(tuple_size(layout),data_alignment);
- }
- case QUOTATION_TYPE:
- return align(sizeof(quotation),data_alignment);
- case WORD_TYPE:
- return align(sizeof(word),data_alignment);
- case FLOAT_TYPE:
- return align(sizeof(boxed_float),data_alignment);
- case DLL_TYPE:
- return align(sizeof(dll),data_alignment);
- case ALIEN_TYPE:
- return align(sizeof(alien),data_alignment);
- case WRAPPER_TYPE:
- return align(sizeof(wrapper),data_alignment);
- case CALLSTACK_TYPE:
- return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
- default:
- critical_error("Invalid header",(cell)this);
- return 0; /* can't happen */
- }
-}
-
-/* The number of cells from the start of the object which should be scanned by
-the GC. Some types have a binary payload at the end (string, word, DLL) which
-we ignore. */
-cell object::binary_payload_start() const
-{
- if(free_p()) return 0;
-
- switch(type())
- {
- /* these objects do not refer to other objects at all */
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- case CALLSTACK_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(word) - sizeof(cell) * 3;
- case ALIEN_TYPE:
- return sizeof(cell) * 3;
- case DLL_TYPE:
- return sizeof(cell) * 2;
- case QUOTATION_TYPE:
- return sizeof(quotation) - sizeof(cell) * 2;
- case STRING_TYPE:
- return sizeof(string);
- /* everything else consists entirely of pointers */
- case ARRAY_TYPE:
- return array_size<array>(array_capacity((array*)this));
- case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)this)->layout));
- case WRAPPER_TYPE:
- return sizeof(wrapper);
- default:
- critical_error("Invalid header",(cell)this);
- return 0; /* can't happen */
- }
-}
-
data_heap_room factor_vm::data_room()
{
data_heap_room room;
if(p->image_path == NULL)
p->image_path = default_image_path();
- srand((unsigned int)system_micros());
+ srand((unsigned int)nano_count());
init_ffi();
init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
init_callbacks(p->callback_size);
--- /dev/null
+namespace factor
+{
+
+template<typename T>
+struct identity {
+ T operator()(T t)
+ {
+ return t;
+ }
+};
+
+struct no_fixup {
+ object *fixup_data(object *obj)
+ {
+ return obj;
+ }
+
+ code_block *fixup_code(code_block *compiled)
+ {
+ return compiled;
+ }
+
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
+
+ code_block *translate_code(const code_block *compiled)
+ {
+ return fixup_code((code_block *)compiled);
+ }
+
+ cell size(object *obj)
+ {
+ return obj->size();
+ }
+
+ cell size(code_block *compiled)
+ {
+ return compiled->size();
+ }
+};
+
+}
cell largest_free_block();
cell free_block_count();
void sweep();
- template<typename Iterator, typename Sizer> void compact(Iterator &iter, Sizer &sizer);
- template<typename Iterator, typename Sizer> void iterate(Iterator &iter, Sizer &sizer);
+ template<typename Iterator, typename Fixup> void compact(Iterator &iter, Fixup fixup, const Block **finger);
+ template<typename Iterator, typename Fixup> void iterate(Iterator &iter, Fixup fixup);
template<typename Iterator> void iterate(Iterator &iter);
};
mark_bits<Block> *state;
char *address;
Iterator &iter;
+ const Block **finger;
- explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_) :
- state(state_), address((char *)address_), iter(iter_) {}
+ explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_, const Block **finger_) :
+ state(state_), address((char *)address_), iter(iter_), finger(finger_) {}
void operator()(Block *block, cell size)
{
if(this->state->marked_p(block))
{
+ *finger = (Block *)((char *)block + size);
+ memmove((Block *)address,block,size);
iter(block,(Block *)address,size);
address += size;
}
/* The forwarding map must be computed first by calling
state.compute_forwarding(). */
template<typename Block>
-template<typename Iterator, typename Sizer>
-void free_list_allocator<Block>::compact(Iterator &iter, Sizer &sizer)
+template<typename Iterator, typename Fixup>
+void free_list_allocator<Block>::compact(Iterator &iter, Fixup fixup, const Block **finger)
{
- heap_compactor<Block,Iterator> compactor(&state,first_block(),iter);
- iterate(compactor,sizer);
+ heap_compactor<Block,Iterator> compactor(&state,first_block(),iter,finger);
+ iterate(compactor,fixup);
/* Now update the free list; there will be a single free block at
the end */
/* During compaction we have to be careful and measure object sizes differently */
template<typename Block>
-template<typename Iterator, typename Sizer>
-void free_list_allocator<Block>::iterate(Iterator &iter, Sizer &sizer)
+template<typename Iterator, typename Fixup>
+void free_list_allocator<Block>::iterate(Iterator &iter, Fixup fixup)
{
Block *scan = first_block();
Block *end = last_block();
while(scan != end)
{
- cell size = sizer(scan);
+ cell size = fixup.size(scan);
Block *next = (Block *)((cell)scan + size);
if(!scan->free_p()) iter(scan,size);
scan = next;
}
}
-template<typename Block> struct standard_sizer {
- cell operator()(Block *block)
- {
- return block->size();
- }
-};
-
template<typename Block>
template<typename Iterator>
void free_list_allocator<Block>::iterate(Iterator &iter)
{
- standard_sizer<Block> sizer;
- iterate(iter,sizer);
+ iterate(iter,no_fixup());
}
}
namespace factor
{
-inline static code_block_visitor<code_workhorse> make_code_visitor(factor_vm *parent)
-{
- return code_block_visitor<code_workhorse>(parent,code_workhorse(parent));
-}
-
full_collector::full_collector(factor_vm *parent_) :
- collector<tenured_space,full_policy>(
- parent_,
- parent_->data->tenured,
- full_policy(parent_)),
- code_visitor(make_code_visitor(parent_)) {}
+ collector<tenured_space,full_policy>(parent_,parent_->data->tenured,full_policy(parent_)),
+ code_visitor(parent,workhorse) {}
void full_collector::trace_code_block(code_block *compiled)
{
}
};
-struct code_workhorse {
- factor_vm *parent;
- code_heap *code;
-
- explicit code_workhorse(factor_vm *parent_) : parent(parent_), code(parent->code) {}
-
- code_block *operator()(code_block *compiled)
- {
- if(!code->marked_p(compiled))
- {
- code->set_marked_p(compiled);
- parent->mark_stack.push_back((cell)compiled + 1);
- }
-
- return compiled;
- }
-};
-
struct full_collector : collector<tenured_space,full_policy> {
- code_block_visitor<code_workhorse> code_visitor;
+ code_block_visitor<gc_workhorse<tenured_space,full_policy> > code_visitor;
explicit full_collector(factor_vm *parent_);
void trace_code_block(code_block *compiled);
current_gc = NULL;
}
+/* primitive_minor_gc() is invoked by inline GC checks, and it needs to fill in
+uninitialized stack locations before actually calling the GC. See the comment
+in compiler.cfg.stacks.uninitialized for details. */
+
+struct call_frame_scrubber {
+ factor_vm *parent;
+ context *ctx;
+
+ explicit call_frame_scrubber(factor_vm *parent_, context *ctx_) :
+ parent(parent_), ctx(ctx_) {}
+
+ void operator()(stack_frame *frame)
+ {
+ cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = parent->frame_code(frame);
+ gc_info *info = compiled->block_gc_info();
+
+ assert(return_address < compiled->size());
+ int index = info->return_address_index(return_address);
+ if(index != -1)
+ ctx->scrub_stacks(info,index);
+ }
+};
+
+void factor_vm::scrub_context(context *ctx)
+{
+ call_frame_scrubber scrubber(this,ctx);
+ iterate_callstack(ctx,scrubber);
+}
+
+void factor_vm::scrub_contexts()
+{
+ std::set<context *>::const_iterator begin = active_contexts.begin();
+ std::set<context *>::const_iterator end = active_contexts.end();
+ while(begin != end)
+ {
+ scrub_context(*begin);
+ begin++;
+ }
+}
+
void factor_vm::primitive_minor_gc()
{
+ scrub_contexts();
+
gc(collect_nursery_op,
0, /* requested size */
true /* trace contexts? */);
true /* trace contexts? */);
}
-void factor_vm::inline_gc(cell gc_roots_)
-{
- cell stack_pointer = (cell)ctx->callstack_top;
-
- if(to_boolean(gc_roots_))
- {
- tagged<array> gc_roots(gc_roots_);
-
- cell capacity = array_capacity(gc_roots.untagged());
- for(cell i = 0; i < capacity; i++)
- {
- cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
- cell *address = (cell *)(spill_slot + stack_pointer);
- data_roots.push_back(data_root_range(address,1));
- }
-
- primitive_minor_gc();
-
- for(cell i = 0; i < capacity; i++)
- data_roots.pop_back();
- }
- else
- primitive_minor_gc();
-}
-
-VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
-{
- parent->inline_gc(gc_roots);
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
-
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+int gc_info::return_address_index(cell return_address)
+{
+ u32 *return_address_array = return_addresses();
+
+ for(int i = 0; i < return_address_count; i++)
+ {
+ if(return_address == return_address_array[i])
+ return i;
+ }
+
+ return -1;
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+struct gc_info {
+ int scrub_d_count;
+ int scrub_r_count;
+ int gc_root_count;
+ int return_address_count;
+
+ cell total_bitmap_size()
+ {
+ return return_address_count * (scrub_d_count + scrub_r_count + gc_root_count);
+ }
+
+ cell total_bitmap_bytes()
+ {
+ return ((total_bitmap_size() + 7) / 8);
+ }
+
+ u32 *return_addresses()
+ {
+ return (u32 *)((u8 *)this - return_address_count * sizeof(u32));
+ }
+
+ u8 *gc_info_bitmap()
+ {
+ return (u8 *)return_addresses() - total_bitmap_bytes();
+ }
+
+ cell scrub_d_base(cell index)
+ {
+ return index * scrub_d_count;
+ }
+
+ cell scrub_r_base(cell index)
+ {
+ return return_address_count * scrub_d_count +
+ index * scrub_r_count;
+ }
+
+ cell spill_slot_base(cell index)
+ {
+ return return_address_count * scrub_d_count
+ + return_address_count * scrub_r_count
+ + index * gc_root_count;
+ }
+
+ int return_address_index(cell return_address);
+};
+
+}
code->allocator->initial_free_list(h->code_size);
}
-struct data_fixupper {
- cell offset;
+struct startup_fixup {
+ cell data_offset;
+ cell code_offset;
- explicit data_fixupper(cell offset_) : offset(offset_) {}
+ explicit startup_fixup(cell data_offset_, cell code_offset_) :
+ data_offset(data_offset_), code_offset(code_offset_) {}
- object *operator()(object *obj)
+ object *fixup_data(object *obj)
{
- return (object *)((char *)obj + offset);
+ return (object *)((cell)obj + data_offset);
}
-};
-
-struct code_fixupper {
- cell offset;
-
- explicit code_fixupper(cell offset_) : offset(offset_) {}
- code_block *operator()(code_block *compiled)
+ code_block *fixup_code(code_block *obj)
{
- return (code_block *)((char *)compiled + offset);
+ return (code_block *)((cell)obj + code_offset);
}
-};
-static inline cell tuple_size_with_fixup(cell offset, object *obj)
-{
- tuple_layout *layout = (tuple_layout *)((char *)UNTAG(((tuple *)obj)->layout) + offset);
- return tuple_size(layout);
-}
+ object *translate_data(const object *obj)
+ {
+ return fixup_data((object *)obj);
+ }
-struct fixup_sizer {
- cell offset;
+ code_block *translate_code(const code_block *compiled)
+ {
+ return fixup_code((code_block *)compiled);
+ }
- explicit fixup_sizer(cell offset_) : offset(offset_) {}
+ cell size(const object *obj)
+ {
+ return obj->size(*this);
+ }
- cell operator()(object *obj)
+ cell size(code_block *compiled)
{
- if(obj->type() == TUPLE_TYPE)
- return align(tuple_size_with_fixup(offset,obj),data_alignment);
- else
- return obj->size();
+ return compiled->size(*this);
}
};
-struct object_fixupper {
+struct start_object_updater {
factor_vm *parent;
- cell data_offset;
- slot_visitor<data_fixupper> data_visitor;
- code_block_visitor<code_fixupper> code_visitor;
+ startup_fixup fixup;
+ slot_visitor<startup_fixup> data_visitor;
+ code_block_visitor<startup_fixup> code_visitor;
- object_fixupper(factor_vm *parent_, cell data_offset_, cell code_offset_) :
+ start_object_updater(factor_vm *parent_, startup_fixup fixup_) :
parent(parent_),
- data_offset(data_offset_),
- data_visitor(slot_visitor<data_fixupper>(parent_,data_fixupper(data_offset_))),
- code_visitor(code_block_visitor<code_fixupper>(parent_,code_fixupper(code_offset_))) {}
+ fixup(fixup_),
+ data_visitor(slot_visitor<startup_fixup>(parent_,fixup_)),
+ code_visitor(code_block_visitor<startup_fixup>(parent_,fixup_)) {}
void operator()(object *obj, cell size)
{
parent->data->tenured->starts.record_object_start_offset(obj);
+ data_visitor.visit_slots(obj);
+
switch(obj->type())
{
case ALIEN_TYPE:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
alien *ptr = (alien *)obj;
}
case DLL_TYPE:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
-
parent->ffi_dlopen((dll *)obj);
break;
}
- case TUPLE_TYPE:
- {
- cell payload_start = tuple_size_with_fixup(data_offset,obj);
- data_visitor.visit_slots(obj,payload_start);
- break;
- }
default:
{
- cell payload_start = obj->binary_payload_start();
- data_visitor.visit_slots(obj,payload_start);
code_visitor.visit_object_code_block(obj);
break;
}
void factor_vm::fixup_data(cell data_offset, cell code_offset)
{
- slot_visitor<data_fixupper> data_workhorse(this,data_fixupper(data_offset));
+ startup_fixup fixup(data_offset,code_offset);
+ slot_visitor<startup_fixup> data_workhorse(this,fixup);
data_workhorse.visit_roots();
- object_fixupper fixupper(this,data_offset,code_offset);
- fixup_sizer sizer(data_offset);
- data->tenured->iterate(fixupper,sizer);
+ start_object_updater updater(this,fixup);
+ data->tenured->iterate(updater,fixup);
}
-struct code_block_fixup_relocation_visitor {
+struct startup_code_block_relocation_visitor {
factor_vm *parent;
- cell code_offset;
- slot_visitor<data_fixupper> data_visitor;
- code_fixupper code_visitor;
+ startup_fixup fixup;
+ slot_visitor<startup_fixup> data_visitor;
- code_block_fixup_relocation_visitor(factor_vm *parent_, cell data_offset_, cell code_offset_) :
+ startup_code_block_relocation_visitor(factor_vm *parent_, startup_fixup fixup_) :
parent(parent_),
- code_offset(code_offset_),
- data_visitor(slot_visitor<data_fixupper>(parent_,data_fixupper(data_offset_))),
- code_visitor(code_fixupper(code_offset_)) {}
+ fixup(fixup_),
+ data_visitor(slot_visitor<startup_fixup>(parent_,fixup_)) {}
void operator()(instruction_operand op)
{
code_block *compiled = op.parent_code_block();
- cell old_offset = op.rel_offset() + (cell)compiled->entry_point() - code_offset;
+ cell old_offset = op.rel_offset() + (cell)compiled->entry_point() - fixup.code_offset;
switch(op.rel_type())
{
case RT_LITERAL:
- op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
- break;
+ {
+ cell value = op.load_value(old_offset);
+ if(immediate_p(value))
+ op.store_value(value);
+ else
+ op.store_value(RETAG(fixup.fixup_data(untag<object>(value)),TAG(value)));
+ break;
+ }
case RT_ENTRY_POINT:
case RT_ENTRY_POINT_PIC:
case RT_ENTRY_POINT_PIC_TAIL:
- op.store_code_block(code_visitor(op.load_code_block(old_offset)));
- break;
case RT_HERE:
- op.store_value(op.load_value(old_offset) + code_offset);
- break;
+ {
+ cell value = op.load_value(old_offset);
+ cell offset = TAG(value);
+ code_block *compiled = (code_block *)UNTAG(value);
+ op.store_value((cell)fixup.fixup_code(compiled) + offset);
+ break;
+ }
case RT_UNTAGGED:
break;
default:
}
};
-struct code_block_fixupper {
+struct startup_code_block_updater {
factor_vm *parent;
- cell data_offset;
- cell code_offset;
+ startup_fixup fixup;
- code_block_fixupper(factor_vm *parent_, cell data_offset_, cell code_offset_) :
- parent(parent_),
- data_offset(data_offset_),
- code_offset(code_offset_) {}
+ startup_code_block_updater(factor_vm *parent_, startup_fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
void operator()(code_block *compiled, cell size)
{
- slot_visitor<data_fixupper> data_visitor(parent,data_fixupper(data_offset));
+ slot_visitor<startup_fixup> data_visitor(parent,fixup);
data_visitor.visit_code_block_objects(compiled);
- code_block_fixup_relocation_visitor code_visitor(parent,data_offset,code_offset);
+ startup_code_block_relocation_visitor code_visitor(parent,fixup);
compiled->each_instruction_operand(code_visitor);
}
};
void factor_vm::fixup_code(cell data_offset, cell code_offset)
{
- code_block_fixupper fixupper(this,data_offset,code_offset);
- code->allocator->iterate(fixupper);
+ startup_fixup fixup(data_offset,code_offset);
+ startup_code_block_updater updater(this,fixup);
+ code->allocator->iterate(updater,fixup);
}
/* Read an image file from disk, only done once during startup */
/* Allocates memory */
code_block *jit::to_code_block()
{
+ /* Emit dummy GC info */
+ code.grow_bytes(alignment_for(code.count + 4,data_alignment));
+ u32 dummy_gc_info = 0;
+ code.append_bytes(&dummy_gc_info,sizeof(u32));
+
code.trim();
relocation.trim();
parameters.trim();
return (a + (b-1)) & ~(b-1);
}
+inline static cell alignment_for(cell a, cell b)
+{
+ return align(a,b) - a;
+}
+
static const cell data_alignment = 16;
#define WORD_SIZE (signed)(sizeof(cell)*8)
cell header;
cell size() const;
+ template<typename Fixup> cell size(Fixup fixup) const;
+
cell binary_payload_start() const;
+ template<typename Fixup> cell binary_payload_start(Fixup fixup) const;
cell *slots() const { return (cell *)this; }
forwarding = NULL;
}
- cell block_line(Block *address)
+ cell block_line(const Block *address)
{
return (((cell)address - start) / data_alignment);
}
return (Block *)(line * data_alignment + start);
}
- std::pair<cell,cell> bitmap_deref(Block *address)
+ std::pair<cell,cell> bitmap_deref(const Block *address)
{
cell line_number = block_line(address);
cell word_index = (line_number / mark_bits_granularity);
return std::make_pair(word_index,word_shift);
}
- bool bitmap_elt(cell *bits, Block *address)
+ bool bitmap_elt(cell *bits, const Block *address)
{
std::pair<cell,cell> position = bitmap_deref(address);
return (bits[position.first] & ((cell)1 << position.second)) != 0;
}
- Block *next_block_after(Block *block)
+ Block *next_block_after(const Block *block)
{
return (Block *)((cell)block + block->size());
}
- void set_bitmap_range(cell *bits, Block *address)
+ void set_bitmap_range(cell *bits, const Block *address)
{
std::pair<cell,cell> start = bitmap_deref(address);
std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
}
}
- bool marked_p(Block *address)
+ bool marked_p(const Block *address)
{
return bitmap_elt(marked,address);
}
- void set_marked_p(Block *address)
+ void set_marked_p(const Block *address)
{
set_bitmap_range(marked,address);
}
/* We have the popcount for every mark_bits_granularity entries; look
up and compute the rest */
- Block *forward_block(Block *original)
+ Block *forward_block(const Block *original)
{
#ifdef FACTOR_DEBUG
assert(marked_p(original));
return new_block;
}
- Block *next_unmarked_block_after(Block *original)
+ Block *next_unmarked_block_after(const Block *original)
{
std::pair<cell,cell> position = bitmap_deref(original);
cell bit_index = position.second;
return (Block *)(this->start + this->size);
}
- Block *next_marked_block_after(Block *original)
+ Block *next_marked_block_after(const Block *original)
{
std::pair<cell,cell> position = bitmap_deref(original);
cell bit_index = position.second;
#include "platform.hpp"
#include "primitives.hpp"
#include "segments.hpp"
+#include "gc_info.hpp"
#include "contexts.hpp"
#include "run.hpp"
#include "objects.hpp"
#include "bitwise_hacks.hpp"
#include "mark_bits.hpp"
#include "free_list.hpp"
+#include "fixup.hpp"
+#include "tuples.hpp"
#include "free_list_allocator.hpp"
#include "write_barrier.hpp"
#include "object_start_map.hpp"
#include "gc.hpp"
#include "debug.hpp"
#include "strings.hpp"
-#include "tuples.hpp"
#include "words.hpp"
#include "float_bits.hpp"
#include "io.hpp"
#include "data_roots.hpp"
#include "code_roots.hpp"
#include "generic_arrays.hpp"
+#include "callstack.hpp"
#include "slot_visitor.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "code_block_visitor.hpp"
#include "compaction.hpp"
#include "full_collector.hpp"
-#include "callstack.hpp"
#include "arrays.hpp"
#include "math.hpp"
#include "byte_arrays.hpp"
ctx->push(allot_cell(object_size(ctx->pop())));
}
-struct slot_become_visitor {
+struct slot_become_fixup : no_fixup {
std::map<object *,object *> *become_map;
- explicit slot_become_visitor(std::map<object *,object *> *become_map_) :
+ explicit slot_become_fixup(std::map<object *,object *> *become_map_) :
become_map(become_map_) {}
- object *operator()(object *old)
+ object *fixup_data(object *old)
{
std::map<object *,object *>::const_iterator iter = become_map->find(old);
if(iter != become_map->end())
};
struct object_become_visitor {
- slot_visitor<slot_become_visitor> *workhorse;
+ slot_visitor<slot_become_fixup> *workhorse;
- explicit object_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ explicit object_become_visitor(slot_visitor<slot_become_fixup> *workhorse_) :
workhorse(workhorse_) {}
void operator()(object *obj)
};
struct code_block_become_visitor {
- slot_visitor<slot_become_visitor> *workhorse;
+ slot_visitor<slot_become_fixup> *workhorse;
- explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ explicit code_block_become_visitor(slot_visitor<slot_become_fixup> *workhorse_) :
workhorse(workhorse_) {}
void operator()(code_block *compiled, cell size)
/* Update all references to old objects to point to new objects */
{
- slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ slot_visitor<slot_become_fixup> workhorse(this,slot_become_fixup(&become_map));
workhorse.visit_roots();
workhorse.visit_contexts();
static void *null_dll;
-u64 system_micros()
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (u64)t.tv_sec * 1000000 + t.tv_usec;
-}
-
void sleep_nanos(u64 nsec)
{
timespec ts;
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
void open_console();
namespace factor
{
-u64 system_micros()
-{
- SYSTEMTIME st;
- FILETIME ft;
- GetSystemTime(&st);
- SystemTimeToFileTime(&st, &ft);
- return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
-}
-
char *strerror(int err)
{
/* strerror() is not defined on WinCE */
#define snprintf _snprintf
#define snwprintf _snwprintf
-u64 system_micros();
void c_to_factor_toplevel(cell quot);
void open_console();
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-u64 system_micros()
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((u64)t.dwLowDateTime | (u64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10;
-}
-
u64 nano_count()
{
static double scale_factor;
inline static void early_init() {}
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
long getpagesize();
_(special_object) \
_(string) \
_(strip_stack_traces) \
- _(system_micros) \
_(tuple) \
_(tuple_boa) \
_(unimplemented) \
exit((int)to_fixnum(ctx->pop()));
}
-void factor_vm::primitive_system_micros()
-{
- ctx->push(from_unsigned_8(system_micros()));
-}
-
void factor_vm::primitive_nano_count()
{
u64 nanos = nano_count();
namespace factor
{
+/* Size of the object pointed to by an untagged pointer */
+template<typename Fixup>
+cell object::size(Fixup fixup) const
+{
+ if(free_p()) return ((free_heap_block *)this)->size();
+
+ switch(type())
+ {
+ case ARRAY_TYPE:
+ return align(array_size((array*)this),data_alignment);
+ case BIGNUM_TYPE:
+ return align(array_size((bignum*)this),data_alignment);
+ case BYTE_ARRAY_TYPE:
+ return align(array_size((byte_array*)this),data_alignment);
+ case STRING_TYPE:
+ return align(string_size(string_capacity((string*)this)),data_alignment);
+ case TUPLE_TYPE:
+ {
+ tuple_layout *layout = (tuple_layout *)fixup.translate_data(untag<object>(((tuple *)this)->layout));
+ return align(tuple_size(layout),data_alignment);
+ }
+ case QUOTATION_TYPE:
+ return align(sizeof(quotation),data_alignment);
+ case WORD_TYPE:
+ return align(sizeof(word),data_alignment);
+ case FLOAT_TYPE:
+ return align(sizeof(boxed_float),data_alignment);
+ case DLL_TYPE:
+ return align(sizeof(dll),data_alignment);
+ case ALIEN_TYPE:
+ return align(sizeof(alien),data_alignment);
+ case WRAPPER_TYPE:
+ return align(sizeof(wrapper),data_alignment);
+ case CALLSTACK_TYPE:
+ return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
+ default:
+ critical_error("Invalid header in size",(cell)this);
+ return 0; /* can't happen */
+ }
+}
+
+inline cell object::size() const
+{
+ return size(no_fixup());
+}
+
+/* The number of cells from the start of the object which should be scanned by
+the GC. Some types have a binary payload at the end (string, word, DLL) which
+we ignore. */
+template<typename Fixup>
+cell object::binary_payload_start(Fixup fixup) const
+{
+ if(free_p()) return 0;
+
+ switch(type())
+ {
+ /* these objects do not refer to other objects at all */
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ case CALLSTACK_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(word) - sizeof(cell) * 3;
+ case ALIEN_TYPE:
+ return sizeof(cell) * 3;
+ case DLL_TYPE:
+ return sizeof(cell) * 2;
+ case QUOTATION_TYPE:
+ return sizeof(quotation) - sizeof(cell) * 2;
+ case STRING_TYPE:
+ return sizeof(string);
+ /* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size<array>(array_capacity((array*)this));
+ case TUPLE_TYPE:
+ {
+ tuple_layout *layout = (tuple_layout *)fixup.translate_data(untag<object>(((tuple *)this)->layout));
+ return tuple_size(layout);
+ }
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ default:
+ critical_error("Invalid header in binary_payload_start",(cell)this);
+ return 0; /* can't happen */
+ }
+}
+
+inline cell object::binary_payload_start() const
+{
+ return binary_payload_start(no_fixup());
+}
+
/* Slot visitors iterate over the slots of an object, applying a functor to
each one that is a non-immediate slot. The pointer is untagged first. The
functor returns a new untagged object pointer. The return value may or may not equal the old one,
- visit_roots()
- visit_contexts() */
-template<typename Visitor> struct slot_visitor {
+template<typename Fixup> struct slot_visitor {
factor_vm *parent;
- Visitor visitor;
+ Fixup fixup;
- explicit slot_visitor<Visitor>(factor_vm *parent_, Visitor visitor_) :
- parent(parent_), visitor(visitor_) {}
+ explicit slot_visitor<Fixup>(factor_vm *parent_, Fixup fixup_) :
+ parent(parent_), fixup(fixup_) {}
cell visit_pointer(cell pointer);
void visit_handle(cell *handle);
void visit_callback_roots();
void visit_literal_table_roots();
void visit_roots();
+ void visit_callstack_object(callstack *stack);
+ void visit_callstack(context *ctx);
void visit_contexts();
void visit_code_block_objects(code_block *compiled);
void visit_embedded_literals(code_block *compiled);
};
-template<typename Visitor>
-cell slot_visitor<Visitor>::visit_pointer(cell pointer)
+template<typename Fixup>
+cell slot_visitor<Fixup>::visit_pointer(cell pointer)
{
if(immediate_p(pointer)) return pointer;
- object *untagged = untag<object>(pointer);
- untagged = visitor(untagged);
+ object *untagged = fixup.fixup_data(untag<object>(pointer));
return RETAG(untagged,TAG(pointer));
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_handle(cell *handle)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_handle(cell *handle)
{
*handle = visit_pointer(*handle);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_object_array(cell *start, cell *end)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_object_array(cell *start, cell *end)
{
while(start < end) visit_handle(start++);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_slots(object *ptr, cell payload_start)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_slots(object *ptr, cell payload_start)
{
cell *slot = (cell *)ptr;
cell *end = (cell *)((cell)ptr + payload_start);
}
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_slots(object *ptr)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_slots(object *obj)
{
- visit_slots(ptr,ptr->binary_payload_start());
+ if(obj->type() == CALLSTACK_TYPE)
+ visit_callstack_object((callstack *)obj);
+ else
+ visit_slots(obj,obj->binary_payload_start(fixup));
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_stack_elements(segment *region, cell *top)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_stack_elements(segment *region, cell *top)
{
visit_object_array((cell *)region->start,top + 1);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_data_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_data_roots()
{
std::vector<data_root_range>::const_iterator iter = parent->data_roots.begin();
std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
visit_object_array(iter->start,iter->start + iter->len);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_bignum_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_bignum_roots()
{
std::vector<cell>::const_iterator iter = parent->bignum_roots.begin();
std::vector<cell>::const_iterator end = parent->bignum_roots.end();
cell *handle = (cell *)(*iter);
if(*handle)
- *handle = (cell)visitor(*(object **)handle);
+ *handle = (cell)fixup.fixup_data(*(object **)handle);
}
}
-template<typename Visitor>
+template<typename Fixup>
struct callback_slot_visitor {
callback_heap *callbacks;
- slot_visitor<Visitor> *visitor;
+ slot_visitor<Fixup> *visitor;
- explicit callback_slot_visitor(callback_heap *callbacks_, slot_visitor<Visitor> *visitor_) :
+ explicit callback_slot_visitor(callback_heap *callbacks_, slot_visitor<Fixup> *visitor_) :
callbacks(callbacks_), visitor(visitor_) {}
void operator()(code_block *stub)
}
};
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_callback_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callback_roots()
{
- callback_slot_visitor<Visitor> callback_visitor(parent->callbacks,this);
+ callback_slot_visitor<Fixup> callback_visitor(parent->callbacks,this);
parent->callbacks->each_callback(callback_visitor);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_literal_table_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_literal_table_roots()
{
std::map<code_block *, cell> *uninitialized_blocks = &parent->code->uninitialized_blocks;
std::map<code_block *, cell>::const_iterator iter = uninitialized_blocks->begin();
parent->code->uninitialized_blocks = new_uninitialized_blocks;
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_roots()
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_roots()
{
visit_handle(&parent->true_object);
visit_handle(&parent->bignum_zero);
visit_object_array(parent->special_objects,parent->special_objects + special_object_count);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_contexts()
+template<typename Fixup>
+struct call_frame_slot_visitor {
+ factor_vm *parent;
+ slot_visitor<Fixup> *visitor;
+
+ explicit call_frame_slot_visitor(factor_vm *parent_, slot_visitor<Fixup> *visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ /*
+ next -> [entry_point]
+ [size]
+ [return address] -- x86 only, backend adds 1 to each spill location
+ [spill area]
+ ...
+ frame -> [entry_point]
+ [size]
+ */
+ void operator()(stack_frame *frame)
+ {
+ cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
+ gc_info *info = compiled->block_gc_info();
+
+ assert(return_address < compiled->size());
+ int index = info->return_address_index(return_address);
+ if(index == -1)
+ return;
+
+#ifdef DEBUG_GC_MAPS
+ std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl;
+#endif
+ u8 *bitmap = info->gc_info_bitmap();
+ cell base = info->spill_slot_base(index);
+ cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
+
+ for(int spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ {
+ if(bitmap_p(bitmap,base + spill_slot))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "visiting spill slot " << spill_slot << std::endl;
+#endif
+ visitor->visit_handle(stack_pointer + spill_slot);
+ }
+ }
+ }
+};
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callstack_object(callstack *stack)
+{
+ call_frame_slot_visitor<Fixup> call_frame_visitor(parent,this);
+ parent->iterate_callstack_object(stack,call_frame_visitor);
+}
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_callstack(context *ctx)
+{
+ call_frame_slot_visitor<Fixup> call_frame_visitor(parent,this);
+ parent->iterate_callstack(ctx,call_frame_visitor);
+}
+
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_contexts()
{
std::set<context *>::const_iterator begin = parent->active_contexts.begin();
std::set<context *>::const_iterator end = parent->active_contexts.end();
visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack);
visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack);
visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
-
+ visit_callstack(ctx);
begin++;
}
}
-template<typename Visitor>
+template<typename Fixup>
struct literal_references_visitor {
- slot_visitor<Visitor> *visitor;
+ slot_visitor<Fixup> *visitor;
- explicit literal_references_visitor(slot_visitor<Visitor> *visitor_) : visitor(visitor_) {}
+ explicit literal_references_visitor(slot_visitor<Fixup> *visitor_) : visitor(visitor_) {}
void operator()(instruction_operand op)
{
}
};
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_code_block_objects(code_block *compiled)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_code_block_objects(code_block *compiled)
{
visit_handle(&compiled->owner);
visit_handle(&compiled->parameters);
visit_handle(&compiled->relocation);
}
-template<typename Visitor>
-void slot_visitor<Visitor>::visit_embedded_literals(code_block *compiled)
+template<typename Fixup>
+void slot_visitor<Fixup>::visit_embedded_literals(code_block *compiled)
{
if(!parent->code->uninitialized_p(compiled))
{
- literal_references_visitor<Visitor> visitor(this);
+ literal_references_visitor<Fixup> visitor(this);
compiled->each_instruction_operand(visitor);
}
}
// run
void primitive_exit();
- void primitive_system_micros();
void primitive_nano_count();
void primitive_sleep();
void primitive_set_slot();
void collect_compact(bool trace_contexts_p);
void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
+ void scrub_context(context *ctx);
+ void scrub_contexts();
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void inline_gc(cell gc_roots);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
object *allot_object(cell type, cell size);
cell frame_executing_quot(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
+ cell frame_offset(stack_frame *frame);
+ void set_frame_offset(stack_frame *frame, cell offset);
void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
void primitive_innermost_stack_frame_executing();
projects / factor.git / commitdiff
