kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
-CONSTANT: url URL" http://factorcode.org/images/latest/"
+CONSTANT: url URL" http://downloads.factorcode.org/images/latest/"
: download-checksums ( -- alist )
url "checksums.txt" >url derive-url http-get nip
: destination ( -- dest )
upload-images-destination get
- "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+ "slava_pestov@downloads.factorcode.org:downloads.factorcode.org/images/latest/"
or ;
: checksums ( -- temp ) "checksums.txt" temp-file ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: channels concurrency.distributed help.markup help.syntax
-io.servers.connection ;
+io.servers ;
IN: channels.remote
HELP: <remote-channel>
FROM: namespaces => set ;
IN: compiler.cfg.alias-analysis
-! We try to eliminate redundant slot operations using some simple heuristics.
+! We try to eliminate redundant slot operations using some
+! simple heuristics.
!
! All heap-allocated objects which are loaded from the stack, or
! other object slots are pessimistically assumed to belong to
2dup eq? [ 2drop ] [
[ ac>vregs ] dip
[ vregs>acs get '[ [ _ ] dip _ set-at ] each ]
- [ acs>vregs get at push-all ]
+ [ ac>vregs push-all ]
2bi
] if ;
#! Set alias class of newly-seen vreg.
vreg vregs>acs get key? [ vreg vreg-not-new ] when
ac vreg vregs>acs get set-at
- vreg ac acs>vregs get push-at ;
+ vreg ac ac>vregs push ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
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
-! can callback arbitrary Factor code
-UNION: factor-call-insn
+UNION: alien-call-insn
##alien-invoke
##alien-indirect
##alien-assembly ;
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+alien-call-insn ;
+
! Instructions that contain subroutine calls to functions which
! allocate memory
UNION: gc-map-insn
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 ;
+TUPLE: gc-map scrub-d scrub-r gc-roots derived-roots ;
: <gc-map> ( -- gc-map ) gc-map new ;
-UNION: alien-call-insn
-##alien-invoke
-##alien-indirect
-##alien-assembly ;
-
! 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 ;
+: assign-gc-roots ( gc-map -- )
+ [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
+
+: assign-derived-roots ( gc-map -- )
+ [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
+
M: gc-map-insn assign-registers-in-insn
[ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
- [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ]
+ [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
bi ;
M: insn assign-registers-in-insn drop ;
[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
-[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
\ No newline at end of file
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
+
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 0 D 0 }
+ T{ ##tagged>integer f 1 0 }
+ T{ ##call-gc f T{ gc-map } }
+ T{ ##replace f 0 D 0 }
+ T{ ##call-gc f T{ gc-map } }
+ T{ ##replace f 1 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+H{
+ { 0 tagged-rep }
+ { 1 int-rep }
+} representations set
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-live-sets ] unit-test
+
+[ V{ { 1 0 } } ] [ 1 get instructions>> 2 swap nth gc-map>> derived-roots>> ] unit-test
+
+[ { 0 } ] [ 1 get instructions>> 2 swap nth gc-map>> gc-roots>> ] unit-test
+
+[ V{ { 1 0 } } ] [ 1 get instructions>> 4 swap nth gc-map>> derived-roots>> ] unit-test
+
+[ { 0 } ] [ 1 get instructions>> 4 swap nth gc-map>> gc-roots>> ] unit-test
\ No newline at end of file
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs fry deques dlists namespaces
-sequences sets compiler.cfg compiler.cfg.def-use
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.utilities compiler.cfg.predecessors
-compiler.cfg.rpo cpu.architecture ;
+USING: arrays kernel accessors assocs fry locals combinators
+deques dlists namespaces sequences sets compiler.cfg
+compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.utilities
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture ;
FROM: namespaces => set ;
IN: compiler.cfg.liveness
-! See http://en.wikipedia.org/wiki/Liveness_analysis
+! Similar to http://en.wikipedia.org/wiki/Liveness_analysis,
+! with three additions:
+! 1) With SSA, it is not sufficient to have a single live-in set
+! per block. There is also there is an edge-live-in set per
+! edge, consisting of phi inputs from each predecessor.
+! 2) Liveness analysis annotates call sites with GC maps
+! indicating the spill slots in the stack frame that contain
+! tagged pointers, and thus have to be visited if a GC occurs
+! inside the call.
+! 3) GC maps can contain derived pointers. A derived pointer is
+! a pointer into the middle of a data heap object. Each derived
+! pointer has a base pointer, to keep it up to date when objects
+! are moved by the garbage collector. This extends live
+! intervals and inserts new ##phi instructions.
SYMBOL: live-ins
: live-in ( bb -- set )
: edge-live-in ( predecessor basic-block -- set )
edge-live-ins get at at ;
+SYMBOL: base-pointers
+
GENERIC: visit-insn ( live-set insn -- live-set )
: kill-defs ( live-set insn -- live-set )
: gen-uses ( live-set insn -- live-set )
uses-vregs [ over conjoin ] each ; inline
-M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+M: vreg-insn visit-insn
+ [ kill-defs ] [ gen-uses ] bi ;
-! Our liveness analysis annotates call sites with GC maps
-! indicating the spill slots in the stack frame that contain
-! tagged pointers, and thus have to be visited if a GC occurs
-! inside the call.
+DEFER: lookup-base-pointer
+
+GENERIC: lookup-base-pointer* ( insn -- vreg/f )
+
+M: ##tagged>integer lookup-base-pointer* src>> ;
+
+M: ##unbox-any-c-ptr lookup-base-pointer*
+ ! If the input to unbox-any-c-ptr was an alien and not a
+ ! byte array, then the derived pointer will be outside of
+ ! the data heap. The GC has to handle this case and ignore
+ ! it.
+ src>> ;
+
+M: ##copy lookup-base-pointer* src>> lookup-base-pointer ;
+
+M: ##add-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+
+M: ##sub-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+
+M: ##add lookup-base-pointer*
+ ! If both operands have a base pointer, then the user better
+ ! not be doing memory reads and writes on the object, since
+ ! we don't give it a base pointer in that case at all.
+ [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
+
+M: ##sub lookup-base-pointer*
+ src1>> lookup-base-pointer ;
+
+M: vreg-insn lookup-base-pointer* drop f ;
+
+: lookup-base-pointer ( vreg -- vreg/f )
+ base-pointers get [ insn-of lookup-base-pointer* ] cache ;
+
+:: visit-derived-root ( vreg derived-roots gc-roots -- )
+ vreg lookup-base-pointer :> base
+ base [
+ { vreg base } derived-roots push
+ base gc-roots adjoin
+ ] when ;
+
+: visit-gc-root ( vreg derived-roots gc-roots -- )
+ pick rep-of {
+ { tagged-rep [ nip adjoin ] }
+ { int-rep [ visit-derived-root ] }
+ [ 2drop 2drop ]
+ } case ;
+
+: gc-roots ( live-set -- derived-roots gc-roots )
+ V{ } clone HS{ } clone
+ [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
+ members ;
: fill-gc-map ( live-set insn -- live-set )
- representations get [
- gc-map>> over keys
- [ rep-of tagged-rep? ] filter
- >>gc-roots
- ] when
- drop ;
+ [ representations get [ dup gc-roots ] [ f f ] if ] dip
+ gc-map>> [ gc-roots<< ] [ derived-roots<< ] bi ;
M: gc-map-insn visit-insn
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
: transfer-liveness ( live-set instructions -- live-set' )
[ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
-: local-live-in ( instructions -- live-set )
- [ H{ } ] dip transfer-liveness keys ;
-
SYMBOL: work-list
: add-to-work-list ( basic-blocks -- )
: compute-live-sets ( cfg -- )
needs-predecessors
+ dup compute-insns
<hashed-dlist> work-list set
H{ } clone live-ins set
H{ } clone edge-live-ins set
H{ } clone live-outs set
+ H{ } clone base-pointers set
post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
{ scrub-d-count uint }
{ scrub-r-count uint }
{ gc-root-count uint }
+{ derived-root-count uint }
{ return-address-count uint } ;
SINGLETON: fake-cpu
fake-cpu \ cpu set
-M: fake-cpu gc-root-offsets ;
+M: fake-cpu gc-root-offset ;
[ ] [
[
50 <byte-array> %
- T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
+ T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
emit-gc-info
] B{ } make
f t f t
} underlying>> %
- ! Return addresses - 4 bytes
+ ! Derived pointers
+ uint-array{ -1 -1 4 } underlying>> %
+
+ ! Return addresses
uint-array{ 100 } underlying>> %
! GC info footer - 16 bytes
{ scrub-d-count 5 }
{ scrub-r-count 2 }
{ gc-root-count 4 }
+ { derived-root-count 3 }
{ return-address-count 1 }
} (underlying)>> %
] B{ } make
! See http://factorcode.org/license.txt for BSD license.
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
+sequences words quotations strings sorting 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 ;
! - <scrubbed data stack locations>
! - <scrubbed retain stack locations>
! - <GC root spill slots>
+! uint[] <base pointers>
! 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>
-
+! uint <largest derived root spill slot>
+! int <number of return addresses>
+!
SYMBOLS: return-addresses gc-maps ;
: gc-map-needed? ( gc-map -- ? )
[ scrub-d>> empty? ]
[ scrub-r>> empty? ]
[ gc-roots>> empty? ]
+ [ derived-roots>> empty? ]
} 1&& not
] when ;
compiled-offset return-addresses get push
] [ drop ] if ;
+: longest ( seqs -- n )
+ [ length ] [ max ] map-reduce ;
+
: emit-scrub ( seqs -- n )
! seqs is a sequence of sequences of 0/1
- dup [ length ] [ max ] map-reduce
+ dup longest
[ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
: integers>bits ( seq n -- bit-array )
<bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
+: largest-spill-slot ( seqs -- n )
+ [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
+
: 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
+ dup largest-spill-slot
[ '[ _ integers>bits % ] each ] keep ;
: emit-uint ( n -- )
building get push-uint ;
+: emit-uints ( n -- )
+ [ emit-uint ] each ;
+
+: gc-root-offsets ( gc-map -- offsets )
+ gc-roots>> [ gc-root-offset ] map ;
+
+: emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count )
+ [
+ gc-maps get {
+ [ [ scrub-d>> ] map emit-scrub ]
+ [ [ scrub-r>> ] map emit-scrub ]
+ [ [ gc-root-offsets ] map emit-gc-roots ]
+ } cleave
+ ] ?{ } make underlying>> % ;
+
+: emit-base-table ( alist longest -- )
+ -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
+
+: derived-root-offsets ( gc-map -- offsets )
+ derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
+
+: emit-base-tables ( -- count )
+ gc-maps get [ derived-root-offsets ] map
+ dup [ keys ] map largest-spill-slot
+ [ '[ _ emit-base-table ] each ] keep ;
+
+: emit-return-addresses ( -- )
+ return-addresses get emit-uints ;
+
: 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@
+ emit-gc-info-bitmaps
+ emit-base-tables
+ emit-return-addresses
+ 4array emit-uints
return-addresses get length emit-uint
] if
] B{ } make ;
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
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators vectors grouping
make alien.c-types combinators.short-circuit math.order
-math.libm math.parser math.functions alien.syntax ;
+math.libm math.parser math.functions alien.syntax memory
+stack-checker ;
FROM: math => float ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
] unit-test
+! Alias analysis bug
+[ t ] [
+ [
+ 10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+ ] compile-call
+] unit-test
+
! GC root offsets were computed wrong on x86
: gc-root-messup ( a -- b )
dup [
[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
-! Alias analysis bug
-[ t ] [
- [
- 10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
- ] 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
+
+! GC maps must support derived pointers
+: (derived-pointer-test-1) ( -- byte-array )
+ 2 <byte-array> ;
+
+: derived-pointer-test-1 ( -- byte-array )
+ ! A callback used below
+ void { } cdecl [ compact-gc ] alien-callback
+ ! Put the construction in a word since instruction selection
+ ! eliminates the untagged pointer entirely if the value is a
+ ! byte array
+ (derived-pointer-test-1) { c-ptr } declare
+ ! Store into an array, an untagged pointer to the payload
+ ! is now an available expression
+ 123 over 0 set-alien-unsigned-1
+ ! GC, moving the array and derived pointer
+ swap void { } cdecl alien-indirect
+ ! Store into the array again
+ 231 over 1 set-alien-unsigned-1 ;
+
+[ B{ 123 231 } ] [ derived-pointer-test-1 ] unit-test
USING: tools.test concurrency.distributed kernel io.files
io.files.temp io.directories arrays io.sockets system calendar
combinators threads math sequences concurrency.messaging
-continuations accessors prettyprint io.servers.connection ;
+continuations accessors prettyprint io.servers ;
FROM: concurrency.messaging => receive send ;
IN: concurrency.distributed.tests
test-node-client "thread-a" <remote-thread> send
100 seconds receive-timeout
] unit-test
-] with-threaded-server
\ No newline at end of file
+] with-threaded-server
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
-io.servers.connection io.encodings.binary assocs init
+io.servers io.encodings.binary assocs init
arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
! %store-memory work
HOOK: complex-addressing? cpu ( -- ? )
-HOOK: gc-root-offsets cpu ( seq -- seq' )
+HOOK: gc-root-offset cpu ( spill-slot -- n )
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
{ cc/<= [ label JG ] }
} case ;
-M: x86 gc-root-offsets
- [ n>> spill-offset special-offset cell + cell /i ] map f like ;
+M: x86 gc-root-offset
+ n>> spill-offset special-offset cell + cell /i ;
M: x86 %call-gc ( gc-map -- )
\ minor-gc %call
USING: calendar ftp.server io.encodings.ascii io.files
io.files.unique namespaces threads tools.test kernel
-io.servers.connection ftp.client accessors urls
+io.servers ftp.client accessors urls
io.pathnames io.directories sequences fry io.backend
continuations ;
FROM: ftp.client => ftp-get ;
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
+io.servers 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 ;
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
-accessors io.sockets io.servers.connection prettyprint\r
+accessors io.sockets io.servers prettyprint\r
io.streams.string io.files io.files.temp io.directories\r
splitting destructors sequences db db.tuples db.sqlite\r
continuations urls math.parser furnace furnace.utilities ;\r
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
: each-responder ( quot -- )
nested-responders swap each ; inline
-: base-path ( string -- pair )
+ERROR: no-such-responder responder ;
+
+: base-path ( string -- seq )
dup responder-nesting get
[ second class superclasses [ name>> = ] with any? ] with find nip
- [ first ] [ "No such responder: " swap append throw ] ?if ;
+ [ first ] [ no-such-responder ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
! Live-fire exercise
USING: http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth furnace.auth.login furnace.db
-io.servers.connection io.files io.files.temp io.directories io
+io.servers io.files io.files.temp io.directories io
threads
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel io.servers.connection ;
+USING: namespaces assocs kernel io.servers ;
IN: http.server.remapping
SYMBOL: port-remapping
USING: help.markup help.syntax io.streams.string quotations strings urls
-http vocabs.refresh math io.servers.connection assocs ;
+http vocabs.refresh math io.servers assocs ;
IN: http.server
HELP: trivial-responder
} ;
ARTICLE: "http.server" "HTTP server"
-"The " { $vocab-link "http.server" } " vocabulary implements an HTTP and HTTPS server on top of " { $vocab-link "io.servers.connection" } "."
+"The " { $vocab-link "http.server" } " vocabulary implements an HTTP and HTTPS server on top of " { $vocab-link "io.servers" } "."
{ $subsections
"http.server.responders"
"http.server.requests"
io.streams.limited
io.streams.string
io.streams.throwing
-io.servers.connection
+io.servers
io.timeouts
io.crlf
fry logging logging.insomniac calendar urls urls.encoding
--- /dev/null
+Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: calendar classes concurrency.semaphores help.markup
-help.syntax io io.sockets io.sockets.secure math quotations ;
-IN: io.servers.connection
-
-ARTICLE: "server-config" "Threaded server configuration"
-"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } "."
-{ $subsections
- "server-config-logging"
- "server-config-listen"
- "server-config-limit"
- "server-config-stream"
- "server-config-handler"
-} ;
-
-ARTICLE: "server-config-logging" "Logging connections"
-"The " { $snippet "name" } " slot of a threaded server instance should be set to a string naming the logging service name to use. See " { $link "logging" } " for details." ;
-
-ARTICLE: "server-config-listen" "Setting ports to listen on"
-"The " { $snippet "insecure" } " slot of a threaded server instance contains an integer, an address specifier, or a sequence of address specifiers. Integer port numbers are interpreted as an " { $link inet4 } "/" { $link inet6 } " pair listening on all interfaces for given port number. All other address specifiers are interpeted as per " { $link "network-addressing" } "."
-$nl
-"The " { $snippet "secure" } " slot of a threaded server instance is interpreted in the same manner as the " { $snippet "insecure" } " slot, except that secure encrypted connections are then allowed. If this slot is set, the " { $snippet "secure-config" } " slot should also be set to a " { $link secure-config } " instance containing SSL server configuration. See " { $link "ssl-config" } " for details."
-$nl
-"Two utility words for producing address specifiers:"
-{ $subsections
- local-server
- internet-server
-} ;
-
-ARTICLE: "server-config-limit" "Limiting connections"
-"The " { $snippet "max-connections" } " slot is initially set to " { $link f } ", which disables connection limiting, but can be set to an integer specifying the maximum number of simultaneous connections."
-$nl
-"Another method to limit connections is to set the " { $snippet "semaphore" } " slot to a " { $link semaphore } ". The server will hold the semaphore while servicing the client connection."
-$nl
-"Setting the " { $snippet "max-connections" } " slot is equivalent to storing a semaphore with this initial count in the " { $snippet "semaphore" } " slot. The " { $snippet "semaphore" } " slot is useful for enforcing a maximum connection count shared between multiple threaded servers. See " { $link "concurrency.semaphores" } " for details." ;
-
-ARTICLE: "server-config-stream" "Client stream parameters"
-"The " { $snippet "encoding" } " and " { $snippet "timeout" } " slots of the threaded server can be set to an encoding descriptor or a " { $link duration } ", respectively. See " { $link "io.encodings" } " and " { $link "io.timeouts" } " for details." ;
-
-ARTICLE: "server-config-handler" "Client handler quotation"
-"The " { $snippet "handler" } " slot of a threaded server instance should be set to a quotation which handles client connections. Client handlers are run in their own thread, with the following variables rebound:"
-{ $list
- { $link input-stream }
- { $link output-stream }
- { $link local-address }
- { $link remote-address }
- { $link threaded-server }
-}
-"An alternate way to implement client handlers is to subclass " { $link threaded-server } ", and define a method on " { $link handle-client* } "."
-$nl
-"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
-
-ARTICLE: "server-examples" "Threaded server examples"
-"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
-
-ARTICLE: "io.servers.connection" "Threaded servers"
-"The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
-{ $subsections "server-examples" }
-"Creating threaded servers with client handler quotations:"
-{ $subsections <threaded-server> }
-"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
-{ $subsections
- threaded-server
- new-threaded-server
- handle-client*
-}
-"The server must be configured before it can be started."
-{ $subsections "server-config" }
-"Starting the server:"
-{ $subsections start-server }
-"Stopping the server:"
-{ $subsections stop-server }
-"Waiting for the server to stop:"
-{ $subsections wait-for-server }
-"Combinator for running a server:"
-{ $subsections with-threaded-server }
-"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
-{ $subsections
- stop-this-server
- secure-port
- insecure-port
-}
-"Additionally, the " { $link local-address } " and "
-{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ;
-
-ABOUT: "io.servers.connection"
-
-HELP: threaded-server
-{ $var-description "In client handlers, stores the current threaded server instance." }
-{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
-
-HELP: new-threaded-server
-{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
-{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
-
-HELP: <threaded-server>
-{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
-{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
-
-HELP: remote-address
-{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
-
-HELP: handle-client*
-{ $values { "threaded-server" threaded-server } }
-{ $contract "Handles a client connection. Default implementation calls quotation stored in the " { $snippet "handler" } " slot of the threaded server." } ;
-
-HELP: start-server
-{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server and returns after the server is fully running. Throws an error if any of the ports cannot be aquired." }
-{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
-
-HELP: stop-server
-{ $values { "threaded-server" threaded-server } }
-{ $description "Stops a threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
-
-HELP: wait-for-server
-{ $values { "threaded-server" threaded-server } }
-{ $description "Waits for a threaded server to stop serving new connections." } ;
-
-HELP: stop-this-server
-{ $description "Stops the current threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
-
-HELP: with-threaded-server
-{ $values
- { "threaded-server" threaded-server } { "quot" quotation }
-}
-{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
-
-HELP: secure-port
-{ $values { "n/f" { $maybe integer } } }
-{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
-{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
-
-HELP: insecure-port
-{ $values { "n/f" { $maybe integer } } }
-{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
-{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
+++ /dev/null
-USING: accessors calendar concurrency.promises fry io
-io.encodings.ascii io.servers.connection
-io.servers.connection.private io.sockets kernel namespaces
-sequences threads tools.test ;
-IN: io.servers.connection
-
-[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
-
-[ f ] [
- ascii <threaded-server>
- 25 internet-server >>insecure
- listen-on
- empty?
-] unit-test
-
-[ t ] [
- T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 }
- [ log-connection ] 2keep
- [ remote-address get = ] [ local-address get = ] bi*
- and
-] unit-test
-
-[ ] [ ascii <threaded-server> init-server drop ] unit-test
-
-[ 10 ] [
- ascii <threaded-server>
- 10 >>max-connections
- init-server semaphore>> count>>
-] unit-test
-
-[ "Hello world." ] [
- ascii <threaded-server>
- 5 >>max-connections
- 0 >>insecure
- [ "Hello world." write stop-this-server ] >>handler
- [
- "localhost" insecure-port <inet> ascii <client> drop stream-contents
- ] with-threaded-server
-] unit-test
-
-[ ] [
- ascii <threaded-server>
- 5 >>max-connections
- 0 >>insecure
- start-server [ '[ _ wait-for-server ] in-thread ] [ stop-server ] bi
-] unit-test
+++ /dev/null
-! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators
-combinators.short-circuit concurrency.combinators
-concurrency.count-downs concurrency.flags
-concurrency.semaphores continuations debugger destructors fry
-io io.sockets io.sockets.secure io.streams.duplex io.styles
-io.timeouts kernel logging make math math.parser namespaces
-present prettyprint random sequences sets strings threads ;
-FROM: namespaces => set ;
-IN: io.servers.connection
-
-TUPLE: threaded-server < identity-tuple
-name
-log-level
-secure
-insecure
-secure-config
-servers
-max-connections
-semaphore
-timeout
-encoding
-handler
-server-stopped ;
-
-SYMBOL: running-servers
-running-servers [ HS{ } clone ] initialize
-
-ERROR: server-already-running threaded-server ;
-
-ERROR: server-not-running threaded-server ;
-
-<PRIVATE
-
-: must-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-not-running ] unless ;
-
-: must-not-be-running ( threaded-server -- threaded-server )
- dup running-servers get in? [ server-already-running ] when ;
-
-: add-running-server ( threaded-server -- )
- must-not-be-running
- running-servers get adjoin ;
-
-: remove-running-server ( threaded-server -- )
- must-be-running
- running-servers get delete ;
-
-PRIVATE>
-
-: local-server ( port -- addrspec ) "localhost" swap <inet> ;
-
-: internet-server ( port -- addrspec ) f swap <inet> ;
-
-: new-threaded-server ( encoding class -- threaded-server )
- new
- "server" >>name
- DEBUG >>log-level
- <secure-config> >>secure-config
- 1 minutes >>timeout
- [ "No handler quotation" throw ] >>handler
- swap >>encoding ;
-
-: <threaded-server> ( encoding -- threaded-server )
- threaded-server new-threaded-server ;
-
-GENERIC: handle-client* ( threaded-server -- )
-
-<PRIVATE
-
-GENERIC: (>insecure) ( obj -- obj )
-
-M: inet (>insecure) ;
-M: inet4 (>insecure) ;
-M: inet6 (>insecure) ;
-M: local (>insecure) ;
-M: integer (>insecure) internet-server ;
-M: string (>insecure) internet-server ;
-M: array (>insecure) [ (>insecure) ] map ;
-M: f (>insecure) ;
-
-: >insecure ( obj -- seq )
- (>insecure) dup sequence? [ 1array ] unless ;
-
-: >secure ( addrspec -- addrspec' )
- >insecure
- [ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ] map ;
-
-: listen-on ( threaded-server -- addrspecs )
- [ secure>> >secure ] [ insecure>> >insecure ] bi append
- [ resolve-host ] map concat ;
-
-: accepted-connection ( remote local -- )
- [
- [ "remote: " % present % ", " % ]
- [ "local: " % present % ]
- bi*
- ] "" make
- \ accepted-connection NOTICE log-message ;
-
-: log-connection ( remote local -- )
- [ accepted-connection ]
- [ [ remote-address set ] [ local-address set ] bi* ]
- 2bi ;
-
-M: threaded-server handle-client* handler>> call( -- ) ;
-
-: handle-client ( client remote local -- )
- '[
- _ _ log-connection
- threaded-server get
- [ timeout>> timeouts ] [ handle-client* ] bi
- ] with-stream ;
-
-\ handle-client NOTICE add-error-logging
-
-: client-thread-name ( addrspec -- string )
- [ threaded-server get name>> ] dip
- unparse-short " connection from " glue ;
-
-: (accept-connection) ( server -- )
- [ accept ] [ addr>> ] bi
- [ '[ _ _ _ handle-client ] ]
- [ drop client-thread-name ] 2bi
- spawn drop ;
-
-: accept-connection ( server -- )
- threaded-server get semaphore>>
- [ [ (accept-connection) ] with-semaphore ]
- [ (accept-connection) ]
- if* ;
-
-: accept-loop ( server -- )
- [ accept-connection ] [ accept-loop ] bi ;
-
-: start-accept-loop ( server -- ) accept-loop ;
-
-\ start-accept-loop NOTICE add-error-logging
-
-: init-server ( threaded-server -- threaded-server )
- <flag> >>server-stopped
- dup semaphore>> [
- dup max-connections>> [
- <semaphore> >>semaphore
- ] when*
- ] unless ;
-
-ERROR: no-ports-configured threaded-server ;
-
-: (make-servers) ( theaded-server addrspecs -- servers )
- swap encoding>>
- '[ [ _ <server> |dispose ] map ] with-destructors ;
-
-: set-servers ( threaded-server -- threaded-server )
- dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
- >>servers ;
-
-: server-thread-name ( threaded-server addrspec -- string )
- [ name>> ] [ addr>> present ] bi* " server on " glue ;
-
-: (start-server) ( threaded-server -- )
- init-server
- dup threaded-server [
- [ ] [ name>> ] bi
- [
- set-servers
- dup add-running-server
- dup servers>>
- [
- [ nip '[ _ [ start-accept-loop ] with-disposal ] ]
- [ server-thread-name ] 2bi spawn drop
- ] with each
- ] with-logging
- ] with-variable ;
-
-PRIVATE>
-
-: start-server ( threaded-server -- threaded-server )
- #! Only create a secure-context if we want to listen on
- #! a secure port, otherwise start-server won't work at
- #! all if SSL is not available.
- dup dup secure>> [
- dup secure-config>> [
- (start-server)
- ] with-secure-context
- ] [
- (start-server)
- ] if ;
-
-: server-running? ( threaded-server -- ? )
- server-stopped>> [ value>> not ] [ f ] if* ;
-
-: stop-server ( threaded-server -- )
- dup server-running? [
- [ [ f ] change-servers drop dispose-each ]
- [ remove-running-server ]
- [ server-stopped>> raise-flag ] tri
- ] [
- drop
- ] if ;
-
-: stop-this-server ( -- )
- threaded-server get stop-server ;
-
-: wait-for-server ( threaded-server -- )
- server-stopped>> wait-for-flag ;
-
-: with-threaded-server ( threaded-server quot -- )
- [ start-server ] dip over
- '[
- [ _ threaded-server _ with-variable ]
- [ _ stop-server ]
- [ ] cleanup
- ] call ; inline
-
-<PRIVATE
-
-: first-port ( quot -- n/f )
- [ threaded-server get servers>> ] dip
- filter [ f ] [ first addr>> port>> ] if-empty ; inline
-
-PRIVATE>
-
-: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
-
-: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
-
-: secure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? ] filter random ;
-
-: insecure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
-
-: server. ( threaded-server -- )
- [ [ "=== " write name>> ] [ ] bi write-object nl ]
- [ servers>> [ addr>> present print ] each ] bi ;
-
-: all-servers ( -- sequence )
- running-servers get-global members ;
-
-: get-servers-named ( string -- sequence )
- [ all-servers ] dip '[ name>> _ = ] filter ;
-
-: servers. ( -- )
- all-servers [ server. ] each ;
-
-: stop-all-servers ( -- )
- all-servers [ stop-server ] each ;
+++ /dev/null
-Multi-threaded TCP/IP servers
--- /dev/null
+USING: calendar classes concurrency.semaphores help.markup
+help.syntax io io.sockets io.sockets.secure math quotations ;
+IN: io.servers
+
+ARTICLE: "server-config" "Threaded server configuration"
+"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } "."
+{ $subsections
+ "server-config-logging"
+ "server-config-listen"
+ "server-config-limit"
+ "server-config-stream"
+ "server-config-handler"
+} ;
+
+ARTICLE: "server-config-logging" "Logging connections"
+"The " { $snippet "name" } " slot of a threaded server instance should be set to a string naming the logging service name to use. See " { $link "logging" } " for details." ;
+
+ARTICLE: "server-config-listen" "Setting ports to listen on"
+"The " { $snippet "insecure" } " slot of a threaded server instance contains an integer, an address specifier, or a sequence of address specifiers. Integer port numbers are interpreted as an " { $link inet4 } "/" { $link inet6 } " pair listening on all interfaces for given port number. All other address specifiers are interpeted as per " { $link "network-addressing" } "."
+$nl
+"The " { $snippet "secure" } " slot of a threaded server instance is interpreted in the same manner as the " { $snippet "insecure" } " slot, except that secure encrypted connections are then allowed. If this slot is set, the " { $snippet "secure-config" } " slot should also be set to a " { $link secure-config } " instance containing SSL server configuration. See " { $link "ssl-config" } " for details."
+$nl
+"Two utility words for producing address specifiers:"
+{ $subsections
+ local-server
+ internet-server
+} ;
+
+ARTICLE: "server-config-limit" "Limiting connections"
+"The " { $snippet "max-connections" } " slot is initially set to " { $link f } ", which disables connection limiting, but can be set to an integer specifying the maximum number of simultaneous connections."
+$nl
+"Another method to limit connections is to set the " { $snippet "semaphore" } " slot to a " { $link semaphore } ". The server will hold the semaphore while servicing the client connection."
+$nl
+"Setting the " { $snippet "max-connections" } " slot is equivalent to storing a semaphore with this initial count in the " { $snippet "semaphore" } " slot. The " { $snippet "semaphore" } " slot is useful for enforcing a maximum connection count shared between multiple threaded servers. See " { $link "concurrency.semaphores" } " for details." ;
+
+ARTICLE: "server-config-stream" "Client stream parameters"
+"The " { $snippet "encoding" } " and " { $snippet "timeout" } " slots of the threaded server can be set to an encoding descriptor or a " { $link duration } ", respectively. See " { $link "io.encodings" } " and " { $link "io.timeouts" } " for details." ;
+
+ARTICLE: "server-config-handler" "Client handler quotation"
+"The " { $snippet "handler" } " slot of a threaded server instance should be set to a quotation which handles client connections. Client handlers are run in their own thread, with the following variables rebound:"
+{ $list
+ { $link input-stream }
+ { $link output-stream }
+ { $link local-address }
+ { $link remote-address }
+ { $link threaded-server }
+}
+"An alternate way to implement client handlers is to subclass " { $link threaded-server } ", and define a method on " { $link handle-client* } "."
+$nl
+"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
+
+ARTICLE: "server-examples" "Threaded server examples"
+"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
+
+ARTICLE: "io.servers" "Threaded servers"
+"The " { $vocab-link "io.servers" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
+{ $subsections "server-examples" }
+"Creating threaded servers with client handler quotations:"
+{ $subsections <threaded-server> }
+"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
+{ $subsections
+ threaded-server
+ new-threaded-server
+ handle-client*
+}
+"The server must be configured before it can be started."
+{ $subsections "server-config" }
+"Starting the server:"
+{ $subsections start-server }
+"Stopping the server:"
+{ $subsections stop-server }
+"Waiting for the server to stop:"
+{ $subsections wait-for-server }
+"Combinator for running a server:"
+{ $subsections with-threaded-server }
+"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
+{ $subsections
+ stop-this-server
+ secure-port
+ insecure-port
+}
+"Additionally, the " { $link local-address } " and "
+{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ;
+
+ABOUT: "io.servers"
+
+HELP: threaded-server
+{ $var-description "In client handlers, stores the current threaded server instance." }
+{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
+
+HELP: new-threaded-server
+{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
+{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
+
+HELP: <threaded-server>
+{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
+{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
+
+HELP: remote-address
+{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
+
+HELP: handle-client*
+{ $values { "threaded-server" threaded-server } }
+{ $contract "Handles a client connection. Default implementation calls quotation stored in the " { $snippet "handler" } " slot of the threaded server." } ;
+
+HELP: start-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Starts a threaded server and returns after the server is fully running. Throws an error if any of the ports cannot be aquired." }
+{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
+
+HELP: stop-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Stops a threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
+
+HELP: wait-for-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Waits for a threaded server to stop serving new connections." } ;
+
+HELP: stop-this-server
+{ $description "Stops the current threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
+
+HELP: with-threaded-server
+{ $values
+ { "threaded-server" threaded-server } { "quot" quotation }
+}
+{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
+
+HELP: secure-port
+{ $values { "n/f" { $maybe integer } } }
+{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
+{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
+
+HELP: insecure-port
+{ $values { "n/f" { $maybe integer } } }
+{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
+{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
--- /dev/null
+USING: accessors calendar concurrency.promises fry io
+io.encodings.ascii io.servers
+io.servers.private io.sockets kernel namespaces
+sequences threads tools.test ;
+IN: io.servers
+
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
+
+[ f ] [
+ ascii <threaded-server>
+ 25 internet-server >>insecure
+ listen-on
+ empty?
+] unit-test
+
+[ t ] [
+ T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 }
+ [ log-connection ] 2keep
+ [ remote-address get = ] [ local-address get = ] bi*
+ and
+] unit-test
+
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
+
+[ 10 ] [
+ ascii <threaded-server>
+ 10 >>max-connections
+ init-server semaphore>> count>>
+] unit-test
+
+[ "Hello world." ] [
+ ascii <threaded-server>
+ 5 >>max-connections
+ 0 >>insecure
+ [ "Hello world." write stop-this-server ] >>handler
+ [
+ "localhost" insecure-port <inet> ascii <client> drop stream-contents
+ ] with-threaded-server
+] unit-test
+
+[ ] [
+ ascii <threaded-server>
+ 5 >>max-connections
+ 0 >>insecure
+ start-server [ '[ _ wait-for-server ] in-thread ] [ stop-server ] bi
+] unit-test
--- /dev/null
+! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar combinators
+combinators.short-circuit concurrency.combinators
+concurrency.count-downs concurrency.flags
+concurrency.semaphores continuations debugger destructors fry
+io io.sockets io.sockets.secure io.streams.duplex io.styles
+io.timeouts kernel logging make math math.parser namespaces
+present prettyprint random sequences sets strings threads ;
+FROM: namespaces => set ;
+IN: io.servers
+
+TUPLE: threaded-server < identity-tuple
+name
+log-level
+secure
+insecure
+secure-config
+servers
+max-connections
+semaphore
+timeout
+encoding
+handler
+server-stopped
+secure-context ;
+
+SYMBOL: running-servers
+running-servers [ HS{ } clone ] initialize
+
+ERROR: server-already-running threaded-server ;
+
+ERROR: server-not-running threaded-server ;
+
+<PRIVATE
+
+: must-be-running ( threaded-server -- threaded-server )
+ dup running-servers get in? [ server-not-running ] unless ;
+
+: must-not-be-running ( threaded-server -- threaded-server )
+ dup running-servers get in? [ server-already-running ] when ;
+
+: add-running-server ( threaded-server -- )
+ must-not-be-running
+ running-servers get adjoin ;
+
+: remove-running-server ( threaded-server -- )
+ must-be-running
+ running-servers get delete ;
+
+PRIVATE>
+
+: local-server ( port -- addrspec ) "localhost" swap <inet> ;
+
+: internet-server ( port -- addrspec ) f swap <inet> ;
+
+: new-threaded-server ( encoding class -- threaded-server )
+ new
+ "server" >>name
+ DEBUG >>log-level
+ <secure-config> >>secure-config
+ 1 minutes >>timeout
+ [ "No handler quotation" throw ] >>handler
+ swap >>encoding ;
+
+: <threaded-server> ( encoding -- threaded-server )
+ threaded-server new-threaded-server ;
+
+GENERIC: handle-client* ( threaded-server -- )
+
+<PRIVATE
+
+GENERIC: >insecure ( obj -- obj )
+
+M: inet >insecure 1array ;
+M: inet4 >insecure 1array ;
+M: inet6 >insecure 1array ;
+M: local >insecure 1array ;
+M: integer >insecure internet-server 1array ;
+M: string >insecure internet-server 1array ;
+M: array >insecure [ >insecure ] map ;
+M: f >insecure ;
+
+: >secure ( addrspec -- addrspec' )
+ >insecure
+ [ dup secure? [ <secure> ] unless ] map ;
+
+: listen-on ( threaded-server -- addrspecs )
+ [ secure>> >secure ] [ insecure>> >insecure ] bi append
+ [ resolve-host ] map concat ;
+
+: accepted-connection ( remote local -- )
+ [
+ [ "remote: " % present % ", " % ]
+ [ "local: " % present % ]
+ bi*
+ ] "" make
+ \ accepted-connection NOTICE log-message ;
+
+: log-connection ( remote local -- )
+ [ accepted-connection ]
+ [ [ remote-address set ] [ local-address set ] bi* ]
+ 2bi ;
+
+M: threaded-server handle-client* handler>> call( -- ) ;
+
+: handle-client ( client remote local -- )
+ '[
+ _ _ log-connection
+ threaded-server get
+ [ timeout>> timeouts ] [ handle-client* ] bi
+ ] with-stream ;
+
+\ handle-client NOTICE add-error-logging
+
+: client-thread-name ( addrspec -- string )
+ [ threaded-server get name>> ] dip
+ unparse-short " connection from " glue ;
+
+: (accept-connection) ( server -- )
+ [ accept ] [ addr>> ] bi
+ [ '[ _ _ _ handle-client ] ]
+ [ drop client-thread-name ] 2bi
+ spawn drop ;
+
+: accept-connection ( server -- )
+ threaded-server get semaphore>>
+ [ [ (accept-connection) ] with-semaphore ]
+ [ (accept-connection) ]
+ if* ;
+
+: with-existing-secure-context ( threaded-server quot -- )
+ [ secure-context>> secure-context ] dip with-variable ; inline
+
+: accept-loop ( server -- )
+ [ accept-connection ] [ accept-loop ] bi ;
+
+: start-accept-loop ( threaded-server server -- )
+ '[ _ accept-loop ] with-existing-secure-context ;
+
+\ start-accept-loop NOTICE add-error-logging
+
+: create-secure-context ( threaded-server -- threaded-server )
+ dup secure>> [
+ dup secure-config>> <secure-context> >>secure-context
+ ] when ;
+
+: init-server ( threaded-server -- threaded-server )
+ create-secure-context
+ <flag> >>server-stopped
+ dup semaphore>> [
+ dup max-connections>> [
+ <semaphore> >>semaphore
+ ] when*
+ ] unless ;
+
+ERROR: no-ports-configured threaded-server ;
+
+: (make-servers) ( theaded-server addrspecs -- servers )
+ swap encoding>>
+ '[ [ _ <server> |dispose ] map ] with-destructors ;
+
+: set-servers ( threaded-server -- threaded-server )
+ dup [
+ dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
+ >>servers
+ ] with-existing-secure-context ;
+
+: server-thread-name ( threaded-server addrspec -- string )
+ [ name>> ] [ addr>> present ] bi* " server on " glue ;
+
+PRIVATE>
+
+: start-server ( threaded-server -- threaded-server )
+ init-server
+ [
+ dup threaded-server [
+ [ ] [ name>> ] bi
+ [
+ set-servers
+ dup add-running-server
+ dup servers>>
+ [
+ [ '[ _ _ [ start-accept-loop ] with-disposal ] ]
+ [ server-thread-name ] 2bi spawn drop
+ ] with each
+ ] with-logging
+ ] with-variable
+ ] keep ;
+
+: server-running? ( threaded-server -- ? )
+ server-stopped>> [ value>> not ] [ f ] if* ;
+
+: stop-server ( threaded-server -- )
+ dup server-running? [
+ [ remove-running-server ]
+ [
+ [
+ [ secure-context>> [ &dispose drop ] when* ]
+ [ [ f ] change-servers drop dispose-each ] bi
+ ] with-destructors
+ ]
+ [ server-stopped>> raise-flag ] tri
+ ] [
+ drop
+ ] if ;
+
+: stop-this-server ( -- )
+ threaded-server get stop-server ;
+
+: wait-for-server ( threaded-server -- )
+ server-stopped>> wait-for-flag ;
+
+: with-threaded-server ( threaded-server quot -- )
+ [ start-server ] dip over
+ '[
+ [ _ threaded-server _ with-variable ]
+ [ _ stop-server ]
+ [ ] cleanup
+ ] call ; inline
+
+<PRIVATE
+
+: first-port ( quot -- n/f )
+ [ threaded-server get servers>> ] dip
+ filter [ f ] [ first addr>> port>> ] if-empty ; inline
+
+PRIVATE>
+
+: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
+
+: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
+
+: secure-addr ( -- inet )
+ threaded-server get servers>> [ addr>> secure? ] filter random ;
+
+: insecure-addr ( -- inet )
+ threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
+
+: server. ( threaded-server -- )
+ [ [ "=== " write name>> ] [ ] bi write-object nl ]
+ [ servers>> [ addr>> present print ] each ] bi ;
+
+: all-servers ( -- sequence )
+ running-servers get-global members ;
+
+: get-servers-named ( string -- sequence )
+ [ all-servers ] dip '[ name>> _ = ] filter ;
+
+: servers. ( -- )
+ all-servers [ server. ] each ;
+
+: stop-all-servers ( -- )
+ all-servers [ stop-server ] each ;
--- /dev/null
+Multi-threaded TCP/IP servers
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
}
-"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
+"The " { $vocab-link "io.servers" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
$nl
"The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets via SSL and TLS." ;
{ $code "f 1234 <inet> resolve-host" }
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "\"localhost\" 1234 <inet> resolve-host" }
- "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
+ "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
ARTICLE: "io.streams.limited" "Limited input streams"
-"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl
+"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes. Limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window. If it is desirable for a stream to throw an exception upon exhaustion, use the " { $vocab-link "io.streams.throwing" } " vocabulary in conjunction with this one." $nl
"Wrap a stream in a limited stream:"
{ $subsections limited-stream }
"Wrap the current " { $link input-stream } " in a limited stream:"
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io kernel quotations words
+math ;
+IN: io.streams.throwing
+
+HELP: stream-exhausted
+{ $values
+ { "n" integer } { "stream" "an input stream" } { "word" word }
+}
+{ $description "The exception that gets thrown when a stream is exhausted." } ;
+
+HELP: stream-throw-on-eof
+{ $values
+ { "stream" "an input stream" } { "quot" quotation }
+}
+{ $description "Wraps a stream in a " { $link <throws-on-eof-stream> } " tuple and calls the quotation with this stream as the " { $link input-stream } " variable. Causes a " { $link stream-exhausted } " exception to be thrown upon stream exhaustion. The stream is left open after this combinator returns." }
+"This example will throw a " { $link stream-exhausted } " exception:"
+{ $unchecked-example """USING: io.streams.throwing prettyprint ;
+"abc" <string-reader> [ 4 read ] stream-throw-on-eof"""
+""
+} ;
+
+HELP: throw-on-eof
+{ $values
+ { "quot" quotation }
+}
+{ $description "Wraps the value stored in the " { $link input-stream } " variable and causes a stream read that exhausts the input stream to throw a " { $link stream-exhausted } " exception. The stream is left open after this combinator returns." } $nl
+"This example will throw a " { $link stream-exhausted } " exception:"
+{ $unchecked-example """USING: io.streams.throwing prettyprint ;
+"abc" [ [ 4 read ] throw-on-eof ] with-string-reader"""
+""
+} ;
+
+ARTICLE: "io.streams.throwing" "Throwing exceptions on stream exhaustion"
+"The " { $vocab-link "io.streams.throwing" } " vocabulary implements combinators for changing the behavior of a stream to throw an exception upon exhaustion instead of returning " { $link f } "." $nl
+"A general combinator to wrap any stream:"
+{ $subsections stream-throw-on-eof }
+"A combinator for the " { $link input-stream } " variable:"
+{ $subsections throw-on-eof }
+"The exception itself:"
+{ $subsections stream-exhausted } ;
+
+ABOUT: "io.streams.throwing"
[
[
- "asdf" <string-reader> &dispose [
- [ 4 swap stream-read ]
- [ stream-read1 ] bi
+ "asdf" <string-reader> [
+ 4 read read1
] stream-throw-on-eof
] with-destructors
] [ stream-exhausted? ] must-fail-with
ERROR: stream-exhausted n stream word ;
-<PRIVATE
-
TUPLE: throws-on-eof-stream stream ;
C: <throws-on-eof-stream> throws-on-eof-stream
+<PRIVATE
+
M: throws-on-eof-stream stream-element-type stream>> stream-element-type ;
M: throws-on-eof-stream dispose stream>> dispose ;
PRIVATE>
: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b )
- [ <throws-on-eof-stream> ] dip call ; inline
+ [ <throws-on-eof-stream> ] dip with-input-stream* ; inline
: throw-on-eof ( ..a quot: ( ..a -- ..b ) -- ..b )
[ input-stream get <throws-on-eof-stream> ] dip with-input-stream* ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs continuations fry http.server io
io.encodings.ascii io.files io.files.unique
-io.servers.connection io.streams.duplex io.streams.string
+io.servers io.streams.duplex io.streams.string
kernel math.ranges mime.multipart multiline namespaces random
sequences strings threads tools.test ;
IN: mime.multipart.tests
] each
USING: http.client http.server http.server.dispatchers
-http.server.responses http.server.static io.servers.connection ;
+http.server.responses http.server.static io.servers ;
SINGLETON: quit-responder
if errorlevel 1 goto fail\r
\r
echo Fetching %_bootimage_version% boot image...\r
-cscript /nologo build-support\http-get.vbs http://factorcode.org/images/%_bootimage_path%/%_bootimage% %_bootimage%\r
+cscript /nologo build-support\http-get.vbs http://downloads.factorcode.org/images/%_bootimage_path%/%_bootimage% %_bootimage%\r
if errorlevel 1 goto fail\r
\r
echo Bootstrapping...\r
$DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
$DELETE temp/staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
- get_url http://factorcode.org/images/latest/checksums.txt
+ get_url http://downloads.factorcode.org/images/latest/checksums.txt
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
set_md5sum
case $OS in
get_boot_image() {
$ECHO "Downloading boot image $BOOT_IMAGE."
- get_url http://factorcode.org/images/latest/$BOOT_IMAGE
+ get_url http://downloads.factorcode.org/images/latest/$BOOT_IMAGE
}
get_url() {
! Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors debugger io io.encodings.utf8 io.servers.connection
+USING: accessors debugger io io.encodings.utf8 io.servers
kernel listener math namespaces ;
-
IN: fuel.remote
<PRIVATE
}
{ $slide "Example: time server"
{ $vocab-link "time-server" }
- { "Demonstrates " { $vocab-link "io.servers.connection" } " vocabulary, threads" }
+ { "Demonstrates " { $vocab-link "io.servers" } " vocabulary, threads" }
}
{ $slide "Example: what is my IP?"
{ $vocab-link "webapps.ip" }
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs calendar continuations destructors io
-io.encodings.binary io.servers.connection io.sockets
+io.encodings.binary io.servers io.sockets
io.streams.duplex fry kernel locals math math.ranges multiline
namespaces prettyprint random sequences sets splitting threads
tools.continuations ;
IN: mason.release.branch.tests
USING: mason.release.branch mason.config tools.test namespaces ;
-[ { "git" "push" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [
+[ { "git" "push" "-f" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [
[
"joe" branch-username set
"blah.com" branch-host set
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar calendar.format io io.encodings.ascii
-io.servers.connection kernel threads ;
+io.servers kernel threads ;
IN: time-server
: handle-time-client ( -- )
-USING: listener io.servers.connection io.encodings.utf8
-accessors kernel ;
+USING: listener io.servers io.encodings.utf8 accessors kernel ;
IN: tty-server
: <tty-server> ( port -- )
"http://downloads.factorcode.org/" prepend ;
: package-url ( builder -- url )
- [ URL" $mason-app/package" ] dip
+ [ URL" http://builds.factorcode.org/package" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
adjust-url ;
: release-url ( builder -- url )
- [ URL" $mason-app/release" ] dip
+ [ URL" http://builds.factorcode.org/release" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
adjust-url ;
furnace.boilerplate furnace.redirection html.forms http.server
http.server.dispatchers kernel namespaces site-watcher site-watcher.db
site-watcher.private urls validators io.sockets.secure.unix.debug
-io.servers.connection io.files.temp db db.tuples sequences
+io.servers io.files.temp db db.tuples sequences
webapps.site-watcher.common webapps.site-watcher.watching
webapps.site-watcher.spidering ;
QUALIFIED: assocs
furnace.auth.features.deactivate-user
db.sqlite
furnace.alloy
-io.servers.connection
+io.servers
io.sockets.secure ;
: <login-config> ( responder -- responder' )
! Copyright (c) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.pathnames
-io.sockets io.sockets.secure io.servers.connection
+io.sockets io.sockets.secure io.servers
namespaces db db.tuples db.sqlite smtp urls
logging.insomniac
html.templates.chloe
webapps.user-admin
webapps.help
webapps.mason
-webapps.mason.backend ;
+webapps.mason.backend
+websites.factorcode ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
} ensure-tables
] with-db ;
-TUPLE: factor-website < dispatcher ;
+TUPLE: concatenative-website < dispatcher ;
: <factor-boilerplate> ( responder -- responder' )
<boilerplate>
- { factor-website "page" } >>template ;
+ { concatenative-website "page" } >>template ;
: <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
"6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key ;
-: <factor-website> ( -- responder )
- factor-website new-dispatcher
+: <concatenative-website> ( -- responder )
+ concatenative-website new-dispatcher
URL" /wiki/view/Front Page" <redirect-responder> "" add-responder ;
SYMBOL: key-password
"vocab:openssl/test/server.pem" key-file set-global
"password" key-password set-global
common-configuration
- <factor-website>
+ <concatenative-website>
<wiki> <login-config> <factor-boilerplate> "wiki" add-responder
<user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> "pastebin" add-responder
: init-production ( -- )
common-configuration
<vhost-dispatcher>
- <factor-website>
+ <concatenative-website>
<wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.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
+ <factor-website> "new.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
dh-file get >>dh-file
key-password get >>password ;
-: <factor-website-server> ( -- threaded-server )
+: <concatenative-website-server> ( -- threaded-server )
<http-server>
<factor-secure-config> >>secure-config
8080 >>insecure
test-db start-expiring
test-db start-update-task
http-insomniac
- <factor-website-server> start-server ;
+ <concatenative-website-server> start-server ;
--- /dev/null
+USING: io math sequences ;
+
+"Hello world" print
+10 [ "Hello, Factor" print ] times
+"Hello, " "Factor" append print
+----
+USING: io kernel sequences
+http.client xml xml.data xml.traversal ;
+
+"http://factorcode.org" http-get nip string>xml
+"a" deep-tags-named
+[ "href" attr ] map
+[ print ] each
+----
+USING: accessors kernel math math.constants
+math.functions prettyprint ;
+IN: shapes
+
+TUPLE: circle radius ;
+TUPLE: rectangle width height ;
+
+GENERIC: area ( shape -- area )
+M: circle area radius>> sq pi * ;
+M: rectangle area [ width>> ] [ height>> ] bi * ;
+
+rectangle new 10 >>width 20 >>height area .
+----
+USING: accessors smtp ;
+
+<email>
+ "john@foobar.com" >>from
+ { "jane@foobar.com" } >>to
+ "Up for lunch?" >>subject
+ "At Tracy's." >>body
+send-email
+----
+USING: io.files io.encodings.utf8 kernel
+sequences splitting ;
+
+"table.txt" utf8 [
+ file-lines
+ [ "|" split ] map flip [ "|" join ] map
+] 2keep
+set-file-lines
+----
+USING: sequences xml.syntax xml.writer ;
+
+{ "three" "blind" "mice" }
+[ [XML <li><-></li> XML] ] map
+[XML <ul><-></ul> XML]
+pprint-xml
+----
+USING: inspector io.files.info io.pathnames system tools.files ;
+
+home directory.
+home file-system-info free-space>> .
+image file-info describe
--- /dev/null
+! Copyright (c) 2010 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors http.server http.server.dispatchers
+http.server.static kernel namespaces sequences ;
+IN: websites.factorcode
+
+SYMBOL: users
+
+: <factor-website> ( -- website )
+ <dispatcher>
+ "resource:extra/websites/factorcode/" <static> enable-fhtml >>default
+ users get [
+ [ "/home/" "/www/" surround <static> ] keep add-responder
+ ] each ;
+
+: init-testing ( -- )
+ <factor-website> main-responder set-global ;
--- /dev/null
+<% USING: namespaces http.client kernel io.files splitting random io io.encodings.utf8 sequences
+webapps.mason.version.data webapps.mason.backend webapps.mason.grids webapps.mason.downloads
+webapps.mason.utils html.elements accessors
+xml.writer ; %>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+ <title>Factor programming language</title>
+ <link rel="stylesheet" href="master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+</head>
+
+<body>
+
+<div><img src="logo.png" alt="Factor programming language" /></div>
+
+<table border="0" width="100%">
+
+<tr>
+<td width="50%" valign="top">
+
+<h1>Why Factor?</h1>
+
+<p>The <big>Factor programming language</big> combines <a href="http://concatenative.org/wiki/view/Factor/Features/The%20language">powerful language features</a> with a <a href="http://docs.factorcode.org/content/article-vocab-index.html">full-featured library</a>. The implementation is <a href="http://concatenative.org/wiki/view/Factor/Optimizing%20compiler">fully compiled</a> for performance, while still supporting <a href="http://concatenative.org/wiki/view/Factor/Interactive development">interactive development</a>. Factor applications are portable between all common platforms. Factor can <a href="http://concatenative.org/wiki/view/Factor/Deployment">deploy stand-alone applications</a> on all platforms. Full source code for the Factor project is available under a <a href="http://factorcode.org/license.txt">BSD license</a>.</p>
+
+<ul>
+<li>Screenshots: <a href="http://factorcode.org/factor-macosx.png">Mac OS X</a>, <a href="http://factorcode.org/factor-windows7.png">Windows</a></li>
+<li><a href="http://concatenative.org/wiki/view/Factor">Learn more about Factor</a></li>
+<li><a href="http://concatenative.org/wiki/view/Factor/Learning">Get started programming with Factor</a></li>
+<li><a href="http://concatenative.org/wiki/view/Factor/FAQ">Get answers to frequently-asked questions</a></li>
+<li><a href="http://docs.factorcode.org/">Read Factor reference documentation online</a></li>
+<li><a href="http://concatenative.org/wiki/view/Concatenative%20language">Learn more about concatenative programming</a></li>
+</ul>
+
+<p>Most of the above links point to pages on the <a href="http://concatenative.org">concatenative.org wiki</a>.</p>
+</td>
+
+<td width="50%" valign="top">
+
+<h1>Show me some code!</h1>
+
+<p>Factor belongs to the family of <em><a href="http://concatenative.org/wiki/view/Concatenative%20language">concatenative languages</a></em>: this means that, at the lowest level, a Factor program is a series of words (functions) that manipulate a stack of references to dynamically-typed values. This gives the language a powerful foundation which allows many abstractions and paradigms to be built on top. Reload this page to see a random code example below.</p>
+
+<pre>
+<%
+"resource:extra/websites/factorcode/examples.txt" utf8 file-lines
+{ "----" } split random "\n" join write
+%>
+</pre>
+
+<p>See the <a href="http://concatenative.org/wiki/view/Factor/Examples">example programs</a> page on the wiki for more.</p>
+
+</td>
+</tr>
+
+</table>
+
+<h1>Downloads</h1>
+
+<% [ %>
+
+<p>To download a binary, follow the link corresponding to your computer's CPU/OS configuration. Binary packages are the recommended route for new users who wish to try Factor.</p>
+
+<h2>Stable release:
+<% latest-version <a [ announcement-url>> =href a> ] [ version>> write ] bi </a> %>
+</h2>
+
+<table id="mytable" cellspacing="0" summary="Stable releases">
+ <% release-grid write-xml %>
+</table>
+
+<p><b>Source code</b>:
+<% latest-version <a [ source-path>> download-url =href a> ] [ version>> write ] bi </a> %>
+</p>
+
+<h2>Development release</h2>
+
+<table id="mytable" cellspacing="0" summary="Development releases">
+ <% package-grid write-xml %>
+</table>
+
+<% ] with-mason-db %>
+
+<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 <a href="http://builds.factorcode.org/dashboard">build farm dashboard</a>.</p>
+
+<p><b>Source code</b> is stored in our <a href="http://concatenative.org/wiki/view/Factor/GIT repository">GIT repository</a>. Source can can be browsed online via <a href="http://github.com/slavapestov/factor/">github</a> or <a href="http://gitweb.factorcode.org/">gitweb</a>.</p>
+
+<h1>More</h1>
+
+<ul>
+<li><a href="http://concatenative.org/wiki/view/Factor/Mailing list">Join the mailing list</a></li>
+<li><a href="http://concatenative.org/wiki/view/Concatenative IRC channel">Join the IRC channel</a></li>
+<li><a href="http://planet.factorcode.org/">planet.factorcode.org</a> - Factor community blogs</li>
+<li><a href="http://concatenative.org/wiki/view/Concatenative%20language/Publications">Academic publications</a></li>
+<li><a href="http://paste.factorcode.org/">Factor community pastebin</a> - if you're in an IRC channel and want to share some code</li>
+</ul>
+
+</body>
+</html>
--- /dev/null
+body {
+ font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+}
+
+ul {
+ margin:10px 10px 10px 0;
+ padding:0 0 0 15px;
+}
+
+li {
+ margin:0 0 0 10px;
+ padding:5px;
+}
+
+a {
+ color:#222;
+ border-bottom:1px solid #aaa;
+ text-decoration:none;
+}
+
+a:hover {
+ border-bottom:1px solid #ccc;
+}
+
+ol.subnav {
+ margin:-10px -10px 0 -5px;
+ padding:0;
+}
+
+ol.subnav li {
+ font:85%/0.9em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ float:left;
+ list-style:none;
+ margin:0;
+ padding:0;
+}
+
+ol.subnav a {
+ font-weight:bold;
+ color:#555;
+ border-top:2px solid #fff;
+ display:block;
+ padding:5px;
+ text-decoration:none;
+ margin:0 5px 0 0;
+ border-bottom:none;
+}
+
+ol.subnav a:hover {
+ border-top:2px solid #943329;
+ color:#121212;
+ border-bottom:none;
+}
+
+#downloads {
+ width: 520px;
+ padding: 0;
+ margin: 0;
+}
+
+caption {
+ padding: 0 0 5px 0;
+ width: 520px;
+ font: italic 11px "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
+ text-align: right;
+}
+
+th {
+ font: bold 11px "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
+ color: #4f6b72;
+ border-right: 1px solid #C1DAD7;
+ border-bottom: 1px solid #C1DAD7;
+ border-top: 1px solid #C1DAD7;
+ letter-spacing: 2px;
+ text-transform: uppercase;
+ padding: 6px 6px 6px 6px;
+ background: #CAE8EA url(bg_header.jpg) no-repeat;
+}
+
+th.nobg {
+ border-top: 0;
+ border-left: 0;
+ border-right: 1px solid #C1DAD7;
+ background: none;
+}
+
+pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+ font-size: 120%;
+}
+
+td.alt {
+ background: #F5FAFA;
+ color: #797268;
+}
+
+td.doesnotexist {
+ background: #E5EAEA;
+}
+
+
+td.unsupported {
+ background: #ffaaaa;
+}
+
+
+td.supported {
+ background: #aaffaa;
+}
+
+td.supported :hover { background-color: #88ff88; }
+
+td.nobinary {
+ background: #eeee88;
+}
+
+div.bigdiv {
+ width: 100px;
+ text-align: center;
+ color: #050;
+}
+
+th.spec {
+ border-left: 1px solid #C1DAD7;
+ border-top: 0;
+ background: #fff;
+ font: bold 10px "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
+}
+
+th.specalt {
+ border-left: 1px solid #C1DAD7;
+ border-top: 0;
+ background: #f5fafa;
+ font: bold 10px "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
+ color: #797268;
+}
+
+th.allbg {
+ border-top: 0;
+ border-left: 0;
+ border-right: 0;
+ background: none;
+}
u8 *bitmap = info->gc_info_bitmap();
{
- cell base = info->scrub_d_base(index);
+ cell base = info->callsite_scrub_d(index);
- for(int loc = 0; loc < info->scrub_d_count; loc++)
+ for(cell loc = 0; loc < info->scrub_d_count; loc++)
{
if(bitmap_p(bitmap,base + loc))
{
}
{
- cell base = info->scrub_r_base(index);
+ cell base = info->callsite_scrub_r(index);
- for(int loc = 0; loc < info->scrub_r_count; loc++)
+ for(cell loc = 0; loc < info->scrub_r_count; loc++)
{
if(bitmap_p(bitmap,base + loc))
{
namespace factor
{
-int gc_info::return_address_index(cell return_address)
+cell gc_info::return_address_index(cell return_address)
{
u32 *return_address_array = return_addresses();
- for(int i = 0; i < return_address_count; i++)
+ for(cell i = 0; i < return_address_count; i++)
{
if(return_address == return_address_array[i])
return i;
}
- return -1;
+ return gc_info_missing_value;
}
}
namespace factor
{
+const u32 gc_info_missing_value = (u32)-1;
+
struct gc_info {
- int scrub_d_count;
- int scrub_r_count;
- int gc_root_count;
- int return_address_count;
+ u32 scrub_d_count;
+ u32 scrub_r_count;
+ u32 gc_root_count;
+ u32 derived_root_count;
+ u32 return_address_count;
+
+ cell callsite_bitmap_size()
+ {
+ return scrub_d_count + scrub_r_count + gc_root_count;
+ }
cell total_bitmap_size()
{
- return return_address_count * (scrub_d_count + scrub_r_count + gc_root_count);
+ return return_address_count * callsite_bitmap_size();
}
cell total_bitmap_bytes()
u32 *return_addresses()
{
- return (u32 *)((u8 *)this - return_address_count * sizeof(u32));
+ return (u32 *)this - return_address_count;
+ }
+
+ u32 *base_pointer_map()
+ {
+ return return_addresses() - return_address_count * derived_root_count;
}
u8 *gc_info_bitmap()
{
- return (u8 *)return_addresses() - total_bitmap_bytes();
+ return (u8 *)base_pointer_map() - total_bitmap_bytes();
}
- cell scrub_d_base(cell index)
+ cell callsite_scrub_d(cell index)
{
return index * scrub_d_count;
}
- cell scrub_r_base(cell index)
+ cell callsite_scrub_r(cell index)
{
return return_address_count * scrub_d_count +
index * scrub_r_count;
}
- cell spill_slot_base(cell index)
+ cell callsite_gc_roots(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);
+ cell lookup_base_pointer(cell index, cell derived_root)
+ {
+ return base_pointer_map()[index * derived_root_count + derived_root];
+ }
+
+ cell return_address_index(cell return_address);
};
}
gc_info *info = compiled->block_gc_info();
assert(return_address < compiled->size());
- int index = info->return_address_index(return_address);
- if(index == -1)
+ u32 callsite = info->return_address_index(return_address);
+ if(callsite == gc_info_missing_value)
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);
+ u8 *bitmap = info->gc_info_bitmap();
- for(int spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ /* Subtract old value of base pointer from every derived pointer. */
+ for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
{
- if(bitmap_p(bitmap,base + spill_slot))
+ cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+ if(base_pointer != gc_info_missing_value)
{
#ifdef DEBUG_GC_MAPS
- std::cout << "visiting spill slot " << spill_slot << std::endl;
+ std::cout << "visiting derived root " << spill_slot
+ << " with base pointer " << base_pointer
+ << std::endl;
+#endif
+ stack_pointer[spill_slot] -= stack_pointer[base_pointer];
+ }
+ }
+
+ /* Update all GC roots, including base pointers. */
+ cell callsite_gc_roots = info->callsite_gc_roots(callsite);
+
+ for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ {
+ if(bitmap_p(bitmap,callsite_gc_roots + spill_slot))
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "visiting GC root " << spill_slot << std::endl;
#endif
visitor->visit_handle(stack_pointer + spill_slot);
}
}
+
+ /* Add the base pointers to obtain new derived pointer values. */
+ for(cell spill_slot = 0; spill_slot < info->derived_root_count; spill_slot++)
+ {
+ cell base_pointer = info->lookup_base_pointer(callsite, spill_slot);
+ if(base_pointer != gc_info_missing_value)
+ stack_pointer[spill_slot] += stack_pointer[base_pointer];
+ }
}
};
return (Type *)allot_object(Type::type_number,size);
}
+ inline bool in_data_heap_p(cell pointer)
+ {
+ return (pointer >= data->seg->start && pointer < data->seg->end);
+ }
+
inline void check_data_pointer(object *pointer)
{
#ifdef FACTOR_DEBUG
if(!(current_gc && current_gc->op == collect_growing_heap_op))
- {
- assert((cell)pointer >= data->seg->start
- && (cell)pointer < data->seg->end);
- }
+ assert(in_data_heap_p((cell)pointer));
#endif
}
projects / factor.git / commitdiff
