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

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

db4
sheeple 2008-02-15 14:16:58 -06:00
parent 9faee652c8 863ace7ab3
commit 2400d9a259
129 changed files with 2318 additions and 1179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/alien/compiler/compiler.factor
View File

@ -326,7 +326,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry
alien-callback-xt [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
@ -398,7 +398,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
dup alien-callback-xt dup rot [
dup alien-callback-xt dup [
init-templates
%save-word-xt
%prologue-later
@ -407,7 +407,7 @@ TUPLE: callback-context ;
dup wrap-callback-quot %alien-callback
%callback-return
] with-stack-frame
] generate-1 ;
] with-generator ;
M: alien-callback generate-node
end-basic-block generate-callback iterate-next ;

24
core/alien/structs/structs-tests.factor
View File

@ -9,18 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! This was actually only correct on Windows/x86:
[ 16 ] [ "align-test" heap-size ] unit-test
cell 4 = [
C-STRUCT: one
{ "long" "a" } { "double" "b" } { "int" "c" } ;
[ 24 ] [ "one" heap-size ] unit-test
] when
! C-STRUCT: align-test
! { "int" "x" }
! { "double" "y" } ;
!
! [ 16 ] [ "align-test" heap-size ] unit-test
!
! cell 4 = [
! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
: MAX_FOOS 30 ;

11
core/assocs/assocs-docs.factor
View File

@ -59,6 +59,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
{ $subsection diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
{ $see-also key? } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
@ -266,12 +267,16 @@ HELP: remove-all
{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
{ $side-effects "assoc" } ;
HELP: substitute
{ $values { "assoc" assoc } { "seq" "a mutable sequence" } }
{ $description "Replaces elements of " { $snippet "seq" } " which appear in as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
HELP: substitute-here
{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
HELP: cache
{ $values { "key" "a key" } { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }

10
core/assocs/assocs.factor
View File

@ -124,8 +124,14 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ;
: substitute ( assoc seq -- )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
(substitute) change-each ;
: substitute ( seq assoc -- newseq )
(substitute) map ;
: cache ( key assoc quot -- value )
2over at [

8
core/bootstrap/compiler/compiler.factor
View File

@ -74,6 +74,12 @@ nl
malloc free memcpy
} compile
[ compiled-usages recompile ] recompile-hook set-global
: enable-compiler ( -- )
[ compiled-usages recompile ] recompile-hook set-global ;
: disable-compiler ( -- )
[ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
enable-compiler
" done" print flush

2
core/bootstrap/stage2.factor
View File

@ -59,7 +59,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global
"math help compiler tools ui ui.tools io" "include" set-global
"math help handbook compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
parse-command-line

22
core/combinators/combinators-docs.factor
View File

@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection cond>quot }
{ $subsection case>quot }
{ $subsection alist>quot }
"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
{ $subsection hash-case>quot }
{ $subsection distribute-buckets }
{ $subsection hash-dispatch-quot } ;
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
@ -104,19 +100,17 @@ HELP: case>quot
{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ;
"This word uses three strategies:"
{ $list
"If the assoc only has a few keys, a linear search is generated."
{ "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
"Otherwise, an open-coded hashtable dispatch is generated."
} } ;
HELP: distribute-buckets
{ $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ;
HELP: hash-case>quot
{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }

7
core/combinators/combinators-tests.factor Normal file → Executable file
View File

@ -69,3 +69,10 @@ namespaces combinators words ;
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test

55
core/combinators/combinators.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors ;
kernel kernel.private math assocs quotations vectors
hashtables sorting ;
TUPLE: no-cond ;
@ -31,16 +32,24 @@ TUPLE: no-case ;
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two depend on combinators
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
reverse [ no-cond ] swap alist>quot ;
: case>quot ( default assoc -- quot )
: linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
alist>quot ;
@ -63,20 +72,50 @@ M: sequence hashcode*
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ case>quot ] with map ;
[ linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ;
: hash-case>quot ( default assoc -- quot )
: hash-case-quot ( default assoc -- quot )
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append ;
: contiguous-range? ( keys -- from to ? )
dup [ fixnum? ] all? [
dup all-unique? [
dup infimum over supremum
[ - swap prune length + 1 = ] 2keep rot
] [
drop f f f
] if
] [
drop f f f
] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
drop - >fixnum r> drop r> dispatch
] [
2drop r> call r> drop
] if ; inline
: dispatch-case-quot ( default assoc from to -- quot )
-roll -roll sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
dup empty? [
drop
] [
dup length 4 <= [
case>quot
linear-case-quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup keys contiguous-range? [
dispatch-case-quot
] [
2drop hash-case-quot
] if
] if
] if ;

2
core/compiler/compiler.factor
View File

@ -30,7 +30,7 @@ IN: compiler
: compile-succeeded ( word -- effect dependencies )
[
dup word-dataflow >r swap dup r> optimize generate
[ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
: compile-failed ( word error -- )

3
core/compiler/tests/simple.factor
View File

@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
[ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test
[ f ] [ f single-combination-test-2 ] unit-test
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test

6
core/compiler/tests/stack-trace.factor
View File

@ -1,7 +1,7 @@
IN: temporary
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting ;
words splitting sorting ;
: symbolic-stack-trace ( -- newseq )
error-continuation get continuation-call callstack>array
@ -31,9 +31,9 @@ words splitting ;
\ > stack-trace-contains?
] unit-test
: quux [ t [ "hi" throw ] when ] times ;
: quux { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
\ (each-integer) stack-trace-contains?
\ sort stack-trace-contains?
] unit-test

4
core/compiler/tests/templates-early.factor
View File

@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
[
[ ] [ init-templates ] unit-test
[ ] [ init-generator ] unit-test
H{ } clone compiled set
[ ] [ gensym gensym begin-compiling ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test

17
core/compiler/tests/templates.factor
View File

@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ;
words definitions compiler.units io combinators ;
IN: temporary
! Oops!
@ -191,3 +191,18 @@ TUPLE: my-tuple ;
2 1
[ 2dup fixnum< [ >r die r> ] when ] compile-call
] unit-test
! Regression
: a-dummy drop "hi" print ;
[ ] [
1 [
dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
drop - >fixnum {
[ a-dummy ]
[ a-dummy ]
[ a-dummy ]
} dispatch
] [ 2drop no-case ] if
] compile-call
] unit-test

4
core/debugger/debugger-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test

10
core/generator/fixup/fixup.factor
View File

@ -140,17 +140,19 @@ SYMBOL: literal-table
V{ } clone relocation-table set
V{ } clone label-table set ;
: generate-labels ( -- labels )
label-table get [
: resolve-labels ( labels -- labels' )
[
first3 label-offset
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- relocation-table label-table code )
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >array
generate-labels
label-table get resolve-labels
] { } make ;

17
core/generator/generator-docs.factor
View File

@ -22,34 +22,35 @@ HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
HELP: init-generator
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: generate-1
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
HELP: with-generator
{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "node" "a dataflow node" } }
{ $description "Recursively generate machine code for a dataflow graph." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }

123
core/generator/generator.factor
View File

@ -11,12 +11,6 @@ IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
: begin-compiling ( word -- )
f swap compiled get set-at ;
: finish-compiling ( word literals relocation labels code -- )
4array swap compiled get set-at ;
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
@ -32,24 +26,31 @@ SYMBOL: compiling-word
SYMBOL: compiling-label
SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: init-generator ( -- )
: begin-compiling ( word label -- )
H{ } clone compiling-loops set
compiling-label set
compiling-word set
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set ;
compiling-word get f ?
1vector literal-table set
f compiling-word get compiled get set-at ;
: generate-1 ( word label node quot -- )
pick begin-compiling [
roll compiling-word set
pick compiling-label set
init-generator
call
literal-table get >array
] { } make fixup finish-compiling ;
: finish-compiling ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
finish-compiling
] with-scope ; inline
GENERIC: generate-node ( node -- next )
@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next )
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- )
: generate ( node word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
] with-generator ;
: word-dataflow ( word -- effect dataflow )
[
@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next )
: if-intrinsics ( #call -- quot )
node-param "if-intrinsics" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #values #terminal-values node-successor #terminal? ;
PREDICATE: #call #terminal-call
dup node-successor #if?
over node-successor node-successor #terminal? and
swap if-intrinsics and ;
UNION: #terminal
POSTPONE: f #return #terminal-values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
! node
M: node generate-node drop iterate-next ;
@ -112,20 +94,34 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
tail-call? [
%jump f
dup compiling-loops get at [
%jump-label f
] [
0 frame-required
%call
iterate-next
] if ;
tail-call? [
%jump f
] [
0 frame-required
%call
iterate-next
] if
] ?if ;
! #label
M: #label generate-node
dup node-param generate-call >r
dup #label-word over node-param rot node-child generate
dup node-child over #label-word rot node-param generate
r> ;
! #loop
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
M: #loop generate-node
end-basic-block
dup node-param compiling-loop
node-child generate-nodes
iterate-next ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
@ -150,25 +146,18 @@ M: #if generate-node
! #dispatch
: dispatch-branch ( node word -- label )
gensym [
rot [
[
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
] generate-1
] with-generator
] keep ;
: tail-dispatch? ( node -- ? )
#! Is the dispatch a jump to a tail call to a word?
dup #call? swap node-successor #return? and ;
: dispatch-branches ( node -- )
node-children [
dup tail-dispatch? [
node-param
] [
compiling-word get dispatch-branch
] if %dispatch-label
compiling-word get dispatch-branch
%dispatch-label
] each ;
: generate-dispatch ( node -- )
@ -182,10 +171,10 @@ M: #dispatch generate-node
generate-dispatch iterate-next
] [
compiling-word get gensym [
rot [
[
init-generate-nodes
generate-dispatch
] generate-1
] with-generator
] keep generate-call
] if ;
@ -224,10 +213,11 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( #call pair -- next )
<label> [ swap do-template ] keep
>r node-successor r> generate-if
node-successor ;
: do-if-intrinsic ( pair -- next )
<label> [
swap do-template
node> node-successor dup >node
] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
@ -249,7 +239,7 @@ M: #call generate-node
] [
node-param generate-call
] ?if
] if* ;
] ?if ;
! #call-label
M: #call-label generate-node node-param generate-call ;
@ -274,4 +264,7 @@ M: #r> generate-node
iterate-next ;
! #return
M: #return generate-node drop end-basic-block %return f ;
M: #return generate-node
end-basic-block
node-param compiling-loops get key?
[ %return ] unless f ;

2
core/generator/registers/registers.factor Normal file → Executable file
View File

@ -504,7 +504,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ swap substitute ] curry each-phantom ;
[ substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;

11
core/generic/math/math.factor
View File

@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ;
2drop object-method
] if ;
: math-vtable* ( picker max quot -- quot )
: math-vtable ( picker quot -- quot )
[
rot , \ tag ,
[ >r [ bootstrap-type>class ] map r> map % ] { } make ,
>r
, \ tag ,
num-tags get [ bootstrap-type>class ]
r> compose map ,
\ dispatch ,
] [ ] make ; inline
: math-vtable ( picker quot -- quot )
num-tags get swap math-vtable* ; inline
TUPLE: math-combination ;
M: math-combination make-default-method

18
core/hashtables/hashtables.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors
combinators ;
math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
@ -161,17 +160,10 @@ M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
M: hashtable equal?
{
{ [ over hashtable? not ] [ 2drop f ] }
{ [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
{ [ t ] [ assoc= ] }
} cond ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
over hashtable? [
2dup [ assoc-size ] 2apply number=
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
! Default method
M: assoc new-assoc drop <hashtable> ;

3
core/inference/dataflow/dataflow-docs.factor
View File

@ -1,4 +1,5 @@
USING: inference.dataflow help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: inference.dataflow
HELP: #return
{ $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } }

20
core/inference/dataflow/dataflow.factor
View File

@ -97,11 +97,13 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label word ;
TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
PREDICATE: #label #loop #label-loop? ;
TUPLE: #entry ;
: #entry ( -- node ) \ #entry all-out-node ;
@ -304,3 +306,19 @@ SYMBOL: node-stack
node-children
[ last-node ] map
[ #terminate? not ] subset ;
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ;
: tail-call? ( -- ? )
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
node-successor dup #tail? swap #terminate? not and
] all? ;

2
core/inference/known-words/known-words.factor
View File

@ -345,7 +345,7 @@ M: object infer-call
\ <word> { object object } { word } <effect> set-primitive-effect
\ <word> make-flushable
\ word-xt { word } { integer } <effect> set-primitive-effect
\ word-xt { word } { integer integer } <effect> set-primitive-effect
\ word-xt make-flushable
\ getenv { fixnum } { object } <effect> set-primitive-effect

2
core/inference/transforms/transforms.factor
View File

@ -35,7 +35,7 @@ IN: inference.transforms
dup peek swap 1 head*
] [
[ no-case ] swap
] if hash-case>quot
] if case>quot
] if
] 1 define-transform

0
core/io/utf16/authors.txt → core/io/encodings/binary/authors.txt
View File

5
core/io/encodings/binary/binary-docs.factor Normal file
View File

@ -0,0 +1,5 @@
USING: help.syntax help.markup ;
IN: io.encodings.binary
HELP: binary
{ $class-description "This is the encoding descriptor for binary I/O." } ;

6
core/io/encodings/binary/binary.factor Normal file
View File

@ -0,0 +1,6 @@
USING: kernel io.encodings ;
TUPLE: binary ;
M: binary init-decoding drop ;
M: binary init-encoding drop ;

1
core/io/encodings/binary/summary.txt Normal file
View File

@ -0,0 +1 @@
Dummy encoding for binary I/O

1
core/io/encodings/binary/tags.txt Normal file
View File

@ -0,0 +1 @@
text

77
core/io/encodings/encodings.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors
namespaces unicode.syntax ;
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
namespaces unicode growable strings io classes io.streams.c
continuations ;
IN: io.encodings
TUPLE: encode-error ;
@ -18,11 +19,77 @@ SYMBOL: begin
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ;
CHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop "" like ;
: decode ( seq quot -- str )
>r [ length <sbuf> 0 begin ] keep r> each
: start-decoding ( seq length -- buf ch state seq )
<sbuf> 0 begin roll ;
GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
: decode ( seq quot -- string )
>r dup length start-decoding r>
[ -rot ] swap compose each
finish-decoding ; inline
: space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ;
: full? ( resizable -- ? ) space zero? ;
: end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ;
: decode-read-loop ( buf ch state stream encoding -- string/f )
>r >r pick r> r> rot full? [ end-read-loop ] [
over stream-read1 [
-rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
] [ end-read-loop ] if*
] if ;
: decode-read ( length stream encoding -- string )
>r swap start-decoding r>
decode-read-loop ;
GENERIC: init-decoding ( stream encoding -- decoded-stream )
: <decoding> ( stream decoding-class -- decoded-stream )
construct-empty init-decoding <line-reader> ;
GENERIC: init-encoding ( stream encoding -- encoded-stream )
: <encoding> ( stream encoding-class -- encoded-stream )
construct-empty init-encoding <plain-writer> ;
GENERIC: encode-string ( string encoding -- byte-array )
M: tuple-class encode-string construct-empty encode-string ;
MIXIN: encoding-stream
M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
tuck set-delegate ;
M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
tuck set-delegate ;
M: encoding-stream stream-read1 1 swap stream-read ;
M: encoding-stream stream-read
[ delegate ] keep decode-read ;
M: encoding-stream stream-read-partial stream-read ;
M: encoding-stream stream-read-until
! Copied from { c-reader stream-read-until }!!!
[ swap read-until-loop ] "" make
swap over empty? over not and [ 2drop f f ] when ;
M: encoding-stream stream-write1
>r 1string r> stream-write ;
M: encoding-stream stream-write
[ encode-string ] keep delegate stream-write ;
M: encoding-stream dispose delegate dispose ;

0
core/io/utf8/authors.txt → core/io/encodings/latin1/authors.txt
View File

5
core/io/encodings/latin1/latin1-docs.factor Normal file
View File

@ -0,0 +1,5 @@
USING: help.syntax help.markup ;
IN: io.encodings.latin1
HELP: latin1
{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;

19
core/io/encodings/latin1/latin1.factor Executable file
View File

@ -0,0 +1,19 @@
USING: io io.encodings strings kernel ;
IN: io.encodings.latin1
TUPLE: latin1 stream ;
M: latin1 init-decoding tuck set-latin1-stream ;
M: latin1 init-encoding drop ;
M: latin1 stream-read1
latin1-stream stream-read1 ;
M: latin1 stream-read
latin1-stream stream-read >string ;
M: latin1 stream-read-until
latin1-stream stream-read-until >string ;
M: latin1 stream-readln
latin1-stream stream-readln >string ;

1
core/io/encodings/latin1/summary.txt Normal file
View File

@ -0,0 +1 @@
ISO 8859-1 encoding/decoding

1
core/io/encodings/latin1/tags.txt Normal file
View File

@ -0,0 +1 @@
text

BIN
core/io/encodings/utf16/.utf16.factor.swo Normal file
View File

Binary file not shown.

1
core/io/encodings/utf16/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

0
core/io/utf16/summary.txt → core/io/encodings/utf16/summary.txt
View File

1
core/io/encodings/utf16/tags.txt Normal file
View File

@ -0,0 +1 @@
text

2
core/io/utf16/utf16-docs.factor → core/io/encodings/utf16/utf16-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io.encodings strings ;
IN: io.utf16
IN: io.encodings.utf16
ARTICLE: "io.utf16" "Working with UTF16-encoded data"
"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."

10
core/io/utf16/utf16-tests.factor → core/io/encodings/utf16/utf16-tests.factor
View File

@ -1,15 +1,15 @@
USING: tools.test io.utf16 arrays unicode.syntax ;
USING: tools.test io.utf16 arrays unicode ;
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test

32
core/io/utf16/utf16.factor → core/io/encodings/utf16/utf16.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting ;
IN: io.utf16
IN: io.encodings.utf16
SYMBOL: double
SYMBOL: quad1
@ -30,7 +30,7 @@ SYMBOL: ignore
>r 2 shift r> BIN: 11 bitand bitor quad3
] [ 2drop do-ignore ] if ;
: (decode-utf16be) ( buf byte ch state -- buf ch state )
: decode-utf16be-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf16be ] }
{ double [ end-multibyte ] }
@ -41,7 +41,7 @@ SYMBOL: ignore
} case ;
: decode-utf16be ( seq -- str )
[ -rot (decode-utf16be) ] decode ;
[ decode-utf16be-step ] decode ;
: handle-double ( buf byte ch -- buf ch state )
swap dup -3 shift BIN: 11011 = [
@ -55,7 +55,7 @@ SYMBOL: ignore
BIN: 11 bitand append-nums HEX: 10000 + decoded
] [ 2drop push-replacement ] if ;
: (decode-utf16le) ( buf byte ch state -- buf ch state )
: decode-utf16le-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop double ] }
{ double [ handle-double ] }
@ -65,7 +65,7 @@ SYMBOL: ignore
} case ;
: decode-utf16le ( seq -- str )
[ -rot (decode-utf16le) ] decode ;
[ decode-utf16le-step ] decode ;
: encode-first
-10 shift
@ -104,13 +104,23 @@ SYMBOL: ignore
: encode-utf16 ( str -- seq )
encode-utf16le bom-le swap append ;
: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
: decode-utf16 ( seq -- str )
{
{ [ utf16le? ] [ decode-utf16le ] }
{ [ utf16be? ] [ decode-utf16be ] }
{ [ bom-le ?head ] [ decode-utf16le ] }
{ [ bom-be ?head ] [ decode-utf16be ] }
{ [ t ] [ decode-error ] }
} cond ;
TUPLE: utf16le ;
: <utf16le> utf16le construct-delegate ;
INSTANCE: utf16le encoding-stream
M: utf16le encode-string drop encode-utf16le ;
M: utf16le decode-step drop decode-utf16le-step ;
TUPLE: utf16be ;
: <utf16be> utf16be construct-delegate ;
INSTANCE: utf16be encoding-stream
M: utf16be encode-string drop encode-utf16be ;
M: utf16be decode-step drop decode-utf16be-step ;

