url "checksums.txt" >url derive-url http-get nip
string-lines [ " " split1 ] { } map>assoc ;
+: file-checksum ( image -- checksum )
+ md5 checksum-file hex-string ;
+
+: download-checksum ( image -- checksum )
+ download-checksums at ;
+
: need-new-image? ( image -- ? )
dup exists?
- [
- [ md5 checksum-file hex-string ]
- [ download-checksums at ]
- bi = not
- ] [ drop t ] if ;
+ [ [ file-checksum ] [ download-checksum ] bi = not ]
+ [ drop t ]
+ if ;
: verify-image ( image -- )
need-new-image? [ "Boot image corrupt" throw ] when ;
SPECIAL-OBJECT: c-to-factor-word 42
SPECIAL-OBJECT: lazy-jit-compile-word 43
SPECIAL-OBJECT: unwind-native-frames-word 44
+SPECIAL-OBJECT: fpu-state-word 45
+SPECIAL-OBJECT: set-fpu-state-word 46
SPECIAL-OBJECT: callback-stub 48
\ c-to-factor c-to-factor-word set
\ lazy-jit-compile lazy-jit-compile-word set
\ unwind-native-frames unwind-native-frames-word set
+ \ fpu-state fpu-state-word set
+ \ set-fpu-state set-fpu-state-word set
undefined-def undefined-quot set ;
: emit-special-objects ( -- )
} test-alias-analysis
] unit-test
-! We can't make any assumptions about heap-ac between alien
-! calls, since they might callback into Factor code
+! We can't make any assumptions about heap-ac between
+! instructions which can call back into Factor code
[
V{
T{ ##peek f 0 D 0 }
T{ ##set-slot-imm f 1 0 1 0 }
} test-alias-analysis
] unit-test
+
+! We can't eliminate stores on any alias class across a GC-ing
+! instruction
+[
+ V{
+ T{ ##allot f 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##allot f 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##allot f 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##copy f 2 1 any-rep }
+ }
+] [
+ V{
+ T{ ##allot f 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##allot f 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##allot f 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##allot f 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ }
+] [
+ V{
+ T{ ##allot f 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+! Make sure that gc-map-insns which are also vreg-insns are
+! handled properly
+[
+ V{
+ T{ ##allot f 0 }
+ T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##allot f 0 }
+ T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
M: insn analyze-aliases ;
-M: vreg-insn analyze-aliases
+: def-acs ( insn -- insn' )
! If an instruction defines a value with a non-integer
! representation it means that the value will be boxed
! anywhere its used as a tagged pointer. Boxing allocates
[ set-heap-ac ] [ set-new-ac ] if
] each-def-rep ;
+M: vreg-insn analyze-aliases
+ def-acs ;
+
M: ##phi analyze-aliases
dup dst>> set-heap-ac ;
analyze-aliases
] when ;
+: clear-live-slots ( -- )
+ heap-ac get ac>vregs [ live-slots get at clear-assoc ] each ;
+
+: clear-recent-stores ( -- )
+ recent-stores get values [ clear-assoc ] each ;
+
+M: gc-map-insn analyze-aliases
+ ! Can't use call-next-method here because of a limitation, gah
+ def-acs
+ clear-recent-stores ;
+
+M: factor-call-insn analyze-aliases
+ def-acs
+ clear-recent-stores
+ clear-live-slots ;
+
+GENERIC: eliminate-dead-stores ( insn -- ? )
+
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
+
+M: insn eliminate-dead-stores drop t ;
+
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
-M: factor-call-insn analyze-aliases
- call-next-method
- heap-ac get ac>vregs [
- [ live-slots get at clear-assoc ]
- [ recent-stores get at clear-assoc ] bi
- ] each ;
-
-GENERIC: eliminate-dead-stores ( insn -- ? )
-
-M: ##set-slot-imm eliminate-dead-stores
- insn#>> dead-stores get in? not ;
-
-M: insn eliminate-dead-stores drop t ;
-
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
UNION: memory-insn
##load-memory ##load-memory-imm
##store-memory ##store-memory-imm
+ ##write-barrier ##write-barrier-imm
alien-call-insn
slot-insn ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.representations
compiler.cfg.scheduling compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
-compiler.cfg.stacks.uninitialized ;
+compiler.cfg.write-barrier compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
insert-gc-checks
+ eliminate-write-barriers
dup compute-uninitialized-sets
insert-save-contexts
destruct-ssa
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.copy-prop
-compiler.cfg.dce
-compiler.cfg.write-barrier ;
+compiler.cfg.dce ;
IN: compiler.cfg.optimizer
: optimize-cfg ( cfg -- cfg' )
alias-analysis
value-numbering
copy-propagation
- eliminate-dead-code
- eliminate-write-barriers ;
+ eliminate-dead-code ;
--- /dev/null
+USING: compiler.cfg.instructions compiler.cfg.write-barrier
+tools.test ;
+IN: compiler.cfg.write-barrier.tests
+
+! Do need a write barrier on a random store.
+[
+ V{
+ T{ ##peek f 1 }
+ T{ ##set-slot f 2 1 3 }
+ T{ ##write-barrier f 1 3 }
+ }
+] [
+ V{
+ T{ ##peek f 1 }
+ T{ ##set-slot f 2 1 3 }
+ T{ ##write-barrier f 1 3 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##peek f 1 }
+ T{ ##set-slot-imm f 2 1 }
+ T{ ##write-barrier-imm f 1 }
+ }
+] [
+ V{
+ T{ ##peek f 1 }
+ T{ ##set-slot-imm f 2 1 }
+ T{ ##write-barrier-imm f 1 }
+ } write-barriers-step
+] unit-test
+
+! Don't need a write barrier on freshly allocated objects.
+[
+ V{
+ T{ ##allot f 1 }
+ T{ ##set-slot f 2 1 3 }
+ }
+] [
+ V{
+ T{ ##allot f 1 }
+ T{ ##set-slot f 2 1 3 }
+ T{ ##write-barrier f 1 3 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##allot f 1 }
+ T{ ##set-slot-imm f 2 1 }
+ }
+] [
+ V{
+ T{ ##allot f 1 }
+ T{ ##set-slot-imm f 2 1 }
+ T{ ##write-barrier-imm f 1 }
+ } write-barriers-step
+] unit-test
+
+! Do need a write barrier if there's a subroutine call between
+! the allocation and the store.
+[
+ V{
+ T{ ##allot f 1 }
+ T{ ##box }
+ T{ ##set-slot f 2 1 3 }
+ T{ ##write-barrier f 1 3 }
+ }
+] [
+ V{
+ T{ ##allot f 1 }
+ T{ ##box }
+ T{ ##set-slot f 2 1 3 }
+ T{ ##write-barrier f 1 3 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##allot f 1 }
+ T{ ##box }
+ T{ ##set-slot-imm f 2 1 }
+ T{ ##write-barrier-imm f 1 }
+ }
+] [
+ V{
+ T{ ##allot f 1 }
+ T{ ##box }
+ T{ ##set-slot-imm f 2 1 }
+ T{ ##write-barrier-imm f 1 }
+ } write-barriers-step
+] unit-test
+
+! ##copy instructions
+[
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##set-slot-imm f 3 1 }
+ T{ ##write-barrier-imm f 2 }
+ }
+] [
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##set-slot-imm f 3 1 }
+ T{ ##write-barrier-imm f 2 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##set-slot-imm f 3 2 }
+ T{ ##write-barrier-imm f 1 }
+ }
+] [
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##set-slot-imm f 3 2 }
+ T{ ##write-barrier-imm f 1 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##copy f 3 2 }
+ T{ ##set-slot-imm f 3 1 }
+ T{ ##write-barrier-imm f 2 }
+ }
+] [
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##copy f 3 2 }
+ T{ ##set-slot-imm f 3 1 }
+ T{ ##write-barrier-imm f 2 }
+ } write-barriers-step
+] unit-test
+
+[
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##copy f 3 2 }
+ T{ ##set-slot-imm f 4 1 }
+ T{ ##write-barrier-imm f 3 }
+ }
+] [
+ V{
+ T{ ##copy f 2 1 }
+ T{ ##copy f 3 2 }
+ T{ ##set-slot-imm f 4 1 }
+ T{ ##write-barrier-imm f 3 }
+ } write-barriers-step
+] unit-test
FROM: namespaces => set ;
IN: compiler.cfg.write-barrier
+! This pass must run after GC check insertion and scheduling.
+
SYMBOL: fresh-allocations
SYMBOL: mutated-objects
+SYMBOL: copies
+
+: resolve-copy ( src -- dst )
+ copies get ?at drop ;
+
GENERIC: eliminate-write-barrier ( insn -- ? )
+: fresh-allocation ( vreg -- )
+ fresh-allocations get conjoin ;
+
M: ##allot eliminate-write-barrier
- dst>> fresh-allocations get conjoin t ;
+ dst>> fresh-allocation t ;
+
+: mutated-object ( vreg -- )
+ resolve-copy mutated-objects get conjoin ;
M: ##set-slot eliminate-write-barrier
- obj>> mutated-objects get conjoin t ;
+ obj>> mutated-object t ;
M: ##set-slot-imm eliminate-write-barrier
- obj>> mutated-objects get conjoin t ;
+ obj>> mutated-object t ;
: needs-write-barrier? ( insn -- ? )
- { [ fresh-allocations get key? not ] [ mutated-objects get key? ] } 1&& ;
+ resolve-copy {
+ [ fresh-allocations get key? not ]
+ [ mutated-objects get key? ]
+ } 1&& ;
M: ##write-barrier eliminate-write-barrier
src>> needs-write-barrier? ;
M: ##write-barrier-imm eliminate-write-barrier
src>> needs-write-barrier? ;
+M: gc-map-insn eliminate-write-barrier
+ fresh-allocations get clear-assoc ;
+
M: ##copy eliminate-write-barrier
- "Run copy propagation first" throw ;
+ [ src>> resolve-copy ] [ dst>> ] bi copies get set-at t ;
M: insn eliminate-write-barrier drop t ;
: write-barriers-step ( insns -- insns' )
H{ } clone fresh-allocations set
H{ } clone mutated-objects set
+ H{ } clone copies set
[ eliminate-write-barrier ] filter! ;
: eliminate-write-barriers ( cfg -- cfg )
aa-indirect-1 >>x
] compile-call
] unit-test
+
+! Write barrier elimination was being done before scheduling and
+! GC check insertion, and didn't take subroutine calls into
+! account. Oops...
+: write-barrier-elim-in-wrong-place ( -- obj )
+ ! A callback used below
+ void { } cdecl [ compact-gc ] alien-callback
+ ! Allocate an object A in the nursery
+ 1 f <array>
+ ! Subroutine call promotes the object to tenured
+ swap void { } cdecl alien-indirect
+ ! Allocate another object B in the nursery, store it into
+ ! the first
+ 1 f <array> over set-first
+ ! Now object A's card should be marked and minor GC should
+ ! promote B to aging
+ minor-gc
+ ! Do stuff
+ [ 100 [ ] times ] infer.
+ ;
+
+[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test
[ char { char char } cdecl [ + ] alien-callback ]
\ fixnum+fast inlined?
] unit-test
+
+[ t ] [
+ [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ]
+ \ >c-ptr inlined?
+] unit-test
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
! Windows-specific setup
ctx-reg jit-update-seh
- ! Clear x87 stack, but preserve rounding mode and exception flags
- ESP 2 SUB
- ESP [] FNSTCW
- FNINIT
- ESP [] FLDCW
- ESP 2 ADD
-
! Load arguments
EAX ESP stack-frame-size [+] MOV
EDX ESP stack-frame-size 4 + [+] MOV
! Unwind stack frames
ESP EDX MOV
- 0 jit-scrub-return
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
+[
+ ESP 2 SUB
+ ESP [] FNSTCW
+ FNINIT
+ AX ESP [] MOV
+ ESP 2 ADD
+] \ fpu-state define-sub-primitive
+
+[
+ ESP stack-frame-size [+] FLDCW
+] \ set-fpu-state define-sub-primitive
+
[
! Load callstack object
temp3 ds-reg [] MOV
! Contexts
: jit-switch-context ( reg -- )
- -4 jit-scrub-return
+ ! Reset return value since its bogus right now, to avoid
+ ! confusing the GC
+ ESP -4 [+] 0 MOV
! Make the new context the current one
ctx-reg swap MOV
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
\ (call) define-combinator-primitive
[
- ! Clear x87 stack, but preserve rounding mode and exception flags
- RSP 2 SUB
- RSP [] FNSTCW
- FNINIT
- RSP [] FLDCW
-
! Unwind stack frames
RSP arg2 MOV
- 0 jit-scrub-return
! Load VM pointer into vm-reg, since we're entering from
! C code
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
+[
+ RSP 2 SUB
+ RSP [] FNSTCW
+ FNINIT
+ AX RSP [] MOV
+ RSP 2 ADD
+] \ fpu-state define-sub-primitive
+
+[
+ RSP 2 SUB
+ RSP [] arg1 16-bit-version-of MOV
+ RSP [] FLDCW
+ RSP 2 ADD
+] \ set-fpu-state define-sub-primitive
+
[
! Load callstack object
arg4 ds-reg [] MOV
! Contexts
: jit-switch-context ( reg -- )
- -8 jit-scrub-return
+ ! Reset return value since its bogus right now, to avoid
+ ! confusing the GC
+ RSP -8 [+] 0 MOV
! Make the new context the current one
ctx-reg swap MOV
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- [ second 0 16 between? ]
+ [ second 0 17 between? ]
} cond ;
: vm-errors ( error -- n errors )
[ a>> ] [ b>> ] [ c>> ] tri
] unit-test
+TUPLE: slot-protocol-test-4 { x read-only } ;
+
+TUPLE: slot-protocol-test-5 { a-read-only-slot read-only } ;
+
+CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ;
+
+[ "hey" ] [
+ "hey" slot-protocol-test-5 boa slot-protocol-test-4 boa
+ a-read-only-slot>>
+] unit-test
+
GENERIC: do-me ( x -- )
M: f do-me drop ;
USING: accessors arrays assocs classes.tuple definitions effects generic
generic.standard hashtables kernel lexer math parser
generic.parser sequences sets slots words words.symbol fry
-compiler.units ;
+compiler.units make ;
IN: delegate
ERROR: broadcast-words-must-have-no-outputs group ;
M: standard-generic group-words
dup "combination" word-prop #>> 2array 1array ;
-: slot-group-words ( slots -- words )
+: slot-words, ( slot-spec -- )
+ [ name>> reader-word 0 2array , ]
[
- name>>
- [ reader-word 0 2array ]
- [ writer-word 0 2array ] bi
- 2array
- ] map concat ;
+ dup read-only>> [ drop ] [
+ name>> writer-word 0 2array ,
+ ] if
+ ] bi ;
+
+: slot-group-words ( slots -- words )
+ [ [ slot-words, ] each ] { } make ;
M: tuple-class group-words
all-slots slot-group-words ;
"ftp" >>protocol
"localhost" >>host
create-test-file >>path
- _ call
+ @
]
[ stop-server ] tri
] with-unique-directory drop ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays calendar classes combinators
+USING: accessors calendar calendar.format classes combinators
combinators.short-circuit concurrency.promises continuations
-destructors ftp io io.backend io.directories io.encodings
-io.encodings.binary tools.files io.encodings.utf8 io.files
-io.files.info io.pathnames io.servers.connection io.sockets
-io.streams.duplex io.streams.string io.timeouts kernel make math
-math.bitwise math.parser namespaces sequences splitting threads
-unicode.case logging calendar.format strings io.files.links
-io.files.types io.encodings.8-bit.latin1 simple-tokenizer ;
+destructors ftp io io.directories io.encodings
+io.encodings.8-bit.latin1 io.encodings.binary io.encodings.utf8
+io.files io.files.info io.files.types io.pathnames
+io.servers.connection io.sockets io.streams.string io.timeouts
+kernel logging math math.bitwise math.parser namespaces
+sequences simple-tokenizer splitting strings threads
+tools.files unicode.case ;
IN: ftp.server
SYMBOL: server
[ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ;
+: make-path-relative? ( path -- ? )
+ {
+ [ absolute-path? ]
+ [ drop server get serving-directory>> ]
+ } 1&& ;
+
+: fixup-relative-path ( string -- string' )
+ dup make-path-relative? [
+ [ server get serving-directory>> ] dip append-relative-path
+ ] when ;
+
: server-response ( string n -- )
2dup number>string swap ":" glue \ server-response DEBUG log-message
<ftp-response>
] recover ;
: random-local-server ( -- server )
- remote-address get class new 0 >>port binary <server> ;
+ remote-address get class new binary <server> ;
: port>bytes ( port -- hi lo )
[ -8 shift ] keep [ 8 bits ] bi@ ;
+: display-directory ( -- string )
+ current-directory get server get serving-directory>> swap ?head drop
+ [ "/" ] when-empty ;
+
: handle-PWD ( obj -- )
drop
- current-directory get "\"" dup surround 257 server-response ;
+ display-directory get "\"" dup surround 257 server-response ;
: handle-SYST ( obj -- )
drop
M: ftp-list handle-passive-command ( stream obj -- )
drop
start-directory [
- utf8 encode-output
- [ current-directory get directory. ] with-string-writer string-lines
+ utf8 encode-output [
+ current-directory get directory.
+ ] with-string-writer string-lines
harvest [ ftp-send ] each
] with-output-stream finish-directory ;
: handle-RETR ( obj -- )
tokenized>> second
+ fixup-relative-path
dup can-serve-file? [
<ftp-get> fulfill-client
] [
: handle-MDTM ( obj -- )
tokenized>> 1 swap ?nth [
+ fixup-relative-path
dup file-info dup directory? [
drop not-a-plain-file
] [
: handle-CWD ( obj -- )
tokenized>> 1 swap ?nth [
+ fixup-relative-path
dup can-serve-directory? [
set-current-directory
directory-change-success
<ftp-server> start-server ;
! sudo tcpdump -i en1 -A -s 10000 tcp port 21
+! [2010-09-04T22:07:58-05:00] DEBUG server-response: 500:Unrecognized command: EPRT |2|0:0:0:0:0:0:0:1|59359|
+
";" split1 nip
"=" split1 nip [ no-boundary ] unless* ;
+SYMBOL: request-limit
+
+request-limit [ 64 1024 * ] initialize
+
SYMBOL: upload-limit
+upload-limit [ 200,000,000 ] initialize
+
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
- upload-limit get min limited-input
+ unlimited-input
+ upload-limit get [ min ] when* limited-input
binary decode-input
parse-multipart-form-data parse-multipart ;
TUPLE: http-server < threaded-server ;
-SYMBOL: request-limit
-
-request-limit [ 64 1024 * ] initialize
-
M: http-server handle-client*
drop [
- request-limit get limited-input
?refresh-all
+ request-limit get limited-input
[ read-request ] ?benchmark
[ do-request ] ?benchmark
[ do-response ] ?benchmark
tools.test io.launcher arrays io namespaces continuations math
io.encodings.binary io.encodings.ascii accessors kernel
sequences io.encodings.utf8 destructors io.streams.duplex locals
-concurrency.promises threads unix.process calendar unix ;
+concurrency.promises threads unix.process calendar unix
+unix.process debugger.unix io.timeouts io.launcher.unix ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
s 3 seconds ?promise-timeout 0 =
]
] unit-test
+
+! Make sure that subprocesses don't inherit our signal mask
+
+! First, ensure that the Factor VM ignores SIGPIPE
+: send-sigpipe ( pid -- )
+ "SIGPIPE" signal-names index 1 +
+ kill io-error ;
+
+[ ] [ current-process-handle send-sigpipe ] unit-test
+
+! Spawn a process
+[ T{ signal f 13 } ] [
+ "sleep 1000" run-detached
+ 1 seconds sleep
+ [ handle>> send-sigpipe ]
+ [ 2 seconds swap set-timeout ]
+ [ wait-for-process ]
+ tri
+] unit-test
: listen-on ( threaded-server -- addrspecs )
[ secure>> >secure ] [ insecure>> >insecure ] bi
- [ resolve-host ] bi@ append ;
+ [ dup [ resolve-host ] when ] bi@ append ;
: accepted-connection ( remote local -- )
[
with-disposal
] with-scope ; inline
-TUPLE: secure addrspec ;
+TUPLE: secure { addrspec read-only } ;
C: <secure> secure
[ "2001:6f8:37a:5:0:0:0:1" ]
[ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test
-[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
+[ t t ] [
+ "localhost" 80 <inet> resolve-host
+ [ length 1 >= ]
+ [ [ [ inet4? ] [ inet6? ] bi or ] all? ] bi
+] unit-test
+
+[ t t ] [
+ "localhost" resolve-host
+ [ length 1 >= ]
+ [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi
+] unit-test
+
+[ t t ] [
+ f resolve-host
+ [ length 1 >= ]
+ [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi
+] unit-test
+
+[ t t ] [
+ f 0 <inet> resolve-host
+ [ length 1 >= ]
+ [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi
+] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
"hi\n" write flush readln readln
] with-client
] unit-test
+
+! Binding to all interfaces should work
+[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman,
+! Copyright (C) 2007, 2010 Slava Pestov, Doug Coleman,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations sequences
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
summary system vocabs.loader combinators present fry vocabs.parser
-classes.struct alien.data ;
+classes.struct alien.data strings ;
IN: io.sockets
<< {
! Addressing
<PRIVATE
+UNION: ?string string POSTPONE: f ;
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: inet-pton ( str addrspec -- data )
+GENERIC# with-port 1 ( addrspec port -- addrspec )
+
: make-sockaddr/size ( addrspec -- sockaddr size )
[ make-sockaddr ] [ sockaddr-size ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
+M: f parse-sockaddr nip ;
+
HOOK: sockaddr-of-family os ( alien af -- sockaddr )
HOOK: addrspec-of-family os ( af -- addrspec )
PRIVATE>
-TUPLE: abstract-inet host port ;
-
-M: abstract-inet present
- [ host>> ":" ] [ port>> number>string ] bi 3append ;
-
-TUPLE: local path ;
+TUPLE: local { path read-only } ;
: <local> ( path -- addrspec )
normalize-path local boa ;
M: local present path>> "Unix domain socket: " prepend ;
-TUPLE: inet4 < abstract-inet ;
+SLOT: port
-C: <inet4> inet4
+TUPLE: ipv4 { host ?string read-only } ;
+
+C: <ipv4> ipv4
-M: inet4 inet-ntop ( data addrspec -- str )
+M: ipv4 inet-ntop ( data addrspec -- str )
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
-ERROR: malformed-inet4 sequence ;
-ERROR: bad-inet4-component string ;
+<PRIVATE
-: parse-inet4 ( string -- seq )
- "." split dup length 4 = [
- malformed-inet4
- ] unless
- [
- string>number
- [ "Dotted component not a number" throw ] unless*
- ] B{ } map-as ;
+ERROR: malformed-ipv4 sequence ;
-ERROR: invalid-inet4 string reason ;
+ERROR: bad-ipv4-component string ;
-M: invalid-inet4 summary drop "Invalid IPv4 address" ;
+: parse-ipv4 ( string -- seq )
+ "." split dup length 4 = [ malformed-ipv4 ] unless
+ [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ;
-M: inet4 inet-pton ( str addrspec -- data )
- drop
- [ parse-inet4 ] [ invalid-inet4 ] recover ;
+ERROR: invalid-ipv4 string reason ;
+
+M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
+
+PRIVATE>
+
+M: ipv4 inet-pton ( str addrspec -- data )
+ drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
-M: inet4 address-size drop 4 ;
+M: ipv4 address-size drop 4 ;
-M: inet4 protocol-family drop PF_INET ;
+M: ipv4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-size drop sockaddr-in heap-size ;
+M: ipv4 sockaddr-size drop sockaddr-in heap-size ;
-M: inet4 empty-sockaddr drop sockaddr-in <struct> ;
+M: ipv4 empty-sockaddr drop sockaddr-in <struct> ;
-M: inet4 make-sockaddr ( inet -- sockaddr )
+M: ipv4 make-sockaddr ( inet -- sockaddr )
sockaddr-in <struct>
AF_INET >>family
- swap [ port>> htons >>port ]
- [ host>> "0.0.0.0" or ]
- [ inet-pton *uint >>addr ] tri ;
+ swap
+ [ port>> htons >>port ]
+ [ host>> "0.0.0.0" or ]
+ [ inet-pton *uint >>addr ] tri ;
+
+M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+ [ addr>> <uint> ] dip inet-ntop <ipv4> ;
+
+TUPLE: inet4 < ipv4 { port integer read-only } ;
+
+C: <inet4> inet4
+
+M: ipv4 with-port [ host>> ] dip <inet4> ;
M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
- [ [ addr>> <uint> ] dip inet-ntop ]
- [ drop port>> ntohs ] 2bi <inet4> ;
+ [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ;
-TUPLE: inet6 < abstract-inet ;
+M: inet4 present
+ [ host>> ] [ port>> number>string ] bi ":" glue ;
-C: <inet6> inet6
+TUPLE: ipv6 { host ?string read-only } ;
-M: inet6 inet-ntop ( data addrspec -- str )
- drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+C: <ipv6> ipv6
-ERROR: invalid-inet6 string reason ;
+M: ipv6 inet-ntop ( data addrspec -- str )
+ drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
-M: invalid-inet6 summary drop "Invalid IPv6 address" ;
+ERROR: invalid-ipv6 string reason ;
<PRIVATE
ERROR: bad-ipv4-embedded-prefix obj ;
+ERROR: more-than-8-components ;
+
: parse-ipv6-component ( seq -- seq' )
[ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ;
-: parse-inet6 ( string -- seq )
+: parse-ipv6 ( string -- seq )
[ f ] [
":" split CHAR: . over last member? [
unclip-last
- [ parse-ipv6-component ] [ parse-inet4 ] bi* append
+ [ parse-ipv6-component ] [ parse-ipv4 ] bi* append
] [
parse-ipv6-component
] if
] if-empty ;
-: pad-inet6 ( string1 string2 -- seq )
+: pad-ipv6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
- dup 0 < [ "More than 8 components" throw ] when
+ dup 0 < [ more-than-8-components ] when
<byte-array> glue ;
-: inet6-bytes ( seq -- bytes )
+: ipv6-bytes ( seq -- bytes )
[ 2 >be ] { } map-as B{ } concat-as ;
PRIVATE>
-M: inet6 inet-pton ( str addrspec -- data )
+M: ipv6 inet-pton ( str addrspec -- data )
drop
- [
- "::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes
- ] [ invalid-inet6 ] recover ;
+ [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
+ [ invalid-ipv6 ]
+ recover ;
-M: inet6 address-size drop 16 ;
+M: ipv6 address-size drop 16 ;
-M: inet6 protocol-family drop PF_INET6 ;
+M: ipv6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-size drop sockaddr-in6 heap-size ;
+M: ipv6 sockaddr-size drop sockaddr-in6 heap-size ;
-M: inet6 empty-sockaddr drop sockaddr-in6 <struct> ;
+M: ipv6 empty-sockaddr drop sockaddr-in6 <struct> ;
-M: inet6 make-sockaddr ( inet -- sockaddr )
+M: ipv6 make-sockaddr ( inet -- sockaddr )
sockaddr-in6 <struct>
AF_INET6 >>family
- swap [ port>> htons >>port ]
- [ host>> "::" or ]
- [ inet-pton >>addr ] tri ;
+ swap
+ [ port>> htons >>port ]
+ [ host>> "::" or ]
+ [ inet-pton >>addr ] tri ;
+
+M: ipv6 parse-sockaddr
+ [ addr>> ] dip inet-ntop <ipv6> ;
+
+TUPLE: inet6 < ipv6 { port integer read-only } ;
+
+C: <inet6> inet6
+
+M: ipv6 with-port [ host>> ] dip <inet6> ;
M: inet6 parse-sockaddr
- [ [ addr>> ] dip inet-ntop ]
- [ drop port>> ntohs ] 2bi <inet6> ;
+ [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ;
-M: f parse-sockaddr nip ;
+M: inet6 present
+ [ host>> ] [ port>> number>string ] bi ":" glue ;
<PRIVATE
HOOK: addrinfo-error io-backend ( n -- )
-: resolve-passive-host ( -- addrspecs )
- { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
-
: prepare-addrinfo ( -- addrinfo )
addrinfo <struct>
PF_UNSPEC >>family
IPPROTO_TCP >>protocol ;
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
PRIVATE>
: <client> ( remote encoding -- stream local )
GENERIC: resolve-host ( addrspec -- seq )
-TUPLE: inet < abstract-inet ;
+TUPLE: hostname { host ?string read-only } ;
+
+TUPLE: inet < hostname port ;
+
+M: inet present
+ [ host>> ] [ port>> number>string ] bi ":" glue ;
C: <inet> inet
+M: string resolve-host
+ f prepare-addrinfo f <void*>
+ [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
+ [ parse-addrinfo-list ] keep freeaddrinfo ;
+
+M: hostname resolve-host
+ host>> resolve-host ;
+
M: inet resolve-host
- [ port>> ] [ host>> ] bi [
- f prepare-addrinfo f <void*>
- [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
- [ parse-addrinfo-list ] keep freeaddrinfo
- ] [ resolve-passive-host ] if*
- swap fill-in-ports ;
+ [ call-next-method ] [ port>> ] bi '[ _ with-port ] map ;
+
+M: inet4 resolve-host 1array ;
+
+M: inet6 resolve-host 1array ;
-M: f resolve-host drop { } ;
+M: local resolve-host 1array ;
-M: object resolve-host 1array ;
+M: f resolve-host
+ drop { T{ ipv6 f "::" } T{ ipv4 f "0.0.0.0" } } ;
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
M: unix addrspec-of-family ( af -- addrspec )
{
- { AF_INET [ T{ inet4 } ] }
- { AF_INET6 [ T{ inet6 } ] }
+ { AF_INET [ T{ ipv4 } ] }
+ { AF_INET6 [ T{ ipv6 } ] }
{ AF_UNIX [ T{ local } ] }
[ drop f ]
} case ;
\r
M: windows addrspec-of-family ( af -- addrspec )\r
{\r
- { AF_INET [ T{ inet4 } ] }\r
- { AF_INET6 [ T{ inet6 } ] }\r
+ { AF_INET [ T{ ipv4 } ] }\r
+ { AF_INET6 [ T{ ipv6 } ] }\r
[ drop f ]\r
} case ;\r
\r
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
+
+[ t ]
+[
+ "abc" <string-reader> 3 limit-stream unlimit-stream
+ "abc" <string-reader> =
+] unit-test
+
+[ t ]
+[
+ "abc" <string-reader> 3 limit-stream unlimit-stream
+ "abc" <string-reader> =
+] unit-test
+
+[ t ]
+[
+ [
+ "resource:license.txt" utf8 <file-reader> &dispose
+ 3 limit-stream unlimit-stream
+ "resource:license.txt" utf8 <file-reader> &dispose
+ [ decoder? ] both?
+ ] with-destructors
+] unit-test
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 <limited-stream> [
+ unlimited-input contents
+ ] with-input-stream
+] unit-test
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 <limited-stream> [
+ [ contents ] with-unlimited-input
+ ] with-input-stream
+] unit-test
+
+[ "gh" ] [
+ "asdfgh" <string-reader> 4 <limited-stream> [
+ 2 [
+ [ contents drop ] with-unlimited-input
+ ] with-limited-input
+ [ contents ] with-unlimited-input
+ ] with-input-stream
+] unit-test
: with-limited-stream ( stream limit quot -- )
[ limit-stream ] dip call ; inline
+: with-limited-input ( limit quot -- )
+ [ [ input-stream get ] dip limit-stream input-stream ] dip
+ with-variable ; inline
+
ERROR: limit-exceeded n stream ;
<PRIVATE
M: limited-stream stream-element-type
stream>> stream-element-type ;
+
+GENERIC: unlimit-stream ( stream -- stream' )
+
+M: decoder unlimit-stream ( stream -- stream' )
+ [ stream>> ] change-stream ;
+
+M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
+
+: unlimited-input ( -- )
+ input-stream [ unlimit-stream ] change ;
+
+: with-unlimited-stream ( stream quot -- )
+ [ unlimit-stream ] dip call ; inline
+
+: with-unlimited-input ( quot -- )
+ [ input-stream get unlimit-stream input-stream ] dip
+ with-variable ; inline
{ $values { "assoc" "a sequence of pairs" } }
{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
{ $examples
- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
+ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
}
{ $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
{ $values { "var" "a match variable name beginning with '?'" } }
{ $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." }
{ $examples
- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
+ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
}
{ $see-also match match-cond replace-patterns match-replace } ;
USING: kernel math math.floats.env math.floats.env.private
math.functions math.libm sequences tools.test locals
compiler.units kernel.private fry compiler.test math.private
-words system ;
+words system memory ;
IN: math.floats.env.tests
: set-default-fp-env ( -- )
[ +denormal-keep+ ] [ denormal-mode ] unit-test
[ { } ] [ fp-traps ] unit-test
+[ ] [
+ all-fp-exceptions [ compact-gc ] with-fp-traps
+] unit-test
+
! In case the tests screw up the FP env because of bugs in math.floats.env
set-default-fp-env
-
: fill-bytes ( multipart -- multipart )
buffer-size read
- [ '[ _ append ] change-bytes ]
+ [ '[ _ B{ } append-as ] change-bytes ]
[ t >>end-of-stream? ] if* ;
: maybe-fill-bytes ( multipart -- multipart )
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
: parse-multipart ( separator -- mime-parts )
- <multipart> parse-beginning fill-bytes parse-multipart-loop
- mime-parts>> ;
+ <multipart> parse-beginning fill-bytes
+ parse-multipart-loop mime-parts>> ;
: callback-bottom ( params -- )
"( callback )" <uninterned-word> >>xt
- xt>> '[ _ callback-xt ] infer-quot-here ;
+ xt>> '[ _ callback-xt { alien } declare ] infer-quot-here ;
: callback-return-quot ( ctype -- quot )
return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
\ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable
\ float>bits { real } { integer } define-primitive \ float>bits make-foldable
\ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable
+\ fpu-state { } { } define-primitive
\ fputc { object alien } { } define-primitive
\ fread { integer alien } { object } define-primitive
\ fseek { integer integer alien } { } define-primitive
\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
\ set-context-object { object fixnum } { } define-primitive
+\ set-fpu-state { } { } define-primitive
\ set-innermost-frame-quot { quotation callstack } { } define-primitive
\ set-slot { object object fixnum } { } define-primitive
\ set-special-object { object fixnum } { } define-primitive
\r
ARTICLE: "tools.disassembler" "Disassembling words"\r
"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."\r
+$nl\r
+"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "."\r
+$nl\r
{ $subsections disassemble } ;\r
\r
ABOUT: "tools.disassembler"\r
"A lower-level word puts timings on the stack, intead of printing:"
{ $subsections benchmark }
"You can also read the system clock directly; see " { $link "system" } "."
-{ $see-also "profiling" "calendar" } ;
+{ $see-also "profiling" "tools.annotations" "calendar" } ;
ABOUT: "timing"
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: urls urls.private io.sockets io.sockets.secure ;
IN: urls.secure
+UNION: abstract-inet inet inet4 inet6 ;
+
M: abstract-inet >secure-addr <secure> ;
{ "tag" "kernel.private" (( object -- n )) }
{ "(execute)" "kernel.private" (( word -- )) }
{ "(call)" "kernel.private" (( quot -- )) }
+ { "fpu-state" "kernel.private" (( -- )) }
+ { "set-fpu-state" "kernel.private" (( -- )) }
{ "unwind-native-frames" "kernel.private" (( -- )) }
{ "set-callstack" "kernel.private" (( callstack -- * )) }
{ "lazy-jit-compile" "kernel.private" (( -- )) }
[ f ]
} cond ;
+PRIVATE>
+
: absolute-path? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
[ f ]
} cond nip ;
-PRIVATE>
+: append-relative-path ( path1 path2 -- path )
+ [ trim-tail-separators ]
+ [ trim-head-separators ] bi* "/" glue ;
: append-path ( path1 path2 -- path )
{
{ [ over absolute-path? over first path-separator? and ] [
[ 2 head ] dip append
] }
- [
- [ trim-tail-separators ]
- [ trim-head-separators ] bi* "/" glue
- ]
+ [ append-relative-path ]
} cond ;
: prepend-path ( path1 path2 -- path )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math threads io io.sockets
io.encodings.ascii io.streams.duplex debugger tools.time
IN: benchmark.sockets
SYMBOL: counter
-SYMBOL: port-promise
+SYMBOL: server-promise
SYMBOL: server
+SYMBOL: port
CONSTANT: number-of-requests 1000
: server-addr ( -- addr )
- "127.0.0.1" port-promise get ?promise <inet4> ;
+ "127.0.0.1" port get <inet4> ;
: server-loop ( server -- )
dup accept drop [
] curry "Client handler" spawn drop server-loop ;
: simple-server ( -- )
- [
- "127.0.0.1" 0 <inet4> ascii <server>
- [ server set ]
- [ addr>> port>> port-promise get fulfill ]
- [ [ server-loop ] with-disposal ]
- tri
- ] ignore-errors ;
+ [ server get [ server-loop ] with-disposal ] ignore-errors
+ t server-promise get fulfill ;
: simple-client ( -- )
[
: clients ( n -- )
dup pprint " clients: " write [
- <promise> port-promise set
+ <promise> server-promise set
dup <count-down> counter set
+ "127.0.0.1" 0 <inet4> ascii <server>
+ [ server set ] [ addr>> port>> port set ] bi
+
[ simple-server ] "Simple server" spawn drop
- yield yield
[ [ simple-client ] "Simple client" spawn drop ] times
+
counter get await
stop-server
- yield yield
+ server-promise get ?promise drop
] benchmark . flush ;
: socket-benchmarks ( -- )
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
-CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download"
+CONSTANT: db-url "http://software77.net/geo-ip/?DL=1"
: download-db ( -- path )
db-path dup exists? [
! 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 timers
+make mason.common mason.git calendar math timers
io.encodings.8-bit.latin1 debugger ;
IN: irc.gitbot
: check-for-updates ( chat -- )
'[
- git-id git-pull-cmd short-running-process git-id
+ git-id
+ { "git" "pull" "origin" "master" } short-running-process
+ git-id
_ report-updates
] try ;
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
-io.files io.launcher namespaces prettyprint combinators mason.child
-mason.cleanup mason.common mason.help mason.release mason.report
-mason.email mason.notify ;
+io.files io.launcher io.pathnames namespaces prettyprint
+combinators mason.child mason.cleanup mason.common mason.config
+mason.docs mason.release mason.report mason.email mason.git
+mason.notify mason.platform mason.updates ;
QUALIFIED: continuations
IN: mason.build
now datestamp stamp set
build-dir make-directory ;
-: enter-build-dir ( -- ) build-dir set-current-directory ;
+: enter-build-dir ( -- )
+ build-dir set-current-directory ;
-: clone-builds-factor ( -- )
- "git" "clone" builds/factor 3array short-running-process ;
+: clone-source ( -- )
+ "git" "clone" builds-dir get "factor" append-path 3array
+ short-running-process ;
-: begin-build ( -- )
+: copy-image ( -- )
+ builds-dir get boot-image-name append-path
+ [ "." copy-file-into ] [ "factor" copy-file-into ] bi ;
+
+: save-git-id ( -- )
"factor" [ git-id ] with-directory {
[ "git-id" to-file ]
[ "factor/git-id" to-file ]
[ notify-begin-build ]
} cleave ;
+: begin-build ( -- )
+ clone-source
+ copy-image
+ save-git-id ;
+
: build ( -- )
create-build-dir
enter-build-dir
- clone-builds-factor
[
begin-build
build-child
[ notify-report ]
- [ status-clean eq? [ upload-help release ] when ] bi
+ [ status-clean eq? [ upload-docs release ] when ] bi
+ finish-build
] [ cleanup ] [ ] continuations:cleanup ;
MAIN: build
try-process
] with-directory ;
-: builds-factor-image ( -- img )
- builds/factor boot-image-name append-path ;
-
-: copy-image ( -- )
- builds-factor-image "." copy-file-into
- builds-factor-image "factor" copy-file-into ;
-
: factor-vm ( -- string )
target-os get "winnt" = "./factor.com" "./factor" ? ;
] if ;
: build-child ( -- status )
- copy-image
{
{ [ notify-make-vm make-vm ] [ compile-failed ] }
{ [ notify-boot boot ] [ boot-failed ] }
[ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test
-[ "/home/bobby/builds/factor" ] [
- [
- "/home/bobby/builds" builds-dir set
- builds/factor
- ] with-scope
-] unit-test
-
[ t ] [
[
"/home/bobby/builds" builds-dir set
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
#! 30 minutes to complete, to catch hangs.
>process 30 minutes >>timeout try-output-process ;
-HOOK: really-delete-tree os ( path -- )
+HOOK: (really-delete-tree) os ( path -- )
-M: windows really-delete-tree
+M: windows (really-delete-tree)
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
[ { "chmod" "ug+rw" "-R" } swap absolute-path suffix short-running-process ]
[ delete-tree ]
bi ;
-M: unix really-delete-tree delete-tree ;
+M: unix (really-delete-tree) delete-tree ;
+
+: really-delete-tree ( path -- )
+ dup exists? [ (really-delete-tree) ] [ drop ] if ;
: retry ( n quot -- )
[ iota ] dip
SYMBOL: stamp
-: builds/factor ( -- path ) builds-dir get "factor" append-path ;
: build-dir ( -- path ) builds-dir get stamp get append-path ;
-: prepare-build-machine ( -- )
- builds-dir get make-directories
- builds-dir get
- [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
- with-directory ;
-
-: git-id ( -- id )
- { "git" "show" } utf8 [ lines ] with-process-reader
- first " " split second ;
-
-: ?prepare-build-machine ( -- )
- builds/factor exists? [ prepare-build-machine ] unless ;
-
CONSTANT: load-all-vocabs-file "load-everything-vocabs"
CONSTANT: load-all-errors-file "load-everything-errors"
! Keep test-log around?
SYMBOL: builder-debug
+! URL for counter notifications.
+SYMBOL: counter-url
+
+counter-url [ "http://builds.factorcode.org/counter" ] initialize
+
! URL for status notifications.
SYMBOL: status-url
+status-url [ "http://builds.factorcode.org/status-update" ] initialize
+
! Password for status notifications.
SYMBOL: status-secret
-SYMBOL: upload-help?
+SYMBOL: upload-docs?
-! The below are only needed if upload-help is true.
+! The below are only needed if upload-docs? is true.
-! Host with HTML help
-SYMBOL: help-host
+! Host to upload docs to
+SYMBOL: docs-host
! Username to log in.
-SYMBOL: help-username
+SYMBOL: docs-username
! Directory to upload docs to.
-SYMBOL: help-directory
+SYMBOL: docs-directory
+
+! URL to notify server about new docs
+SYMBOL: docs-update-url
+
+docs-update-url [ "http://builds.factorcode.org/docs-update" ] initialize
! Boolean. Do we release binaries and update the clean branch?
SYMBOL: upload-to-factorcode?
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: mason.disk tools.test strings sequences ;
+IN: mason.disk.tests
+
+[ t ] [ disk-usage string? ] unit-test
+
+[ t ] [ sufficient-disk-space? { t f } member? ] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.files.info io.pathnames kernel math
+math.parser namespaces sequences mason.config ;
+IN: mason.disk
+
+: gb ( -- n ) 30 2^ ; inline
+
+: sufficient-disk-space? ( -- ? )
+ ! We want at least 300Mb to be available before starting
+ ! a build.
+ current-directory get file-system-info available-space>>
+ gb > ;
+
+: check-disk-space ( -- )
+ sufficient-disk-space? [
+ "Less than 1 Gb free disk space." throw
+ ] unless ;
+
+: mb-str ( n -- string ) gb /i number>string ;
+
+: disk-usage ( -- string )
+ builds-dir get file-system-info
+ [ used-space>> ] [ total-space>> ] bi
+ [ [ mb-str ] bi@ " / " glue " Gb used" append ]
+ [ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi
+ " " glue ;
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays hashtables help.html http.client io.directories
+io.files io.launcher kernel make mason.common mason.config
+namespaces sequences ;
+IN: mason.docs
+
+: make-docs-archive ( -- )
+ "factor/temp" [
+ { "tar" "cfz" "docs.tar.gz" "docs" } short-running-process
+ ] with-directory ;
+
+: upload-docs-archive ( -- )
+ "factor/temp/docs.tar.gz"
+ docs-username get
+ docs-host get
+ docs-directory get "/docs.tar.gz" append
+ upload-safely ;
+
+: notify-docs ( -- )
+ status-secret get "secret" associate
+ docs-update-url get
+ http-post
+ 2drop ;
+
+: upload-docs ( -- )
+ upload-docs? get [
+ make-docs-archive
+ upload-docs-archive
+ notify-docs
+ ] when ;
\ No newline at end of file
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors combinators make smtp debugger
-prettyprint sequences io io.streams.string io.encodings.utf8 io.files
-io.sockets mason.common mason.platform mason.config ;
+USING: accessors calendar combinators continuations debugger fry
+io io.encodings.utf8 io.files io.sockets kernel make
+mason.common mason.config mason.platform math.order namespaces
+prettyprint sequences smtp ;
IN: mason.email
: mason-email ( body content-type subject -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- swap >>subject
- swap >>content-type
- swap >>body
- send-email ;
+ '[
+ <email>
+ builder-from get >>from
+ builder-recipients get >>to
+ _ >>body
+ _ >>content-type
+ _ >>subject
+ send-email
+ ] [
+ "E-MAILING FAILED:" print
+ error. flush
+ ] recover ;
: subject-prefix ( -- string )
"mason on " platform ": " 3append ;
: email-report ( report status -- )
[ "text/html" ] dip report-subject mason-email ;
-: email-error ( error callstack -- )
+! Some special logic to throttle the amount of fatal errors
+! coming in, if eg git-daemon goes down on factorcode.org and
+! it fails pulling every 5 minutes.
+
+SYMBOL: last-email-time
+
+SYMBOL: next-email-time
+
+: send-email-throttled? ( -- ? )
+ ! We sent too many errors. See if its time to send a new
+ ! one again.
+ now next-email-time get-global after?
+ [ f next-email-time set-global t ] [ f ] if ;
+
+: throttle-time ( -- dt ) 6 hours ;
+
+: throttle-emails ( -- )
+ ! Last e-mail was less than 20 minutes ago. Don't send any
+ ! errors for 4 hours.
+ throttle-time hence next-email-time set-global
+ f last-email-time set-global ;
+
+: maximum-frequency ( -- dt ) 30 minutes ;
+
+: send-email-capped? ( -- ? )
+ ! We're about to send an error after sending another one.
+ ! See if we should start throttling emails.
+ last-email-time get-global
+ maximum-frequency ago
+ after?
+ [ throttle-emails f ] [ t ] if ;
+
+: email-fatal? ( -- ? )
+ {
+ { [ next-email-time get-global ] [ send-email-throttled? ] }
+ { [ last-email-time get-global ] [ send-email-capped? ] }
+ [ now last-email-time set-global t ]
+ } cond
+ dup [ now last-email-time set-global ] when ;
+
+: email-fatal ( string subject -- )
+ [ print nl print flush ]
[
- "Fatal error on " write host-name print nl
- [ error. ] [ callstack. ] bi*
- ] with-string-writer
- "text/plain"
- subject-prefix "fatal error" append
- mason-email ;
+ email-fatal? [
+ now last-email-time set-global
+ [ "text/plain" subject-prefix ] dip append
+ mason-email
+ ] [ 2drop ] if
+ ] 2bi ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit continuations
+debugger io io.directories io.encodings.utf8 io.files
+io.launcher io.sockets io.streams.string kernel mason.common
+mason.email sequences splitting ;
+IN: mason.git
+
+: git-id ( -- id )
+ { "git" "show" } utf8 [ lines ] with-process-reader
+ first " " split second ;
+
+<PRIVATE
+
+: git-clone-cmd ( -- cmd )
+ {
+ "git"
+ "clone"
+ "git://factorcode.org/git/factor.git"
+ } ;
+
+: git-clone ( -- )
+ #! Must be run from builds-dir
+ git-clone-cmd try-output-process ;
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: repo-corrupted-body ( error -- string )
+ [
+ "Corrupted repository on " write host-name write " will be re-cloned." print
+ "Error while pulling was:" print
+ nl
+ error.
+ ] with-string-writer ;
+
+: git-repo-corrupted ( error -- )
+ repo-corrupted-body "corrupted repo" email-fatal
+ "factor" really-delete-tree
+ git-clone ;
+
+: git-pull-failed ( error -- )
+ dup output-process-error? [
+ dup output>> "not uptodate. Cannot merge." swap start
+ [ git-repo-corrupted ]
+ [ rethrow ]
+ if
+ ] [ rethrow ] if ;
+
+: with-process-reader* ( desc encoding quot -- )
+ [ <process-reader*> ] dip swap [ with-input-stream ] dip
+ dup wait-for-process dup { 0 1 } member?
+ [ 2drop ] [ process-failed ] if ; inline
+
+: git-status-cmd ( -- cmd )
+ { "git" "status" } ;
+
+: git-status-failed ( error -- )
+ #! Exit code 1 means there's nothing to commit.
+ dup { [ process-failed? ] [ code>> 1 = ] } 1&&
+ [ drop ] [ rethrow ] if ;
+
+: git-status ( -- seq )
+ [
+ git-status-cmd utf8 [ lines ] with-process-reader*
+ [ "#\t" head? ] filter
+ ] [ git-status-failed { } ] recover ;
+
+: check-repository ( -- seq )
+ "factor" [ git-status ] with-directory ;
+
+: repo-dirty-body ( error -- string )
+ [
+ "Dirty repository on " write host-name write " will be re-cloned." print
+ "Modified and untracked files:" print nl
+ [ print ] each
+ ] with-string-writer ;
+
+: git-repo-dirty ( files -- )
+ repo-dirty-body "dirty repo" email-fatal
+ "factor" really-delete-tree
+ git-clone ;
+
+PRIVATE>
+
+: git-pull ( -- id )
+ #! Must be run from builds-dir.
+ "factor" exists? [
+ check-repository [
+ "factor" [
+ [ git-pull-cmd short-running-process ]
+ [ git-pull-failed ]
+ recover
+ ] with-directory
+ ] [ git-repo-dirty ] if-empty
+ ] [ git-clone ] if
+ "factor" [ git-id ] with-directory ;
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.html io.directories io.files io.launcher
-kernel make mason.common mason.config namespaces sequences ;
-IN: mason.help
-
-: make-help-archive ( -- )
- "factor/temp" [
- { "tar" "cfz" "docs.tar.gz" "docs" } short-running-process
- ] with-directory ;
-
-: upload-help-archive ( -- )
- "factor/temp/docs.tar.gz"
- help-username get
- help-host get
- help-directory get "/docs.tar.gz" append
- upload-safely ;
-
-: upload-help ( -- )
- upload-help? get [
- make-help-archive
- upload-help-archive
- ] when ;
\ No newline at end of file
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar continuations debugger io
-io.directories io.files kernel mason.common
-mason.email mason.updates mason.notify namespaces threads ;
+io.directories io.pathnames io.sockets io.streams.string kernel
+mason.config mason.disk mason.email mason.notify mason.updates
+namespaces prettyprint threads ;
FROM: mason.build => build ;
IN: mason
-: build-loop-error ( error -- )
- [ "Build loop error:" print flush error. flush :c flush ]
- [ error-continuation get call>> email-error ] bi ;
+: fatal-error-body ( error callstack -- string )
+ [
+ "Fatal error on " write host-name print nl
+ [ error. ] [ callstack. ] bi*
+ ] with-string-writer ;
-: build-loop-fatal ( error -- )
- "FATAL BUILDER ERROR:" print
- error. flush ;
+: build-loop-error ( error callstack -- )
+ fatal-error-body
+ "build loop error"
+ email-fatal ;
: build-loop ( -- )
- ?prepare-build-machine
+ notify-heartbeat
+
[
- notify-heartbeat
- [
- builds/factor set-current-directory
- new-code-available? [ build ] when
- ] [
- build-loop-error
- ] recover
+ builds-dir get make-directories
+ builds-dir get [
+ check-disk-space
+ update-sources
+ build? [ build ] [ 5 minutes sleep ] if
+ ] with-directory
] [
- build-loop-fatal
+ error-continuation get call>> build-loop-error
+ 5 minutes sleep
] recover
- 5 minutes sleep
+
build-loop ;
MAIN: build-loop
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry http.client io io.encodings.utf8 io.files
kernel mason.common mason.config mason.email mason.twitter
-namespaces prettyprint sequences ;
+namespaces prettyprint sequences debugger continuations ;
IN: mason.notify
: status-notify ( report arg message -- )
- [
- short-host-name "host-name" set
- target-cpu get "target-cpu" set
- target-os get "target-os" set
- status-secret get "secret" set
- "message" set
- "arg" set
- "report" set
- ] H{ } make-assoc
- [ 5 ] dip '[ _ status-url get http-post 2drop ] retry ;
+ '[
+ 5 [
+ [
+ short-host-name "host-name" set
+ target-cpu get "target-cpu" set
+ target-os get "target-os" set
+ status-secret get "secret" set
+ _ "report" set
+ _ "arg" set
+ _ "message" set
+ ] H{ } make-assoc
+ status-url get http-post 2drop
+ ] retry
+ ] [
+ "STATUS NOTIFY FAILED:" print
+ error. flush
+ ] recover ;
: notify-heartbeat ( -- )
f f "heartbeat" status-notify ;
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 io.files io.sockets io.streams.string kernel
-locals mason.common mason.config mason.platform math namespaces
-prettyprint sequences xml.syntax xml.writer combinators.short-circuit
-literals splitting ;
+locals mason.common mason.config mason.disk mason.platform math
+namespaces prettyprint sequences xml.syntax xml.writer
+combinators.short-circuit literals splitting ;
IN: mason.report
: git-link ( id -- link )
target-os get
target-cpu get
short-host-name
+ disk-usage
build-dir
current-git-id get git-link
[XML
<h1>Build report for <->/<-></h1>
<table>
<tr><td>Build machine:</td><td><-></td></tr>
+ <tr><td>Disk usage:</td><td><-></td></tr>
<tr><td>Build directory:</td><td><-></td></tr>
<tr><td>GIT ID:</td><td><-></td></tr>
</table>
--- /dev/null
+USING: continuations db db.sqlite io.directories io.files.temp
+mason.server tools.test ;
+IN: mason.server.tests
+
+[ "test.db" temp-file delete-file ] ignore-errors
+
+[ 0 1 2 ] [
+ "test.db" temp-file <sqlite-db> [
+ init-mason-db
+
+ counter-value
+ increment-counter-value
+ increment-counter-value
+ ] with-db
+] unit-test
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: db db.sqlite db.tuples db.types kernel ;
+USING: accessors calendar db db.sqlite db.tuples db.types kernel
+math math.order sequences combinators.short-circuit ;
IN: mason.server
CONSTANT: +starting+ "starting"
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
-
+
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
{ "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
-
+
{ "last-git-id" "LAST_GIT_ID" TEXT }
{ "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
{ "status" "STATUS" TEXT }
} define-persistent
+TUPLE: counter id value ;
+
+counter "COUNTER" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "value" "VALUE" INTEGER }
+} define-persistent
+
+: counter-tuple ( -- counter )
+ counter new select-tuple
+ [ counter new dup insert-tuple ] unless* ;
+
+: counter-value ( -- n )
+ [ counter-tuple value>> 0 or ] with-transaction ;
+
+: increment-counter-value ( -- n )
+ [
+ counter-tuple [ 0 or 1 + dup ] change-value update-tuple
+ ] with-transaction ;
+
+: crashed-builders ( -- seq )
+ builder new select-tuples
+ [ current-timestamp>> 5 hours ago before? ] filter ;
+
+: broken-builders ( -- seq )
+ builder new select-tuples
+ [
+ clean-timestamp>>
+ { [ not ] [ 1 weeks ago before? ] } 1||
+ ] filter ;
+
+: funny-builders ( -- crashed broken limbo )
+ builder new select-tuples
+ [ [ current-timestamp>> 5 hours ago before? ] filter ]
+ [ [ clean-timestamp>> 1 weeks ago before? ] filter ]
+ [ [ [ clean-git-id>> ] [ release-git-id>> ] bi = not ] filter ]
+ tri ;
+
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
: with-mason-db ( quot -- )
[ mason-db ] dip with-db ; inline
+
+: init-mason-db ( -- )
+ { builder counter } ensure-tables ;
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.download io.directories io.launcher
-kernel mason.common mason.platform ;
+USING: bootstrap.image.download http.client init kernel
+math.parser namespaces mason.config mason.common mason.git
+mason.platform ;
IN: mason.updates
-: git-pull-cmd ( -- cmd )
- {
- "git"
- "pull"
- "--no-summary"
- "git://factorcode.org/git/factor.git"
- "master"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull-cmd short-running-process
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- boot-image-name maybe-download-image ;
-
-: new-code-available? ( -- ? )
- updates-available? new-image-available? or ;
+TUPLE: sources git-id boot-image counter ;
+
+C: <sources> sources
+
+SYMBOLS: latest-sources last-built-sources ;
+
+[
+ f latest-sources set-global
+ f last-built-sources set-global
+] "mason.updates" add-startup-hook
+
+: latest-boot-image ( -- boot-image )
+ boot-image-name
+ [ maybe-download-image drop ] [ file-checksum ] bi ;
+
+: latest-counter ( -- counter )
+ counter-url get-global http-get nip string>number ;
+
+: update-sources ( -- )
+ #! Must be run from builds-dir
+ git-pull latest-boot-image latest-counter <sources>
+ latest-sources set-global ;
+
+: build? ( -- ? )
+ latest-sources get-global last-built-sources get-global = not ;
+
+: finish-build ( -- )
+ #! If the build completed (successfully or not) without
+ #! mason crashing or being killed, don't build this git ID
+ #! and boot image hash again.
+ latest-sources get-global last-built-sources set-global ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
-urls.secure fry oauth urls ;
+urls.secure fry oauth urls system ;
IN: twitter
! Configuration
call
] with-scope ; inline
+: twitter-url ( string -- string' )
+ os windows?
+ "http://twitter.com/"
+ "https://twitter.com/" ? prepend ;
+
PRIVATE>
: obtain-twitter-request-token ( -- request-token )
[
- "https://twitter.com/oauth/request_token"
+ "oauth/request_token" twitter-url
<request-token-params>
obtain-request-token
] with-twitter-oauth ;
: twitter-authorize-url ( token -- url )
- "https://twitter.com/oauth/authorize" >url
+ "oauth/authorize" twitter-url >url
swap key>> "oauth_token" set-query-param ;
: obtain-twitter-access-token ( request-token verifier -- access-token )
[
- [ "https://twitter.com/oauth/access_token" ] 2dip
+ [ "oauth/access_token" twitter-url ] 2dip
<access-token-params>
swap >>verifier
swap >>request-token
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
! Twitter requests
-: twitter-url ( string -- url )
- "https://twitter.com/statuses/" ".json" surround ;
+: status-url ( string -- url )
+ "statuses/" ".json" surround twitter-url ;
: set-request-twitter-auth ( request -- request )
[ <oauth-request-params> set-oauth ] with-twitter-oauth ;
] H{ } make-assoc ;
: (tweet) ( string -- json )
- update-post-data "update" twitter-url
+ update-post-data "update" status-url
<post-request> twitter-request ;
PRIVATE>
<PRIVATE
: timeline ( url -- tweets )
- twitter-url <get-request>
+ status-url <get-request>
twitter-request json>twitter-statuses ;
PRIVATE>
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions http.server.responses
+mason.server math.parser ;
+IN: webapps.mason.counter
+
+: <counter-action> ( -- action )
+ <action>
+ [
+ [
+ counter-value number>string
+ "text/plain" <content>
+ ] with-mason-db
+ ] >>display ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Mason dashboard</t:title>
+
+ <h1>Crashed build machines</h1>
+ <p>Machines which have not sent a heartbeat for several hours:</p>
+ <t:xml t:name="crashed" />
+
+ <h1>Broken build machines</h1>
+ <p>Machines which have not had a successful build for over a week:</p>
+ <t:xml t:name="broken" />
+
+ <h1>Build machines in limbo</h1>
+ <p>Machines with a clean build that have not uploaded binary for that build:</p>
+ <t:xml t:name="limbo" />
+
+ <h1>Force build now</h1>
+ <p>Requires build engineer status.</p>
+
+ <t:form t:action="$mason-app/dashboard/increment-counter">
+ <p><button type="submit">Increment counter</button></p>
+ </t:form>
+
+ <h1>Make a release</h1>
+ <p>Requires build engineer status.</p>
+
+ <t:form t:action="$mason-app/dashboard/make-release">
+ <table>
+ <tr><td>Version:</td><td><t:field t:name="version" /></td></tr>
+ <tr><td>Announcement URL:</td><td><t:field t:name="announcement-url" /></td></tr>
+ </table>
+
+ <p><button type="submit">Go</button></p>
+ </t:form>
+</t:chloe>
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel mason.server furnace.actions
+html.forms sequences xml.syntax webapps.mason.utils ;
+IN: webapps.mason.downloads
+
+: builder-list ( seq -- xml )
+ [
+ [ package-url ] [ [ os>> ] [ cpu>> ] bi "/" glue ] bi
+ [XML <li><a href=<->><-></a></li> XML]
+ ] map
+ [ [XML <p>No machines.</p> XML] ]
+ [ [XML <ul><-></ul> XML] ]
+ if-empty ;
+
+: <dashboard-action> ( -- action )
+ <page-action>
+ [
+ [
+ funny-builders
+ [ builder-list ] tri@
+ [ "crashed" set-value ]
+ [ "broken" set-value ]
+ [ "limbo" set-value ] tri*
+ ] with-mason-db
+ ] >>init ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations furnace.actions help.html
+http.server.responses io.directories io.directories.hierarchy
+io.launcher io.files io.pathnames kernel memoize threads
+webapps.mason.utils ;
+IN: webapps.mason.docs-update
+
+: update-docs ( -- )
+ home [
+ "newdocs" make-directory
+ "newdocs" [ { "tar" "xfz" "../docs.tar.gz" } try-process ] with-directory
+
+ "docs" exists? [ "docs" "docs.old" move-file ] when
+ "newdocs/docs" "docs" move-file
+
+ "newdocs" delete-directory
+ "docs.old" exists? [ "docs.old" delete-tree ] when
+
+ \ load-index reset-memoized
+ ] with-directory ;
+
+: <docs-update-action> ( -- action )
+ <action>
+ [ validate-secret ] >>validate
+ [
+ [ update-docs ] "Documentation update" spawn drop
+ "OK" "text/plain" <content>
+ ] >>submit ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <title>Factor binary package for <t:label t:name="platform" /></title>
- </head>
- <body>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <h1>Factor binary package for <t:label t:name="platform" /></h1>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
- <p>Requirements:</p>
- <t:xml t:name="requirements" />
+ <h1>Factor binary package for <t:label t:name="platform" /></h1>
- <h2>Download <t:xml t:name="package" /></h2>
+ <p>Requirements:</p>
+ <t:xml t:name="requirements" />
- <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
+ <h2>Download <t:xml t:name="package" /></h2>
- <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
+ <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
- <h1>Build machine information</h1>
+ <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
- <table border="1">
- <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
- <tr><td>Last heartbeat:</td><td><t:label t:name="current-timestamp" /></td></tr>
- <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
- <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
- <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
- <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
- <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
- </table>
+ <h1>Build machine information</h1>
- <p><t:xml t:name="last-report" /></p>
- </body>
-</html>
+ <table border="1">
+ <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
+ <tr><td>Last heartbeat:</td><td><t:label t:name="current-timestamp" /></td></tr>
+ <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
+ <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
+ <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
+ <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
+ <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
+ </table>
+
+ <p><t:xml t:name="last-report" /></p>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <title>Factor binary package for <t:label t:name="platform" /></title>
- </head>
- <body>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <h1>Factor binary package for <t:label t:name="platform" /></h1>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
- <p>Requirements:</p>
- <t:xml t:name="requirements" />
+ <h1>Factor binary package for <t:label t:name="platform" /></h1>
- <h2>Download <t:xml t:name="release" /></h2>
+ <p>Requirements:</p>
+ <t:xml t:name="requirements" />
- <p>This release was built from GIT ID <t:xml t:name="git-id" />.</p>
+ <h2>Download <t:xml t:name="release" /></h2>
- <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
- </body>
-</html>
+ <p>This release was built from GIT ID <t:xml t:name="git-id" />.</p>
+
+ <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
</t:chloe>
<t:xml t:name="package-grid" />
</table>
+<p>Stable and development releases are built and uploaded by the <a href="http://concatenative.org/wiki/view/Factor/Build farm">build farm</a>. Follow <a href="http://twitter.com/FactorBuilds">@FactorBuilds</a> on Twitter to receive notifications. If you're curious, take a look at the <t:a t:href="$mason-app/dashboard">build farm dashboard</t:a>.</p>
+
</t:chloe>
</table>
XML] ;
-: package-url ( builder -- url )
- [ URL" $mason-app/package" ] dip
- [ os>> "os" set-query-param ]
- [ cpu>> "cpu" set-query-param ] bi
- adjust-url ;
-
: package-date ( filename -- date )
"." split1 drop 16 tail* 6 head* ;
] with-mason-db
] >>display ;
-: release-url ( builder -- url )
- [ URL" $mason-app/release" ] dip
- [ os>> "os" set-query-param ]
- [ cpu>> "cpu" set-query-param ] bi
- adjust-url ;
-
: release-version ( filename -- release )
".tar.gz" ?tail drop ".zip" ?tail drop ".dmg" ?tail drop
"-" split1-last nip ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions math.parser
+http.server.responses mason.server ;
+IN: webapps.mason.increment-counter
+
+: <increment-counter-action> ( -- action )
+ <action>
+ [
+ [
+ increment-counter-value
+ number>string "text/plain" <content>
+ ] with-mason-db
+ ] >>submit ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <title>Make release</title>
- </head>
- <body>
- <t:form t:action="$mason-app/make-release">
- <table>
- <tr><td>Version:</td><td><t:field t:name="version" /></td></tr>
- <tr><td>Announcement URL:</td><td><t:field t:name="announcement-url" /></td></tr>
- </table>
-
- <p><button type="submit">Go</button></p>
- </t:form>
- </body>
-</html>
-
-</t:chloe>
IN: webapps.mason.make-release
: <make-release-action> ( -- action )
- <page-action>
+ <action>
[
{
{ "version" [ v-one-line ] }
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors furnace.auth furnace.db
+USING: accessors furnace.actions furnace.auth furnace.db
http.server.dispatchers mason.server webapps.mason.grids
-webapps.mason.make-release webapps.mason.package
-webapps.mason.release webapps.mason.report
-webapps.mason.downloads webapps.mason.status-update ;
+webapps.mason.package webapps.mason.release webapps.mason.report
+webapps.mason.downloads webapps.mason.counter
+webapps.mason.status-update webapps.mason.docs-update
+webapps.mason.dashboard webapps.mason.make-release
+webapps.mason.increment-counter ;
IN: webapps.mason
TUPLE: mason-app < dispatcher ;
-SYMBOL: can-make-releases?
+SYMBOL: build-engineer?
-can-make-releases? define-capability
+build-engineer? define-capability
+
+: <mason-protected> ( responder -- responder' )
+ <protected>
+ "access the build farm dashboard" >>description
+ { build-engineer? } >>capabilities ;
: <mason-app> ( -- dispatcher )
mason-app new-dispatcher
{ mason-app "downloads" } >>template
"downloads" add-responder
- <make-release-action>
- { mason-app "make-release" } >>template
- <protected>
- "make releases" >>description
- { can-make-releases? } >>capabilities
- "make-release" add-responder
-
<status-update-action>
- "status-update" add-responder ;
+ "status-update" add-responder
+
+ <docs-update-action>
+ "docs-update" add-responder
+
+ <counter-action>
+ "counter" add-responder
+
+ <dispatcher>
+ <dashboard-action>
+ { mason-app "dashboard" } >>template
+ "" add-responder
+
+ <make-release-action> <mason-protected>
+ "make-release" add-responder
+
+ <increment-counter-action> <mason-protected>
+ "increment-counter" add-responder
+
+ "dashboard" add-responder ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar combinators db.tuples furnace.actions
furnace.redirection html.forms http.server.responses io kernel
-mason.config mason.server namespaces validators ;
+mason.server namespaces validators webapps.mason.utils ;
IN: webapps.mason.status-update
: find-builder ( -- builder )
{ "message" [ v-one-line ] }
{ "arg" [ [ v-one-line ] v-optional ] }
{ "report" [ ] }
- { "secret" [ v-one-line ] }
} validate-params
- "secret" value status-secret get = [ validation-failed ] unless
+ validate-secret
] >>validate
[
[
- [
- find-builder
- now >>current-timestamp
- [ update-builder ] [ update-tuple ] bi
- ] with-mason-db
- "OK" "text/html" <content>
- ] if-secure
+ find-builder
+ now >>current-timestamp
+ [ update-builder ] [ update-tuple ] bi
+ ] with-mason-db
+ "OK" "text/plain" <content>
] >>submit ;
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs db.tuples furnace.actions
-html.forms kernel mason.server mason.version.data sequences
-validators xml.syntax ;
+furnace.utilities html.forms kernel mason.config mason.server
+mason.version.data namespaces sequences validators xml.syntax
+urls ;
IN: webapps.mason.utils
: link ( url label -- xml )
: download-url ( string -- string' )
"http://downloads.factorcode.org/" prepend ;
+
+: package-url ( builder -- url )
+ [ URL" $mason-app/package" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ adjust-url ;
+
+: release-url ( builder -- url )
+ [ URL" $mason-app/release" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ adjust-url ;
+
+: validate-secret ( -- )
+ { { "secret" [ v-one-line ] } } validate-params
+ "secret" value status-secret get =
+ [ validation-failed ] unless ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
-assocs db.tuples arrays splitting strings validators urls
+assocs db.tuples arrays splitting strings validators urls fry
html.forms
html.components
furnace
"administer users" >>description
{ can-administer-users? } >>capabilities ;
-: make-admin ( username -- )
- <user>
- select-tuple
- [ can-administer-users? suffix ] change-capabilities
+: give-capability ( username capability -- )
+ [ <user> select-tuple ] dip
+ '[ _ suffix ] change-capabilities
update-tuple ;
+
+: make-admin ( username -- )
+ can-administer-users? give-capability ;
webapps.wiki
webapps.user-admin
webapps.help
-webapps.mason ;
+webapps.mason
+mason.server ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
: init-factor-db ( -- )
+ mason-db [ init-mason-db ] with-db
+
test-db [
init-furnace-tables
<user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> "pastebin" add-responder
<planet> <login-config> <factor-boilerplate> "planet" add-responder
- <mason-app> <login-config> "mason" add-responder
+ <mason-app> <login-config> <factor-boilerplate> "mason" add-responder
"/tmp/docs/" <help-webapp> "docs" add-responder
test-db <alloy>
main-responder set-global ;
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
- <mason-app> <login-config> test-db <alloy> "builds.factorcode.org" add-responder
+ <mason-app> <login-config>
<factor-boilerplate> test-db <alloy> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
to_tenured_collector collector(this);
- current_gc->event->started_card_scan();
+ gc_event *event = current_gc->event;
+
+ if(event) event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
full_unmarker());
- current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+ if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
- current_gc->event->started_code_scan();
+ if(event) event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_aging);
- current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+ if(event) event->ended_code_scan(collector.code_blocks_scanned);
collector.tenure_reachable_objects();
}
FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
}
+void factor_vm::scrub_return_address()
+{
+ stack_frame *top = ctx->callstack_top;
+ stack_frame *bottom = ctx->callstack_bottom;
+ stack_frame *frame = bottom - 1;
+
+ while(frame >= top && frame_successor(frame) >= top)
+ frame = frame_successor(frame);
+
+ set_frame_offset(frame,0);
+
+#ifdef FACTOR_DEBUG
+ /* Doing a GC here triggers all kinds of funny errors */
+ primitive_compact_gc();
+#endif
+}
+
cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
/* Compact data and code heaps */
void factor_vm::collect_compact_impl(bool trace_contexts_p)
{
- current_gc->event->started_compaction();
+ gc_event *event = current_gc->event;
+
+ if(event) event->started_compaction();
tenured_space *tenured = data->tenured;
mark_bits<object> *data_forwarding_map = &tenured->state;
update_code_roots_for_compaction();
callbacks->update();
- current_gc->event->ended_compaction();
+ if(event) event->ended_compaction();
}
struct code_compaction_fixup {
c_to_factor_func(quot);
}
+template<typename Func> Func factor_vm::get_entry_point(cell n)
+{
+ /* We return word->code->entry_point() and not word->entry_point,
+ because if profiling is enabled, we don't want to go through the
+ entry point's profiling stub. This clobbers registers, since entry
+ points use the C ABI and not the Factor ABI. */
+ tagged<word> entry_point_word(special_objects[n]);
+ return (Func)entry_point_word->code->entry_point();
+}
+
void factor_vm::unwind_native_frames(cell quot, stack_frame *to)
{
- tagged<word> unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]);
- unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->entry_point;
- unwind_native_frames_func(quot,to);
+ get_entry_point<unwind_native_frames_func_type>(UNWIND_NATIVE_FRAMES_WORD)(quot,to);
+}
+
+cell factor_vm::get_fpu_state()
+{
+ return get_entry_point<get_fpu_state_func_type>(GET_FPU_STATE_WORD)();
+}
+
+void factor_vm::set_fpu_state(cell state)
+{
+ get_entry_point<set_fpu_state_func_type>(GET_FPU_STATE_WORD)(state);
}
}
typedef void (* c_to_factor_func_type)(cell quot);
typedef void (* unwind_native_frames_func_type)(cell quot, stack_frame *to);
+typedef cell (* get_fpu_state_func_type)();
+typedef void (* set_fpu_state_func_type)(cell state);
}
exit(1);
}
-void factor_vm::throw_error(cell error, stack_frame *stack)
+void factor_vm::throw_error(cell error)
{
- assert(stack);
-
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT]))
ctx->push(error);
- unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],stack);
+ unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],
+ ctx->callstack_top);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
}
}
-void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack)
-{
- throw_error(allot_array_4(special_objects[OBJ_ERROR],
- tag_fixnum(error),arg1,arg2),stack);
-}
-
void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2)
{
throw_error(allot_array_4(special_objects[OBJ_ERROR],
- tag_fixnum(error),arg1,arg2),ctx->callstack_top);
+ tag_fixnum(error),arg1,arg2));
}
void factor_vm::type_error(cell type, cell tagged)
general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object);
}
-void factor_vm::memory_protection_error(cell addr, stack_frame *stack)
+void factor_vm::memory_protection_error(cell addr)
{
/* Retain and call stack underflows are not supposed to happen */
if(ctx->datastack_seg->underflow_p(addr))
- general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object,stack);
+ general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object);
else if(ctx->datastack_seg->overflow_p(addr))
- general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object,stack);
+ general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object);
else if(ctx->retainstack_seg->underflow_p(addr))
- general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object,stack);
+ general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object);
else if(ctx->retainstack_seg->overflow_p(addr))
- general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack);
+ general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object);
else if(ctx->callstack_seg->underflow_p(addr))
- general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object,stack);
+ general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object);
else if(ctx->callstack_seg->overflow_p(addr))
- general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack);
+ general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object);
else
- general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object,stack);
+ general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object);
}
-void factor_vm::signal_error(cell signal, stack_frame *stack)
+void factor_vm::signal_error(cell signal)
{
- general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object,stack);
+ general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object);
}
void factor_vm::divide_by_zero_error()
general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object);
}
-void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack)
+void factor_vm::fp_trap_error(unsigned int fpu_status)
{
- general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack);
+ general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object);
}
/* For testing purposes */
void factor_vm::memory_signal_handler_impl()
{
- memory_protection_error(signal_fault_addr,signal_callstack_top);
+ scrub_return_address();
+ memory_protection_error(signal_fault_addr);
}
void memory_signal_handler_impl()
void factor_vm::misc_signal_handler_impl()
{
- signal_error(signal_number,signal_callstack_top);
+ scrub_return_address();
+ signal_error(signal_number);
}
void misc_signal_handler_impl()
void factor_vm::fp_signal_handler_impl()
{
- fp_trap_error(signal_fpu_status,signal_callstack_top);
+ /* Clear pending exceptions to avoid getting stuck in a loop */
+ set_fpu_state(get_fpu_state());
+
+ scrub_return_address();
+ fp_trap_error(signal_fpu_status);
}
void fp_signal_handler_impl()
p->callstack_size = 128 * sizeof(cell);
#endif
- p->code_size = 8 * sizeof(cell);
+ p->code_size = 64;
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
p->tenured_size = 24 * sizeof(cell);
void factor_vm::collect_sweep_impl()
{
- current_gc->event->started_data_sweep();
+ gc_event *event = current_gc->event;
+
+ if(event) event->started_data_sweep();
data->tenured->sweep();
- current_gc->event->ended_data_sweep();
+ if(event) event->ended_data_sweep();
update_code_roots_for_sweep();
- current_gc->event->started_code_sweep();
+ if(event) event->started_code_sweep();
code->allocator->sweep();
- current_gc->event->ended_code_sweep();
+ if(event) event->ended_code_sweep();
}
void factor_vm::collect_full(bool trace_contexts_p)
if(data->low_memory_p())
{
- current_gc->op = collect_growing_heap_op;
- current_gc->event->op = collect_growing_heap_op;
+ set_current_gc_op(collect_growing_heap_op);
collect_growing_heap(0,trace_contexts_p);
}
else if(data->high_fragmentation_p())
{
- current_gc->op = collect_compact_op;
- current_gc->event->op = collect_compact_op;
+ set_current_gc_op(collect_compact_op);
collect_compact_impl(trace_contexts_p);
}
total_time = (cell)(nano_count() - start_time);
}
-gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_), start_time(nano_count())
+gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_)
{
- event = new gc_event(op,parent);
+ if(parent->gc_events)
+ {
+ event = new gc_event(op,parent);
+ start_time = nano_count();
+ }
+ else
+ event = NULL;
}
gc_state::~gc_state()
{
- delete event;
- event = NULL;
+ if(event)
+ {
+ delete event;
+ event = NULL;
+ }
}
void factor_vm::end_gc()
{
- current_gc->event->ended_gc(this);
- if(gc_events) gc_events->push_back(*current_gc->event);
- delete current_gc->event;
- current_gc->event = NULL;
+ if(gc_events)
+ {
+ current_gc->event->ended_gc(this);
+ gc_events->push_back(*current_gc->event);
+ }
}
void factor_vm::start_gc_again()
break;
}
- current_gc->event = new gc_event(current_gc->op,this);
+ if(gc_events)
+ current_gc->event = new gc_event(current_gc->op,this);
+}
+
+void factor_vm::set_current_gc_op(gc_op op)
+{
+ current_gc->op = op;
+ if(gc_events) current_gc->event->op = op;
}
void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
{
try
{
- current_gc->event->op = current_gc->op;
+ if(gc_events) current_gc->event->op = current_gc->op;
switch(current_gc->op)
{
collect_aging();
if(data->high_fragmentation_p())
{
- current_gc->op = collect_full_op;
- current_gc->event->op = collect_full_op;
+ set_current_gc_op(collect_full_op);
collect_full(trace_contexts_p);
}
break;
collect_to_tenured();
if(data->high_fragmentation_p())
{
- current_gc->op = collect_full_op;
- current_gc->event->op = collect_full_op;
+ set_current_gc_op(collect_full_op);
collect_full(trace_contexts_p);
}
break;
cell compaction_time;
u64 temp_time;
- explicit gc_event(gc_op op_, factor_vm *parent);
+ gc_event(gc_op op_, factor_vm *parent);
void started_card_scan();
void ended_card_scan(cell cards_scanned_, cell decks_scanned_);
void started_code_scan();
{
MACH_STACK_POINTER(thread_state) = (cell)fix_callstack_top((stack_frame *)MACH_STACK_POINTER(thread_state));
- signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
+ ctx->callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
/* Now we point the program counter at the right handler function. */
if(exception == EXC_BAD_ACCESS)
collector.trace_roots();
collector.trace_contexts();
- current_gc->event->started_card_scan();
+ gc_event *event = current_gc->event;
+
+ if(event) event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_nursery,
simple_unmarker(card_points_to_nursery));
card_points_to_nursery,
full_unmarker());
}
- current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+ if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
- current_gc->event->started_code_scan();
+ if(event) event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_nursery);
- current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+ if(event) event->ended_code_scan(collector.code_blocks_scanned);
collector.cheneys_algorithm();
C_TO_FACTOR_WORD,
LAZY_JIT_COMPILE_WORD,
UNWIND_NATIVE_FRAMES_WORD,
+ GET_FPU_STATE_WORD,
+ SET_FPU_STATE_WORD,
/* Incremented on every modify-code-heap call; invalidates call( inline
caching */
UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap));
UAP_PROGRAM_COUNTER(uap) = (cell)handler;
- signal_callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
+ ctx->callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
+void ignore_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+}
+
void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
factor_vm *vm = current_vm();
sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
sigaction_safe(SIGILL,&misc_sigaction,NULL);
+ /* We don't use SA_IGN here because then the ignore action is inherited
+ by subprocesses, which we don't want. There is a unit test in
+ io.launcher.unix for this. */
memset(&ignore_sigaction,0,sizeof(struct sigaction));
sigemptyset(&ignore_sigaction.sa_mask);
- ignore_sigaction.sa_handler = SIG_IGN;
+ ignore_sigaction.sa_sigaction = ignore_signal_handler;
+ ignore_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK;
sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
}
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return pthread_self(); }
-void signal_handler(int signal, siginfo_t* siginfo, void* uap);
-void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-
u64 nano_count();
void sleep_nanos(u64 nsec);
void open_console();
LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
- signal_callstack_top = (stack_frame *)c->ESP;
+ ctx->callstack_top = (stack_frame *)c->ESP;
switch (e->ExceptionCode)
{
signal_fpu_status = fpu_status(MXCSR(c));
#else
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
+
+ /* This seems to have no effect */
X87SW(c) = 0;
#endif
MXCSR(c) &= 0xffffffc0;
collector.trace_roots();
collector.trace_contexts();
- current_gc->event->started_card_scan();
+ gc_event *event = current_gc->event;
+
+ if(event) event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
full_unmarker());
- current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+ if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
- current_gc->event->started_code_scan();
+ if(event) event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_aging);
- current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+ if(event) event->ended_code_scan(collector.code_blocks_scanned);
collector.tenure_reachable_objects();
/* Is call counting enabled? */
bool profiling_p;
- /* Global variables used to pass fault handler state from signal handler to
- user-space */
+ /* Global variables used to pass fault handler state from signal handler
+ to VM */
cell signal_number;
cell signal_fault_addr;
unsigned int signal_fpu_status;
- stack_frame *signal_callstack_top;
/* GC is off during heap walking */
bool gc_off;
void primitive_profiling();
// errors
- void throw_error(cell error, stack_frame *stack);
- void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack);
+ void throw_error(cell error);
void general_error(vm_error_type error, cell arg1, cell arg2);
void type_error(cell type, cell tagged);
void not_implemented_error();
- void memory_protection_error(cell addr, stack_frame *stack);
- void signal_error(cell signal, stack_frame *stack);
+ void memory_protection_error(cell addr);
+ void signal_error(cell signal);
void divide_by_zero_error();
- void fp_trap_error(unsigned int fpu_status, stack_frame *stack);
+ void fp_trap_error(unsigned int fpu_status);
void primitive_unimplemented();
void memory_signal_handler_impl();
void misc_signal_handler_impl();
// gc
void end_gc();
+ void set_current_gc_op(gc_op op);
void start_gc_again();
void update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set);
void collect_nursery();
cell frame_scan(stack_frame *frame);
cell frame_offset(stack_frame *frame);
void set_frame_offset(stack_frame *frame, cell offset);
+ void scrub_return_address();
void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
void primitive_innermost_stack_frame_executing();
// entry points
void c_to_factor(cell quot);
+ template<typename Func> Func get_entry_point(cell n);
void unwind_native_frames(cell quot, stack_frame *to);
+ cell get_fpu_state();
+ void set_fpu_state(cell state);
// factor
void default_parameters(vm_parameters *p);
projects / factor.git / commitdiff