1
core/io/encodings/utf8/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

0
core/io/utf8/summary.txt → core/io/encodings/utf8/summary.txt
View File

1
core/io/encodings/utf8/tags.txt Normal file
View File

@ -0,0 +1 @@
text

6
core/io/utf8/utf8-docs.factor → core/io/encodings/utf8/utf8-docs.factor Normal file → Executable file
View File

@ -1,12 +1,12 @@
USING: help.markup help.syntax io.encodings strings ;
IN: io.utf8
IN: io.encodings.utf8
ARTICLE: "io.utf8" "Working with UTF8-encoded data"
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
{ $subsection encode-utf8 }
{ $subsection decode-utf8 } ;
ABOUT: "io.utf8"
ABOUT: "io.encodings.utf8"
HELP: decode-utf8
{ $values { "seq" "a sequence of bytes" } { "str" string } }

23
core/io/encodings/utf8/utf8-tests.factor Normal file
View File

@ -0,0 +1,23 @@
USING: io.encodings.utf8 tools.test sbufs kernel io
sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here <utf8> contents >array ;
: encode-utf8-w/stream ( array -- newarray )
SBUF" " clone tuck <utf8> write >array ;
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test

24
core/io/utf8/utf8.factor → core/io/encodings/utf8/utf8.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors
namespaces io.encodings combinators ;
IN: io.utf8
USING: math kernel sequences sbufs vectors growable io continuations
namespaces io.encodings combinators strings io.streams.c ;
IN: io.encodings.utf8
! Decoding UTF-8
SYMBOL: double
SYMBOL: triple
@ -31,7 +33,7 @@ SYMBOL: quad3
: end-multibyte ( buf byte ch -- buf ch state )
f append-nums [ decoded ] unless* ;
: (decode-utf8) ( buf byte ch state -- buf ch state )
: decode-utf8-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf8 ] }
{ double [ end-multibyte ] }
@ -43,7 +45,9 @@ SYMBOL: quad3
} case ;
: decode-utf8 ( seq -- str )
[ -rot (decode-utf8) ] decode ;
[ decode-utf8-step ] decode ;
! Encoding UTF-8
: encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor , ;
@ -70,3 +74,13 @@ SYMBOL: quad3
: encode-utf8 ( str -- seq )
[ [ char>utf8 ] each ] B{ } make ;
! Interface for streams
TUPLE: utf8 ;
: <utf8> utf8 construct-delegate ;
INSTANCE: utf8 encoding-stream
M: utf8 encode-string drop encode-utf8 ;
M: utf8 decode-step drop decode-utf8-step ;
! In the future, this should detect and ignore a BOM at the beginning

16
core/io/utf8/utf8-tests.factor
View File

@ -1,16 +0,0 @@
USING: io.utf8 tools.test strings arrays unicode.syntax ;
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
[ "x" ] [ "x" decode-utf8 >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test

308
core/optimizer/backend/backend.factor
View File

@ -3,8 +3,7 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard optimizer.specializers ;
combinators classes optimizer.def-use ;
IN: optimizer.backend
SYMBOL: class-substitutions
@ -38,10 +37,10 @@ GENERIC: optimize-node* ( node -- node/t changed? )
over assoc-empty? [
2drop
] [
2dup node-in-d substitute
2dup node-in-r substitute
2dup node-out-d substitute
node-out-r substitute
2dup node-in-d swap substitute-here
2dup node-in-r swap substitute-here
2dup node-out-d swap substitute-here
node-out-r swap substitute-here
] if ;
: perform-substitutions ( node -- )
@ -68,8 +67,6 @@ DEFER: optimize-nodes
] if
] when ;
M: f set-node-successor 2drop ;
: optimize-nodes ( node -- newnode )
[
class-substitutions [ clone ] change
@ -78,19 +75,9 @@ M: f set-node-successor 2drop ;
optimizer-changed get
] with-scope optimizer-changed set ;
! Generic nodes
M: node optimize-node* drop t f ;
: cleanup-inlining ( node -- newnode changed? )
node-successor [ node-successor t ] [ t f ] if* ;
! #return
M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
! Some utilities for splicing in dataflow IR subtrees
! Post-inlining cleanup
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;
@ -103,277 +90,30 @@ M: #values optimize-node* cleanup-inlining ;
#! Not very efficient.
dupd union* update ;
: post-inline ( #call/#merge #return/#values -- assoc )
>r node-out-d r> node-in-d 2array unify-lengths flip
: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
node-out-d swap node-in-d 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
: substitute-def-use ( node -- )
#! As a first approximation, we take all the values used
#! by the set of new nodes, and push a 't' on their
#! def-use list here. We could perform a full graph
#! substitution, but we don't need to, because the next
#! optimizer iteration will do that. We just need a minimal
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
[ compute-def-use def-use get keys ] with-scope
def-use get [ [ t swap ?push ] change-at ] curry each ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor dup [
class-substitutions get pick node-classes update
literal-substitutions get pick node-literals update
tuck compute-value-substitutions value-substitutions get swap update*
node-successor t
] [
2drop t f
] if ;
: substitute-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
#! substituted. A subsequent optimizer phase kills the
#! last node of 'new' and the first node of 'old'.
dup substitute-def-use
last-node
class-substitutions get over node-classes update
literal-substitutions get over node-literals update
2dup post-inline value-substitutions get swap update*
set-node-successor ;
! #return
M: #return optimize-node* cleanup-inlining ;
GENERIC: remember-method* ( method-spec node -- )
! #values
M: #values optimize-node* cleanup-inlining ;
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: f set-node-successor 2drop ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
: splice-node ( old new -- )
dup splice-def-use last-node set-node-successor ;
: drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ;
! Constant branch folding
: fold-branch ( node branch# -- node )
over node-children nth
swap node-successor over substitute-node ;
! #if
: known-boolean-value? ( node value -- value ? )
2dup node-literal? [
node-literal t
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup general-t class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
] if ;
M: #if optimize-node*
dup dup node-in-d first known-boolean-value? [
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep
t
] [ 2drop t f ] if ;
M: #dispatch optimize-node*
dup dup node-in-d first 2dup node-literal? [
"Optimizing #dispatch" print
node-literal
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
] [
3drop t f
] if ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] }
} cond ;
! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable?
] [
2drop f
] if ;
: literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and
#! pushes some literals.
>r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
node-class-first r> class< ;
: optimize-predicate ( #call -- node )
dup evaluate-predicate swap
dup node-successor #if? [
dup drop-inputs >r
node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep
] [
swap 1array inline-literals
] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- )
dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [
node-out-d [ unused? ] all?
] [
drop f
] if ;
: flush-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all?
] [
drop f
] if ;
: literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f
] if ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
M: #call optimize-node*
{
{ [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] }
} cond dup not ;

181
core/optimizer/control/control-tests.factor Executable file
View File

@ -0,0 +1,181 @@
IN: temporary
USING: tools.test optimizer.control combinators kernel
sequences inference.dataflow math inference classes strings
optimizer ;
: label-is-loop? ( node word -- ? )
[
{
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? not ] [ 2drop f ] }
{ [ t ] [ 2drop t ] }
} cond
] curry node-exists? ;
: label-is-not-loop? ( node word -- ? )
[
{
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? ] [ 2drop f ] }
{ [ t ] [ 2drop t ] }
} cond
] curry node-exists? ;
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
\ (each-integer) label-is-loop?
] unit-test
: loop-test-2 ( a -- )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [
[ loop-test-2 ] dataflow dup detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
: loop-test-3 ( a -- )
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [
[ loop-test-3 ] dataflow dup detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test
: loop-test-4 ( a -- )
dup [
loop-test-4
] [
drop
] if ; inline
: find-label ( node -- label )
dup #label? [ node-successor find-label ] unless ;
: test-loop-exits
dataflow dup detect-loops find-label
dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ;
[ { #values } t ] [
[ loop-test-4 ] test-loop-exits
] unit-test
: loop-test-5 ( a -- )
dup [
dup string? [
loop-test-5
] [
drop
] if
] [
drop
] if ; inline
[ { #values #values } t ] [
[ loop-test-5 ] test-loop-exits
] unit-test
: loop-test-6 ( a -- )
dup [
dup string? [
loop-test-6
] [
3 throw
] if
] [
drop
] if ; inline
[ { #values } t ] [
[ loop-test-6 ] test-loop-exits
] unit-test
[ f ] [
[ [ [ ] map ] map ] dataflow dup detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
: blah f ;
DEFER: a
: b ( -- )
blah [ b ] [ a ] if ; inline
: a ( -- )
blah [ b ] [ a ] if ; inline
[ t ] [
[ a ] dataflow dup detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] dataflow dup detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
\ b label-is-loop?
] unit-test
DEFER: a'
: b' ( -- )
blah [ b' b' ] [ a' ] if ; inline
: a' ( -- )
blah [ b' ] [ a' ] if ; inline
[ f ] [
[ a' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test
! I used to think this should be f, but doing this on pen and
! paper almost convinced me that a loop conversion here is
! sound. The loop analysis algorithm looks pretty solid -- its
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
[ b' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test

336
core/optimizer/control/control.factor Executable file
View File

@ -0,0 +1,336 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ;
IN: optimizer.control
! ! ! Rudimentary CFA
! A LOOP
!
! #label A
! |
! #if ----> #merge ----> #return
! |
! -------------
! | |
! #call-label A |
! | ...
! #values
!
! NOT A LOOP (call to A not in tail position):
!
!
! #label A
! |
! #if ----> ... ----> #merge ----> #return
! |
! -------------
! | |
! #call-label A |
! | ...
! ...
! |
! #values
!
! NOT A LOOP (call to A nested inside another label which is
! not a loop):
!
!
! #label A
! |
! #if ----> #merge ----> ... ----> #return
! |
! -------------
! | |
! ... #label B
! |
! #if -> ...
! |
! ---------
! | |
! #call-label A |
! | |
! #values |
! #call-label B
! |
! ...
! Mapping word => { node { nesting tail? }+ height }
! We record all calls to a label, their control nesting and
! whether it is a tail call or not
SYMBOL: label-info
GENERIC: collect-label-info* ( node -- )
M: #label collect-label-info*
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
M: node collect-label-info*
drop ;
: collect-label-info ( node -- )
H{ } clone label-info set
[ collect-label-info* ] each-node ;
! Mapping word => label
SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
[ nip second [ second ] all? ] assoc-subset
[ first ] assoc-map
potential-loops set ;
: remove-non-loop-calls ( -- )
! Boolean is set to t if something changed.
! We recurse until a fixed point is reached.
f label-info get [
! If label X is called from within a label Y that is
! no longer a potential loop, then X is no longer a
! potential loop either.
over potential-loops get key? [
second [ first ] map concat
potential-loops get [ key? ] curry all?
[ drop ] [ potential-loops get delete-at t or ] if
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- )
[
collect-label-info
remove-non-tail-calls
remove-non-loop-calls
potential-loops get [
nip t swap set-#label-loop?
] assoc-each
] with-scope ;
! ! ! Constant branch folding
!
! BEFORE
!
! #if ----> #merge ----> C
! |
! ---------
! | |
! A B
! | |
! #values |
! #values
!
! AFTER
!
! |
! A
! |
! #values
! |
! #merge
! |
! C
: fold-branch ( node branch# -- node )
over node-children nth
swap node-successor over splice-node ;
! #if
: known-boolean-value? ( node value -- value ? )
2dup node-literal? [
node-literal t
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup general-t class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
] if ;
: fold-if-branch? dup node-in-d first known-boolean-value? ;
: fold-if-branch ( node value -- node' )
over drop-inputs >r
0 1 ? fold-branch
r> [ set-node-successor ] keep ;
! ! ! Lifting code after a conditional if one branch throws
! BEFORE
!
! #if ----> #merge ----> B ----> #return/#values
! |
! |
! ---------
! | |
! | A
! #terminate |
! #values
!
! AFTER
!
! #if ----> #merge (*) ----> #return/#values (**)
! |
! |
! ---------
! | |
! | A
! #terminate |
! #values
! |
! #merge (***)
! |
! B
! |
! #return/#values
!
! (*) has the same outputs as the inputs of (**), and it is not
! the same node as (***)
!
! Note: if (**) is #return is is sound to put #terminate there,
! but not if (**) is #
: only-one ( seq -- elt/f )
dup length 1 = [ first ] [ drop f ] if ;
: lift-throw-tail? ( #if -- tail/? )
dup node-successor #tail?
[ drop f ] [ active-children only-one ] if ;
: clone-node ( node -- newnode )
clone dup [ clone ] modify-values ;
: lift-branch
over
last-node clone-node
dup node-in-d \ #merge out-node
[ set-node-successor ] keep -rot
>r dup node-successor r> splice-node
set-node-successor ;
M: #if optimize-node*
dup fold-if-branch? [ fold-if-branch t ] [
drop dup lift-throw-tail? dup [
dupd lift-branch t
] [
2drop t f
] if
] if ;
! Loop tail hoising: code after a loop can sometimes go in the
! non-recursive branch of the loop
! BEFORE:
! #label -> C -> #return 1
! |
! -> #if -> #merge (*) -> #return 2
! |
! --------
! | |
! A B
! | |
! #values |
! #call-label
! |
! |
! #values
! AFTER:
! #label -> #return 1
! |
! -> #if -------> #merge (*) -> #return 2
! | \-------------------/
! ---------------- |
! | | |
! A B unreacachable code needed to
! | | preserve invariants
! #values |
! | #call-label
! #merge (*) |
! | |
! C #values
! |
! #return 1
: find-tail ( node -- tail )
dup #terminate? [
dup node-successor #tail? [
node-successor find-tail
] unless
] unless ;
: child-tails ( node -- seq )
node-children [ find-tail ] map ;
GENERIC: add-loop-exit* ( label node -- )
M: #branch add-loop-exit*
child-tails [ add-loop-exit* ] with each ;
M: #call-label add-loop-exit*
tuck node-param eq? [ drop ] [ node-successor , ] if ;
M: #terminate add-loop-exit*
2drop ;
M: node add-loop-exit*
nip node-successor dup #terminate? [ drop ] [ , ] if ;
: find-loop-exits ( label node -- seq )
[ add-loop-exit* ] { } make ;
: find-final-if ( node -- #if/f )
dup [
dup #if? [
dup node-successor #tail? [
node-successor find-final-if
] unless
] [
node-successor find-final-if
] if
] when ;
: detach-node-successor ( node -- successor )
dup node-successor #terminate rot set-node-successor ;
: lift-loop-tail? ( #label -- tail/f )
dup node-successor node-successor [
dup node-param swap node-child find-final-if dup [
find-loop-exits only-one
] [ 2drop f ] if
] [ drop f ] if ;
M: #loop optimize-node*
dup lift-loop-tail? dup [
last-node "values" set
dup node-successor "tail" set
dup node-successor last-node "return" set
dup node-child find-final-if node-successor "merge" set
! #label -> #return
"return" get clone-node over set-node-successor
! #merge -> C
"merge" get clone-node "tail" get over set-node-successor
! #values -> #merge ->C
"values" get set-node-successor
t
] [
2drop t f
] if ;

28
core/optimizer/def-use/def-use.factor
View File

@ -70,20 +70,6 @@ M: #branch node-def-use
#! #values node.
dup branch-def-use (node-def-use) ;
! : dead-literals ( -- values )
! def-use get [ >r value? r> empty? and ] assoc-subset ;
!
! : kill-node* ( node values -- )
! [ swap remove-all ] curry modify-values ;
!
! : kill-node ( node values -- )
! dup assoc-empty?
! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
!
! : kill-values ( node -- )
! #! Remove literals which are not actually used anywhere.
! dead-literals kill-node ;
: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
dead-literals [ kill-nodes ] with-variable
] if ;
!
: sole-consumer ( #call -- node/f )
node-out-d first used-by
dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- )
#! As a first approximation, we take all the values used
#! by the set of new nodes, and push a 't' on their
#! def-use list here. We could perform a full graph
#! substitution, but we don't need to, because the next
#! optimizer iteration will do that. We just need a minimal
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
[ compute-def-use def-use get keys ] with-scope
def-use get [ [ t swap ?push ] change-at ] curry each ;

227
core/optimizer/inlining/inlining.factor Executable file
View File

@ -0,0 +1,227 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control ;
IN: optimizer.inlining
GENERIC: remember-method* ( method-spec node -- )
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
: (flat-length) ( seq -- n )
[
{
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] }
} cond
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] }
} cond ;
! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable?
] [
2drop f
] if ;
: literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and
#! pushes some literals.
>r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
node-class-first r> class< ;
: optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it
#! immediately
dup evaluate-predicate swap
dup node-successor #if? [
dup drop-inputs >r
node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep
] [
swap 1array inline-literals
] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- )
dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [
node-out-d [ unused? ] all?
] [
drop f
] if ;
: flush-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all?
] [
drop f
] if ;
: literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node )
dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
] [
2drop f
] if ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
M: #call optimize-node*
{
{ [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] }
} cond dup not ;

2
core/optimizer/known-words/known-words.factor
View File

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays sequences.private combinators ;
optimizer.inlining float-arrays sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input

2
core/optimizer/math/math.factor
View File

@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
generic.standard system ;
optimizer.inlining generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }

52
core/optimizer/optimizer-tests.factor
View File

@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable ;
continuations growable optimizer.inlining namespaces ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -301,3 +301,53 @@ TUPLE: silly-tuple a b ;
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression
: lift-throw-tail-regression
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- )
over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1
] [
over 0 < [
2drop
] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1
] if
] if ; inline
: lift-loop-tail-test-2
10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
: generic-inline-test-1
1
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test
generic-inline-test ;
[ { t f } ] [
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
] unit-test

6
core/optimizer/optimizer.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class ;
optimizer.known-words optimizer.math optimizer.control
optimizer.inlining inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@ -11,6 +12,7 @@ IN: optimizer
H{ } clone value-substitutions set
dup compute-def-use
kill-values
dup detect-loops
dup infer-classes
optimizer-changed off
optimize-nodes

2
core/optimizer/specializers/specializers.factor
View File

@ -24,7 +24,7 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( word -- alist )
: specializer-methods ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append

11
core/parser/parser-docs.factor
View File

@ -266,19 +266,10 @@ HELP: escape
{ $description "Converts from a single-character escape code and the corresponding character." }
{ $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ;
HELP: next-escape
{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
{ $description "Helper word for " { $link parse-string } " which parses an escape sequence starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." }
{ $errors "Throws a " { $link bad-escape } " if the string contains an invalid escape sequence." } ;
HELP: next-char
{ $values { "m" "an index into " { $snippet "str" } } { "str" string } { "n" "an index into " { $snippet "str" } } { "ch" "a character" } }
{ $description "Helper word for " { $link parse-string } " which parses a character starting at the " { $snippet "m" } "th index of " { $snippet "str" } "." } ;
HELP: parse-string
{ $values { "str" "a new " { $link string } } }
{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." }
{ $errors "Throws an " { $link bad-escape } " if the string contains an invalid escape sequence." }
{ $errors "Throws an error if the string contains an invalid escape sequence." }
$parsing-note ;
HELP: still-parsing?

43
core/parser/parser.factor
View File

@ -119,22 +119,43 @@ M: bad-escape summary drop "Bad escape code" ;
{ CHAR: \" CHAR: \" }
} at [ bad-escape ] unless* ;
: next-escape ( m str -- n ch )
2dup nth CHAR: u =
[ >r 1+ dup 6 + tuck r> subseq hex> ]
[ over 1+ -rot nth escape ] if ;
SYMBOL: name>char-hook
: next-char ( m str -- n ch )
2dup nth CHAR: \\ =
[ >r 1+ r> next-escape ] [ over 1+ -rot nth ] if ;
name>char-hook global [
[ "Unicode support not available" throw ] or
] change-at
: (parse-string) ( m str -- n )
2dup nth CHAR: " =
[ drop 1+ ] [ [ next-char , ] keep (parse-string) ] if ;
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
CHAR: } over index cut-slice
>r >string name>char-hook get call r>
1 tail-slice
] [
6 cut-slice >r hex> r>
] if ;
: next-escape ( str -- ch str' )
"u" ?head-slice [
unicode-escape
] [
unclip-slice escape swap
] if ;
: (parse-string) ( str -- m )
dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> 1 tail-slice r>
dup CHAR: " = [
drop slice-from
] [
drop next-escape >r , r> (parse-string)
] if
] [
"Unterminated string" throw
] if ;
: parse-string ( -- str )
lexer get [
[ (parse-string) ] "" make swap
[ swap tail-slice (parse-string) ] "" make swap
] change-column ;
TUPLE: parse-error file line col text ;

2
core/sequences/sequences.factor
View File

@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence
: check-copy ( src n dst -- )
over 0 < [ bounds-error ] when
>r swap length + r> lengthen ;
>r swap length + r> lengthen ; inline
PRIVATE>

23
core/syntax/syntax-docs.factor
View File

@ -100,13 +100,9 @@ ARTICLE: "escape" "Character escape codes"
{ { $snippet "\\0" } "a null byte (ASCII 0)" }
{ { $snippet "\\e" } "escape (ASCII 27)" }
{ { $snippet "\\\"" } { $snippet "\"" } }
}
"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:"
{ $code
"CHAR: \\u000078"
"78"
}
"While not useful for single characters, this syntax is also permitted inside strings." ;
{ { $snippet "\\u" { $emphasis "xxxxxx" } } { "The Unicode code point with hexadecimal number " { $snippet { $emphasis "xxxxxx" } } } }
{ { $snippet "\\u{" { $emphasis "name" } "}" } { "The Unicode code point named " { $snippet { $emphasis "name" } } } }
} ;
ARTICLE: "syntax-strings" "Character and string syntax"
"Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof."
@ -412,8 +408,17 @@ HELP: IN:
HELP: CHAR:
{ $syntax "CHAR: token" }
{ $values { "token" "a literal character or escape code" } }
{ $description "Adds the Unicode code point of the character represented by the token to the parse tree." } ;
{ $values { "token" "a literal character, escape code, or Unicode character name" } }
{ $description "Adds a Unicode code point to the parse tree." }
{ $examples
{ $code
"CHAR: x"
"CHAR: \\u000032"
"CHAR: \\u{exclamation-mark}"
"CHAR: exclamation-mark"
"CHAR: ugaritic-letter-samka"
}
} ;
HELP: "
{ $syntax "\"string...\"" }

12
core/syntax/syntax.factor
View File

@ -5,7 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting tuples generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units ;
classes.union classes.mixin classes.predicate compiler.units
combinators ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -56,7 +57,14 @@ IN: bootstrap.syntax
"f" [ f parsed ] define-syntax
"t" "syntax" lookup define-symbol
"CHAR:" [ 0 scan next-char nip parsed ] define-syntax
"CHAR:" [
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape drop ] }
{ [ t ] [ name>char-hook get call ] }
} cond parsed
] define-syntax
"\"" [ parse-string parsed ] define-syntax
"SBUF\"" [

4
core/threads/threads-docs.factor Normal file → Executable file
View File

@ -9,6 +9,7 @@ $nl
{ $subsection in-thread }
{ $subsection yield }
{ $subsection sleep }
"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:"
{ $subsection stop }
"Continuations can be added to the run queue directly:"
{ $subsection schedule-thread }
@ -21,7 +22,8 @@ ABOUT: "threads"
HELP: run-queue
{ $values { "queue" dlist } }
{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ;
{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front }
" and dequeued with " { $link pop-back } "." } ;
HELP: schedule-thread
{ $values { "continuation" "a continuation reified by " { $link callcc0 } } }

12
core/vocabs/loader/loader.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs
words vocabs definitions parser continuations inspector debugger
io io.styles io.streams.lines hashtables sorting prettyprint
source-files arrays combinators strings system math.parser
compiler.errors ;
USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations inspector debugger io io.styles
io.streams.lines hashtables sorting prettyprint source-files
arrays combinators strings system math.parser compiler.errors
splitting ;
IN: vocabs.loader
SYMBOL: vocab-roots
@ -16,7 +16,7 @@ V{
} clone vocab-roots set-global
: vocab-dir ( vocab -- dir )
vocab-name "." split "/" join ;
vocab-name { { CHAR: . CHAR: / } } substitute ;
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>

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

@ -245,8 +245,8 @@ HELP: remove-word-prop
{ $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." }
{ $side-effects "word" } ;
HELP: word-xt
{ $values { "word" word } { "xt" "an execution token integer" } }
HELP: word-xt ( word -- start end )
{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } }
{ $description "Outputs the machine code address of the word's definition." } ;
HELP: define-symbol

2
extra/benchmark/benchmark.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require
[ [ run ] benchmark ] [ error. f f ] recover 2array
[ [ run ] benchmark ] [ error. drop f f ] recover 2array
dup . ;
: run-benchmarks ( -- assoc )

14
extra/benchmark/bootstrap2/bootstrap2.factor
View File

@ -1,14 +0,0 @@
USING: io.files io.launcher system bootstrap.image
namespaces sequences kernel ;
IN: benchmark.bootstrap2
: bootstrap-benchmark
"." resource-path cd
[
vm ,
"-i=" my-boot-image-name append ,
"-output-image=foo.image" ,
"-no-user-init" ,
] { } make try-process ;
MAIN: bootstrap-benchmark

15
extra/benchmark/sockets/sockets.factor
View File

@ -22,7 +22,7 @@ IN: benchmark.sockets
CHAR: x write1
] with-stream ;
: socket-benchmark ( n -- )
: clients ( n -- )
dup pprint " clients: " write
[
[ simple-server ] in-thread
@ -33,11 +33,12 @@ IN: benchmark.sockets
] time ;
: socket-benchmarks
10 socket-benchmark
20 socket-benchmark
40 socket-benchmark
80 socket-benchmark
160 socket-benchmark
320 socket-benchmark ;
10 clients
20 clients
40 clients
80 clients
160 clients
320 clients
640 clients ;
MAIN: socket-benchmarks

3
extra/bootstrap/handbook/handbook.factor Executable file
View File

@ -0,0 +1,3 @@
USING: vocabs.loader vocabs kernel ;
"bootstrap.help" vocab [ "help.handbook" require ] when

4
extra/bootstrap/help/help.factor
View File

@ -14,8 +14,6 @@ IN: bootstrap.help
[ vocab-root ] subset
[ vocab-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
] with-variable
"help.handbook" require ;
] with-variable ;
load-help

3
extra/bootstrap/tools/tools.factor
View File

@ -4,10 +4,11 @@ USING: vocabs.loader sequences ;
"bootstrap.image"
"tools.annotations"
"tools.crossref"
! "tools.deploy"
"tools.deploy"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"tools.disassembler"
"editors"
} [ require ] each

185
extra/builder/builder.factor
View File

@ -3,71 +3,43 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
arrays system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
combinators.cleave benchmark
classes strings quotations words parser-combinators new-slots accessors
assocs.lib smtp builder.util ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: runtime ( quot -- time ) benchmark nip ;
SYMBOL: builds-dir
: builds ( -- path )
builds-dir get
home "/builds" append
or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-recipients
: host-name* ( -- name ) host-name "." split first ;
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
: email-string ( subject -- )
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
[ ] with-process-stream drop ;
: email-file ( subject file -- )
`{
{ +stdin+ , }
{ +arguments+
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
}
>hashtable run-process drop ;
: prepare-build-machine ( -- )
builds make-directory
builds cd
{ "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
{ "winnt" [ "./factor-nt.exe" ] }
[ drop "./factor" ] }
case ;
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
VAR: stamp
: enter-build-dir ( -- )
datestamp >stamp
"/builds" cd
builds cd
stamp> make-directory
stamp> cd ;
@ -80,57 +52,59 @@ VAR: stamp
: make-clean ( -- desc ) { "make" "clean" } ;
: make-vm ( -- )
`{
{ +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" }
{ +stderr+ +stdout+ }
}
>hashtable ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
: make-vm ( -- desc )
<process*>
{ "make" target } to-strings >>arguments
"../compile-log" >>stdout
+stdout+ >>stderr
>desc ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
{ "winnt" [ "./factor-nt.exe" ] }
[ drop "./factor" ] }
case ;
: bootstrap-cmd ( -- cmd )
{ factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
to-strings ;
: bootstrap ( -- desc )
`{
{ +arguments+ {
,[ factor-binary ]
,[ "-i=" my-boot-image-name append ]
"-no-user-init"
} }
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
}
>hashtable ;
<process*>
bootstrap-cmd >>arguments
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
20 minutes>ms >>timeout
>desc ;
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) <file-reader> contents eval ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cat ( file -- ) <file-reader> contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] curry ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build) ( -- )
builds-check
build-status off
enter-build-dir
"report" [
"Build machine: " write host-name print
"Build directory: " write cwd print
"CPU: " write cpu print
"OS: " write os print
"Build directory: " write cwd print nl
git-clone [ "git clone failed" print ] run-or-bail
@ -142,7 +116,7 @@ SYMBOL: build-status
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
[ my-arch download-image ] [ "Image download error" print throw ] recover
[ retrieve-image ] [ "Image download error" print throw ] recover
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
@ -152,20 +126,50 @@ SYMBOL: build-status
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
"Load time: " write "../load-time" eval-file milli-seconds>time print
"Test time: " write "../test-time" eval-file milli-seconds>time print
"Test time: " write "../test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat
] with-file-out ;
"Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
: build ( -- )
[ (build) ] [ drop ] recover
"report" "../report" email-file ;
] with-file-out
build-status on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: minutes>ms ( min -- ms ) 60 * 1000 * ;
SYMBOL: builder-from
SYMBOL: builder-recipients
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
: send-builder-email ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"../report" file>string >>body
send ;
: build ( -- )
[ (build) ] [ drop ] recover
[ send-builder-email ] [ drop "not sending mail" . ] recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
@ -174,8 +178,9 @@ SYMBOL: build-status
= not ;
: build-loop ( -- )
builds-check
[
"/builds/factor" cd
builds "/factor" append cd
updates-available?
[ build ]
when

46
extra/builder/server/server.factor
View File

@ -41,28 +41,28 @@ IN: builder.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build-server ( -- )
receive
{
{
"start"
[
build-status get "idle" =
build-status get f =
or
[
[ [ build ] [ drop ] recover "idle" build-status set-global ]
in-thread
]
when
]
}
! : build-server ( -- )
! receive
! {
! {
! "start"
! [
! build-status get "idle" =
! build-status get f =
! or
! [
! [ [ build ] [ drop ] recover "idle" build-status set-global ]
! in-thread
! ]
! when
! ]
! }
{
{ ?from ?tag "status" }
[ `{ ?tag ,[ build-status get ] } ?from send ]
}
}
match-cond
build-server ;
! {
! { ?from ?tag "status" }
! [ `{ ?tag ,[ build-status get ] } ?from send ]
! }
! }
! match-cond
! build-server ;

7
extra/builder/test/test.factor
View File

@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint
tools.browser
tools.test
bootstrap.stage2 ;
bootstrap.stage2 benchmark builder.util ;
IN: builder.test
@ -16,9 +16,12 @@ IN: builder.test
: do-tests ( -- )
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
: do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-out
[ do-load ] runtime "../load-time" [ . ] with-file-out
[ do-tests ] runtime "../test-time" [ . ] with-file-out ;
[ do-tests ] runtime "../test-time" [ . ] with-file-out
do-benchmarks ;
MAIN: do-all

86
extra/builder/util/util.factor Normal file
View File

@ -0,0 +1,86 @@
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
parser-combinators accessors assocs.lib
combinators.cleave bake calendar new-slots ;
IN: builder.util
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: runtime ( quot -- time ) benchmark nip ;
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: to-strings
: to-string ( obj -- str )
dup class
{
{ string [ ] }
{ quotation [ call ] }
{ word [ execute ] }
{ fixnum [ number>string ] }
{ array [ to-strings concat ] }
}
case ;
: to-strings ( seq -- str )
dup [ string? ] all?
[ ]
[ [ to-string ] map flatten ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: process* arguments stdin stdout stderr timeout ;
: <process*> process* construct-empty ;
: >desc ( process* -- desc )
H{ } clone
over arguments>> [ +arguments+ swap put-at ] when*
over stdin>> [ +stdin+ swap put-at ] when*
over stdout>> [ +stdout+ swap put-at ] when*
over stderr>> [ +stderr+ swap put-at ] when*
over timeout>> [ +timeout+ swap put-at ] when*
nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) file-contents eval ;
: cat ( file -- ) file-contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] compose ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: bootstrap.image bootstrap.image.download io.streams.null ;
: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;

24
extra/const/const.factor
View File

@ -1,24 +0,0 @@
USING: kernel parser words sequences ;
IN: const
: define-const ( word value -- )
[ parsed ] curry dupd define
t "parsing" set-word-prop ;
: CONST:
CREATE scan-word dup parsing?
[ execute dup pop ] when define-const ; parsing
: define-enum ( words -- )
dup length [ define-const ] 2each ;
: ENUM:
";" parse-tokens [ create-in ] map define-enum ; parsing
: define-value ( word -- )
{ f } clone [ first ] curry define ;
: VALUE: CREATE define-value ; parsing
: set-value ( value word -- )
word-def first set-first ;

62
extra/db/db.factor
View File

@ -1,32 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ;
namespaces sequences sequences.lib tuples words strings ;
IN: db
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
TUPLE: db handle insert-statements update-statements delete-statements ;
: <db> ( handle -- obj )
H{ } clone
H{ } clone
H{ } clone
H{ } clone
H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: dispose-statements [ dispose drop ] assoc-each ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
dup db-select-statements dispose-statements
db-handle db-close
] with-variable ;
TUPLE: statement sql params handle bound? ;
TUPLE: statement sql params handle bound? slot-names ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
@ -35,7 +32,17 @@ HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: execute-statement ( statement -- )
GENERIC: insert-statement ( statement -- id )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
@ -43,19 +50,9 @@ GENERIC: execute-statement ( statement -- )
[ set-statement-params ] keep
t swap set-statement-bound? ;
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
HOOK: last-id db ( -- id )
: init-result-set ( result-set -- )
dup #rows over set-result-set-max
-1 swap set-result-set-n ;
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
@ -69,10 +66,10 @@ HOOK: last-id db ( -- id )
dup #columns [ row-column ] with map ;
: query-each ( statement quot -- )
over advance-row [
2drop
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
[ call ] 2keep query-each
2drop
] if ; inline
: query-map ( statement quot -- seq )
@ -93,11 +90,6 @@ HOOK: last-id db ( -- id )
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
<simple-statement> [ execute-statement ] with-disposal ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
@ -111,3 +103,15 @@ HOOK: rollback-transaction db ( -- )
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
<simple-statement> [ execute-statement ] with-disposal
] [
! [
[ sql-command ] each
! ] with-transaction
] if ;

2
extra/db/postgresql/ffi/ffi.factor
View File

@ -50,6 +50,8 @@ IN: db.postgresql.ffi
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType

6
extra/db/postgresql/lib/lib.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types ;
quotations sequences db.postgresql.ffi alien alien.c-types
db.types ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@ -37,7 +38,8 @@ IN: db.postgresql.lib
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params [ malloc-char-string ] map >c-void*-array
statement-params
[ first number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw

6
extra/db/postgresql/postgresql-tests.factor
View File

@ -2,7 +2,7 @@
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db ;
sequences namespaces tools.test db db.types ;
IN: temporary
IN: scratchpad
@ -40,13 +40,13 @@ IN: temporary
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
{ "Jane" "New Zealand" }
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ "John" "America" }
{ { "John" TEXT } { "America" TEXT } }
swap do-bound-query
] with-disposal
] with-db

180
extra/db/postgresql/postgresql.factor
View File

@ -1,8 +1,10 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
kernel math namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@ -51,11 +53,19 @@ M: postgresql-result-set #columns ( result-set -- n )
M: postgresql-result-set row-column ( result-set n -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
M: postgresql-statement execute-statement ( statement -- )
query-results dispose ;
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
>r row-column r> sql-type>factor-type ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
{
{ INTEGER [ string>number ] }
{ BIG_INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
[ drop ]
} case ;
M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
@ -67,8 +77,11 @@ M: postgresql-statement query-results ( query -- result-set )
postgresql-result-set <result-set>
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- ? )
dup increment-n swap result-set-max >= ;
M: postgresql-result-set advance-row ( result-set -- )
dup result-set-n 1+ swap set-result-set-n ;
M: postgresql-result-set more-rows? ( result-set -- ? )
dup result-set-n swap result-set-max < ;
M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear
@ -103,3 +116,154 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
: postgresql-type-hash* ( -- assoc )
H{
{ SERIAL "serial" }
} ;
: postgresql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ DOUBLE "real" }
} ;
: enquote ( str -- newstr ) "(" swap ")" 3append ;
: postgresql-type ( str n/str -- newstr )
" " swap number>string* enquote 3append ;
: >sql-type* ( obj -- str )
dup pair? [
first2 >r >sql-type* r> postgresql-type
] [
dup postgresql-type-hash* at* [
nip
] [
drop >sql-type
] if
] if ;
M: postgresql-db >sql-type ( hash obj -- str )
dup pair? [
first2 >r >sql-type r> postgresql-type
] [
postgresql-type-hash at* [
no-sql-type
] unless
] if ;
: insert-function ( columns table -- sql )
[
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
[ third dup array? [ first ] when >sql-type % ] interleave
")" %
" returns bigint as '" %
2dup "insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
"); " %
"select currval(''" % % "_id_seq'');' language sql;" %
drop
] "" make ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
[ "," % ] [ third >sql-type % ] interleave
")" %
] "" make ;
M: postgresql-db create-sql ( columns table -- seq )
[
[
2dup
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type* % " " %
sql-modifiers " " join %
] interleave "); " %
] "" make ,
over native-id? [ insert-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
[
dup "drop table " % % ";" %
] "" make ,
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
[
"select add_" % %
"(" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- slot-names sql )
[
"update " %
%
" set " %
dup remove-id
dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " %
[ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ;
M: postgresql-db delete-sql* ( columns table -- slot-names sql )
[
"delete from " %
%
" where " %
first second % " = $1" %
] "" make ;
M: postgresql-db select-sql ( columns table -- slot-names sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
: postgresql-db-modifiers ( -- hashtable )
H{
{ +native-id+ "not null primary key" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;

4
extra/db/sqlite/ffi/ffi.factor
View File

@ -108,7 +108,7 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
@ -125,6 +125,8 @@ FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

21
extra/db/sqlite/lib/lib.factor
View File

@ -30,7 +30,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare_v2 sqlite-check-result ] 2keep
[ sqlite3_prepare sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )
@ -74,10 +74,11 @@ IN: db.sqlite.lib
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG_INTEGER [ sqlite-bind-int-by-name ] }
{ BIG_INTEGER [ sqlite-bind-int64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -95,17 +96,25 @@ IN: db.sqlite.lib
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
: sqlite-column-typed ( handle index type -- obj )
{
{ INTEGER [ sqlite3_column_int ] }
{ BIG_INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
} case ;
! TODO
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
: step-complete? ( step-result -- bool )
: sqlite-step-has-more-rows? ( step-result -- bool )
dup SQLITE_ROW = [
drop f
drop t
] [
dup SQLITE_DONE =
[ drop ] [ sqlite-check-result ] if t
[ drop ] [ sqlite-check-result ] if f
] if ;
: sqlite-next ( prepared -- ? )
sqlite3_step step-complete? ;
sqlite3_step sqlite-step-has-more-rows? ;

57
extra/db/sqlite/sqlite.factor
View File

@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
@ -52,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement execute-statement ( statement -- )
statement-handle sqlite-next drop ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id )
execute-statement last-insert-id ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -61,11 +63,19 @@ M: sqlite-result-set #columns ( result-set -- n )
M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
M: sqlite-result-set advance-row ( result-set -- handle ? )
result-set-handle sqlite-next ;
M: sqlite-result-set row-column-typed ( result-set n type -- obj )
>r result-set-handle r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep
set-sqlite-result-set-has-more? ;
M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ;
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
@ -86,9 +96,10 @@ M: sqlite-db create-sql ( columns table -- sql )
] interleave ")" %
] "" make ;
M: sqlite-db drop-sql ( table -- sql )
M: sqlite-db drop-sql ( columns table -- sql )
[
"drop table " % %
drop
] "" make ;
M: sqlite-db insert-sql* ( columns table -- sql )
@ -103,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql )
")" %
] "" make ;
: where-primary-key% ( columns -- )
" where " %
[ primary-key? ] find nip second dup % " = :" % % ;
M: sqlite-db update-sql* ( columns table -- sql )
[
"update " %
@ -110,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql )
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
" where " %
[ primary-key? ] find nip second dup % " = :" % %
where-primary-key%
] "" make ;
M: sqlite-db delete-sql* ( columns table -- sql )
@ -122,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql )
first second dup % " = :" % %
] "" make ;
M: sqlite-db select-sql* ( columns table -- sql )
: select-interval ( interval name -- )
;
: select-sequence ( seq name -- )
;
M: sqlite-db select-sql ( columns table -- sql )
[
"select ROWID, " %
swap [ ", " % ] [ second % ] interleave
" from " %
%
" where ROWID = :ID" %
over [ ", " % ] [ second % ] interleave
" from " % %
" where " %
] "" make ;
M: sqlite-db tuple>params ( columns tuple -- obj )
@ -137,10 +156,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
M: sqlite-db last-id ( -- id )
db get db-handle sqlite3_last_insert_rowid ;
: sqlite-db-modifiers ( -- hashtable )
H{
@ -167,6 +182,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
: sqlite-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
@ -182,4 +198,3 @@ M: sqlite-db >sql-type ( obj -- str )
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;

42
extra/db/tuples/tuples-tests.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces ;
db.types continuations namespaces db.postgresql math ;
! tools.time ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
: <person> ( name age -- person )
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
@ -29,21 +30,22 @@ SYMBOL: the-person
[ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test ;
[ ] [ the-person get delete-tuple ] unit-test
; ! 1 [ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
test-tuples
] with-db ;
! : test-postgres ( -- )
! resource-path <postgresql-db> [
! test-tuples
! ] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
test-tuples
] with-db ;
person "PERSON"
{
{ "the-id" "ROWID" INTEGER +native-id+ }
{ "the-id" "ID" SERIAL +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
@ -51,18 +53,18 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set
test-sqlite
! test-postgres
! test-sqlite
test-postgresql
person "PERSON"
{
{ "the-id" "ROWID" INTEGER +assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
! person "PERSON"
! {
! { "the-id" "ID" INTEGER +assigned-id+ }
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
! { "the-number" "AGE" INTEGER { +default+ 0 } }
! { "real" "REAL" DOUBLE { +default+ 0.3 } }
! } define-persistent
1 "billy" 20 6.28 <assigned-person> the-person set
! 1 "billy" 20 6.28 <assigned-person> the-person set
test-sqlite
! test-postgres
! test-sqlite
! test-postgresql

49
extra/db/tuples/tuples.factor
View File

@ -38,12 +38,28 @@ TUPLE: no-slot-named ;
[ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- sql )
HOOK: drop-sql db ( table -- sql )
HOOK: insert-sql* db ( columns table -- sql )
HOOK: update-sql* db ( columns table -- sql )
HOOK: delete-sql* db ( columns table -- sql )
HOOK: select-sql* db ( columns table -- sql )
HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( columns table -- seq )
HOOK: insert-sql* db ( columns table -- slot-names sql )
HOOK: update-sql* db ( columns table -- slot-names sql )
HOOK: delete-sql* db ( columns table -- slot-names sql )
HOOK: select-sql db ( tuple -- statement )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
HOOK: tuple>params db ( columns tuple -- obj )
HOOK: make-slot-names* db ( quot -- seq )
HOOK: column-slot-name% db ( spec -- )
HOOK: column-bind-name% db ( spec -- )
: make-slots-names ( quot -- seq str )
[ make-column-names ] "" make ; inline
: slot-name% ( seq -- ) first % ;
: column-name% ( seq -- ) second % ;
: column-type% ( seq -- ) third % ;
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
@ -54,30 +70,29 @@ HOOK: select-sql* db ( columns table -- sql )
: delete-sql ( columns class -- statement )
db get db-delete-statements [ delete-sql* ] cache-statement ;
: select-sql ( columns class -- statement )
db get db-select-statements [ select-sql* ] cache-statement ;
HOOK: tuple>params db ( columns tuple -- obj )
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement execute-statement ;
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- )
db-table drop-sql sql-command ;
dup db-columns swap db-table drop-sql sql-command ;
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement
last-id
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement insert-statement
] keep set-primary-key ;
: update-tuple ( tuple -- )
@ -86,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
: delete-tuple ( tuple -- )
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
! : select-tuple ( tuple -- )
! [ select-sql ] bind-tuple do-query ;
: select-tuple ( tuple -- )
[ select-sql ] keep do-query ;
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;

7
extra/db/types/types.factor
View File

@ -11,6 +11,12 @@ SYMBOL: +assigned-id+
: primary-key? ( spec -- ? )
[ { +native-id+ +assigned-id+ } member? ] contains? ;
: contains-id? ( columns id -- ? )
swap [ member? ] with contains? ;
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
SYMBOL: +serial+
@ -22,6 +28,7 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER
SYMBOL: DOUBLE
SYMBOL: BOOLEAN

4
extra/delegate/protocols/protocols.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections
io definitions kernel ;
io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until
stream-read1 stream-read stream-read-until dispose
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table ;

153
extra/help/handbook/handbook.factor
View File

@ -1,8 +1,8 @@
USING: help help.markup help.syntax help.topics
namespaces words sequences classes assocs vocabs kernel
arrays prettyprint.backend kernel.private io tools.browser
generic math tools.profiler system ui strings sbufs vectors
byte-arrays bit-arrays float-arrays quotations help.lint ;
USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
@ -161,15 +161,20 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }
{ $subsection "tools.crossref" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "meta-interpreter" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }
{ $subsection "tools.test" }
{ $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
{ $subsection "tools.deploy" } ;
ARTICLE: "article-index" "Article index"
@ -201,7 +206,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "cookbook" }
{ $subsection "first-program" }
{ $subsection "vocab-index" }
{ $subsection "changes" }
{ $heading "Language reference" }
{ $subsection "conventions" }
{ $subsection "syntax" }
@ -231,137 +235,6 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "type-index" }
{ $subsection "class-index" } ;
USING: io.files io.sockets float-arrays inference ;
ARTICLE: "changes" "Changes in the latest release"
{ $heading "Factor 0.91" }
{ $subheading "Performance" }
{ $list
{ "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
{ "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
{ "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
{ "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." }
{ "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." }
{ "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" }
{ "Improved hash code algorithm for sequences" }
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
{ "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
}
{ $subheading "IO" }
{ $list
{ "More robust Windows CE native I/O" }
{ "New " { $link os-envs } " word to get the current set of environment variables" }
{ "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
{ { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
{ "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
{ { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
}
{ $subheading "Tools" }
{ $list
{ "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
{ "The deploy tool now supports Windows" }
{ { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
}
{ $subheading "UI" }
{ $list
{ { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
{ { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
{ { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
{ "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
{ "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" }
}
{ $subheading "Libraries" }
{ $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
{ "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
{ { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" }
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
{ { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
{ { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
{ { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
{ { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
{ { $vocab-link "webapps.planet" } " - add Atom feed generation" }
}
{ $heading "Factor 0.90" }
{ $subheading "Core" }
{ $list
{ "New module system; see " { $link "vocabs.loader" } ". (Eduardo Cavazos)" }
{ "Tuple constructors are defined differently now; see " { $link "tuple-constructors" } "." }
{ "Mixin classes implemented; these are essentially extensible unions. See " { $link "mixins" } "." }
{ "New " { $link float-array } " data type implements a space-efficient sequence of floats." }
{ "Moved " { $link <file-appender> } ", " { $link delete-file } ", " { $link make-directory } ", " { $link delete-directory } " words from " { $snippet "libs/io" } " into the core, and fixed them to work on more platforms." }
{ "New " { $link host-name } " word." }
{ "The " { $link directory } " word now outputs an array of pairs, with the second element of each pair indicating if that entry is a subdirectory. This saves an unnecessary " { $link stat } " call when traversing directory hierarchies, which speeds things up." }
{ "IPv6 is now supported, along with Unix domain sockets (the latter on Unix systems only). The stack effects of " { $link <client> } " and " { $link <server> } " have changed, since they now take generic address specifiers; see " { $link "network-streams" } "." }
{ "The stage 2 bootstrap process is more flexible, and various subsystems such as help, tools and the UI can be omitted by supplying command line switches; see " { $link "bootstrap-cli-args" } "." }
{ "The " { $snippet "-shell" } " command line switch has been replaced by a " { $snippet "-run" } " command line switch; see " { $link "standard-cli-args" } "." }
{ "Variable usage inference has been removed; the " { $link infer } " word no longer reports this information." }
}
{ $subheading "Tools" }
{ $list
{ "Stand-alone image deployment; see " { $link "tools.deploy" } "." }
{ "Stand-alone application bundle deployment on Mac OS X; see " { $vocab-link "tools.deploy.app" } "." }
{ "New vocabulary browser tool in the UI." }
{ "New profiler tool in the UI." }
}
{ $subheading "Extras" }
"Most existing libraries were improved when ported to the new module system; the most notable changes include:"
{ $list
{ { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" }
{ { $vocab-link "benchmark" } ": new set of benchmarks." }
{ { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" }
{ { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" }
{ { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" }
{ { $vocab-link "hints" } ": Give type specialization hints to the compiler." }
{ { $vocab-link "inverse" } ": Invertible computation and concatenative pattern matching. (Daniel Ehrenberg)" }
{ { $vocab-link "ldap" } ": OpenLDAP library binding. (Elie Chaftari)" }
{ { $vocab-link "locals" } ": Efficient lexically scoped locals, closures, and local words." }
{ { $vocab-link "mortar" } ": Experimental message-passing object system. (Eduardo Cavazos)" }
{ { $vocab-link "openssl" } ": OpenSSL library binding. (Elie Chaftari)" }
{ { $vocab-link "pack" } ": Utility for reading and writing binary data. (Doug Coleman)" }
{ { $vocab-link "pdf" } ": Haru PDF library binding. (Elie Chaftari)" }
{ { $vocab-link "qualified" } ": Refer to words from another vocabulary without adding the entire vocabulary to the search path. (Daniel Ehrenberg)" }
{ { $vocab-link "roman" } ": Reading and writing Roman numerals. (Doug Coleman)" }
{ { $vocab-link "scite" } ": SciTE editor integration. (Clemens Hofreither)" }
{ { $vocab-link "smtp" } ": SMTP client with support for CRAM-MD5 authentication. (Elie Chaftari, Dirk Vleugels)" }
{ { $vocab-link "tuple-arrays" } ": Space-efficient packed tuple arrays. (Daniel Ehrenberg)" }
{ { $vocab-link "unicode" } ": major new functionality added. (Daniel Ehrenberg)" }
}
{ $subheading "Performance" }
{ $list
{ "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "with each" } ", and similarly for other " { $snippet "-with" } " combinators." }
"Improved generational promotion strategy in garbage collector reduces the amount of junk which makes its way into tenured space, which in turn reduces the frequency of full garbage collections."
"Faster generic word dispatch and union membership testing."
{ "Alien memory accessors (" { $link "reading-writing-memory" } ") are compiled as intrinsics where possible, which improves performance in code which iteroperates with C libraries." }
}
{ $subheading "Platforms" }
{ $list
"Networking support added for Windows CE. (Doug Coleman)"
"UDP/IP networking support added for all Windows platforms. (Doug Coleman)"
"Solaris/x86 fixes. (Samuel Tardieu)"
"Linux/AMD64 port works again."
} ;
{ <array> <string> <sbuf> <vector> <byte-array> <bit-array> <float-array> }
related-words

2
extra/http/http.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ascii io.utf8 assocs.lib
sequences strings splitting ascii io.encodings.utf8 assocs.lib
namespaces unicode.case ;
IN: http

29
extra/icfp/2006/2006.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io io.files
splitting io.binary math.functions vectors quotations sequences.private ;
USING: kernel math sequences kernel.private namespaces arrays io
io.files splitting io.binary math.functions vectors quotations
combinators ;
IN: icfp.2006
SYMBOL: regs
@ -9,10 +10,6 @@ SYMBOL: arrays
SYMBOL: finger
SYMBOL: open-arrays
: call-nth ( n array -- )
>r >fixnum r> 2dup nth quotation?
[ dispatch ] [ "Not a quotation" throw ] if ; inline
: reg-val ( m -- n ) regs get nth ;
: set-reg ( val n -- ) regs get set-nth ;
@ -117,11 +114,21 @@ SYMBOL: open-arrays
: run-op ( -- bool )
advance
{
[ op0 ] [ op1 ] [ op2 ] [ op3 ]
[ op4 ] [ op5 ] [ op6 ] [ drop t ]
[ op8 ] [ op9 ] [ op10 ] [ op11 ]
[ op12 ] [ op13 ]
} call-nth ;
{ 0 [ op0 ] }
{ 1 [ op1 ] }
{ 2 [ op2 ] }
{ 3 [ op3 ] }
{ 4 [ op4 ] }
{ 5 [ op5 ] }
{ 6 [ op6 ] }
{ 7 [ drop t ] }
{ 8 [ op8 ] }
{ 9 [ op9 ] }
{ 10 [ op10 ] }
{ 11 [ op11 ] }
{ 12 [ op12 ] }
{ 13 [ op13 ] }
} case ;
: exec-loop ( bool -- )
[ run-op exec-loop ] unless ;

6
extra/io/launcher/launcher-docs.factor
View File

@ -90,6 +90,10 @@ HELP: get-environment
{ $values { "env" "an association" } }
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
HELP: current-process-handle
{ $values { "handle" "a process handle" } }
{ $description "Returns the handle of the current process." } ;
HELP: run-process*
{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
{ $contract "Launches a process using the launch descriptor." }
@ -186,6 +190,8 @@ ARTICLE: "io.launcher" "Launching OS processes"
{ $subsection try-process }
"Stopping processes:"
{ $subsection kill-process }
"Finding the current process handle:"
{ $subsection current-process-handle }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream }

6
extra/io/launcher/launcher.factor
View File

@ -76,6 +76,8 @@ SYMBOL: +append-environment+
{ [ dup assoc? ] [ >hashtable ] }
} cond ;
HOOK: current-process-handle io-backend ( -- handle )
HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status )
@ -119,7 +121,9 @@ HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;
: <process-stream> ( desc -- stream )
>descriptor process-stream*
>descriptor
[ process-stream* ] keep
+timeout+ swap at [ over set-timeout ] when*
{ set-delegate set-process-stream-process }
process-stream construct ;

13
extra/io/unix/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.unix.backend io.unix.files
io.nonblocking sequences kernel namespaces math system
alien.c-types debugger continuations arrays assocs
combinators unix.process parser-combinators memoize
promises strings threads ;
promises strings threads unix ;
IN: io.unix.launcher
! Search unix first
@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser )
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
+stdin+ get ?closed read-flags 0 redirect
+stdout+ get ?closed write-flags 1 redirect
+stderr+ get dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
[ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
: spawn-process ( -- )
[
@ -70,6 +71,8 @@ MEMO: 'arguments' ( -- parser )
io-error
] [ error. :c flush ] recover 1 exit ;
M: unix-io current-process-handle ( -- handle ) getpid ;
M: unix-io run-process* ( desc -- pid )
[
[ spawn-process ] [ ] with-fork <process>

68
extra/io/windows/launcher/launcher.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows io.windows.pipes libc io.nonblocking
io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators io.backend ;
@ -87,75 +87,29 @@ TUPLE: CreateProcess-args
over set-CreateProcess-args-lpEnvironment
] when ;
: (redirect) ( path access-mode create-mode -- handle )
>r >r
normalize-pathname
r> ! access-mode
share-mode
security-attributes-inherit
r> ! create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ 3drop t ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: fill-startup-info
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
over redirect-stdout over set-STARTUPINFO-hStdOutput
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
HOOK: fill-redirection io-backend ( args -- args )
drop ;
M: windows-ce-io fill-redirection ;
: make-CreateProcess-args ( -- args )
default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment ;
fill-lpEnvironment
fill-startup-info ;
M: windows-io current-process-handle ( -- handle )
GetCurrentProcessId ;
M: windows-io run-process* ( desc -- handle )
[
[
make-CreateProcess-args fill-startup-info
make-CreateProcess-args
fill-redirection
dup call-CreateProcess
CreateProcess-args-lpProcessInformation <process>
] with-descriptor

4
extra/io/windows/nt/files/files.factor
View File

@ -2,7 +2,7 @@ USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 alien.c-types
alien.arrays sequences combinators combinators.lib sequences.lib
ascii splitting alien strings ;
ascii splitting alien strings assocs ;
IN: io.windows.nt.files
M: windows-nt-io cwd
@ -60,7 +60,7 @@ M: windows-nt-io root-directory? ( path -- ? )
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join
{ { CHAR: / CHAR: \\ } } substitute
cwd swap windows-path+
[ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;

66
extra/io/windows/nt/launcher/launcher.factor
View File

@ -3,13 +3,63 @@
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system
io.windows.launcher io.windows.pipes ;
sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend
combinators ;
IN: io.windows.nt.launcher
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle )
>r >r
normalize-pathname
r> ! access-mode
share-mode
security-attributes-inherit
r> ! create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
@ -30,14 +80,22 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit
over set-CreateProcess-args-stdin-pipe ;
M: windows-io process-stream*
M: windows-nt-io fill-redirection
dup CreateProcess-args-lpStartupInfo
over redirect-stdout over set-STARTUPINFO-hStdOutput
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
drop ;
M: windows-nt-io process-stream*
[
[
make-CreateProcess-args
fill-stdout-pipe
fill-stdin-pipe
fill-startup-info
fill-redirection
dup call-CreateProcess

Some files were not shown because too many files have changed in this diff Show More