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

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

db4
Bruno Deferrari 2008-09-17 12:28:22 -03:00
parent 4bd73a1eb7 de68e712e9
commit 74916a9162
66 changed files with 4370 additions and 1119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/compiler/constants/constants.factor
View File

@ -23,3 +23,30 @@ IN: compiler.constants
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;

6
basis/db/types/types.factor
View File

@ -113,12 +113,6 @@ ERROR: no-sql-type ;
(lookup-type) second
] if ;
: paren ( string -- new-string )
"(" swap ")" 3append ;
: join-space ( string1 string2 -- new-string )
" " swap 3append ;
: modifiers ( spec -- string )
modifiers>> [ lookup-modifier ] map " " join
[ "" ] [ " " prepend ] if-empty ;

1
basis/help/handbook/handbook.factor
View File

@ -108,6 +108,7 @@ USE: io.buffers
ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsection "sequences" }
{ $subsection "virtual-sequences" }
{ $subsection "namespaces-make" }
"Fixed-length sequences:"
{ $subsection "arrays" }

2
basis/io/unix/linux/monitors/monitors-tests.factor
View File

@ -10,6 +10,7 @@ threads calendar prettyprint destructors io.timeouts ;
! Non-recursive
[ ] [ "monitor-test-self" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
@ -22,6 +23,7 @@ threads calendar prettyprint destructors io.timeouts ;
! Recursive
[ ] [ "monitor-test-self" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test

3
basis/tools/scaffold/scaffold.factor
View File

@ -115,6 +115,7 @@ ERROR: no-vocab vocab ;
{ "seq3" sequence } { "seq4" sequence }
{ "seq1'" sequence } { "seq2'" sequence }
{ "newseq" sequence }
{ "seq'" sequence }
{ "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
{ "assoc3" assoc } { "newassoc" assoc }
{ "alist" "an array of key/value pairs" }
@ -157,7 +158,7 @@ ERROR: no-vocab vocab ;
"{ $description \"\" } ;" print ;
: help-header. ( word -- )
"HELP: " write name>> print ;
"HELP: " write . ;
: (help.) ( word -- )
[ help-header. ] [ $values. ] [ $description. ] tri ;

6
build-support/factor.sh
View File

@ -175,6 +175,7 @@ find_os() {
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
SunOS) OS=solaris;;
esac
}
@ -186,6 +187,7 @@ find_architecture() {
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
i86pc) ARCH=x86;;
amd64) ARCH=x86;;
ppc64) ARCH=ppc;;
*86) ARCH=x86;;
@ -261,6 +263,8 @@ check_os_arch_word() {
$ECHO "ARCH: $ARCH"
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
echo $MAKE_TARGET
exit 5
fi
}
@ -486,6 +490,8 @@ usage() {
echo " $0 update macosx-x86-32"
}
MAKE_TARGET=unknown
# -n is nonzero length, -z is zero length
if [[ -n "$2" ]] ; then
parse_build_info $2

42
core/continuations/continuations-docs.factor
View File

@ -77,6 +77,9 @@ $nl
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
"Continuations as control-flow:"
{ $subsection attempt-all }
{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
@ -211,3 +214,42 @@ HELP: with-datastack
{ $examples
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
HELP: <continuation>
{ $description "Constructs a new continuation." }
{ $notes "User code should call " { $link continuation } " instead." } ;
HELP: attempt-all
{ $values
{ "seq" sequence } { "quot" quotation }
{ "obj" object } }
{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
{ $examples "The first two numbers throw, the last one doesn't:"
{ $example
"USING: prettyprint continuations kernel math ;"
"{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
"6" }
"All quotations throw, the last exception is rethrown:"
{ $example
"USING: prettyprint continuations kernel math ;"
"[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
"5"
}
} ;
HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
HELP: with-return
{ $values
{ "quot" quotation } }
{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
{ $examples
"Only \"Hi\" will print:"
{ $example
"USING: prettyprint continuations io ;"
"[ \"Hi\" print return \"Bye\" print ] with-return"
"Hi"
} } ;
{ return with-return } related-words

8
core/destructors/destructors-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax libc kernel continuations io ;
USING: help.markup help.syntax libc kernel continuations io
sequences ;
IN: destructors
HELP: dispose
@ -45,6 +46,11 @@ HELP: |dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
HELP: dispose-each
{ $values
{ "seq" sequence } }
{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ;
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code

6
core/hashtables/hashtables-docs.factor
View File

@ -111,6 +111,12 @@ HELP: associate
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
{ $description "Create a new hashtable holding one key/value pair." } ;
HELP: ?set-at
{ $values
{ "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } }
{ "assoc" assoc } }
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
HELP: >hashtable
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;

258
core/io/io-docs.factor
View File

@ -1,128 +1,7 @@
USING: help.markup help.syntax quotations hashtables kernel
classes strings continuations destructors ;
classes strings continuations destructors math ;
IN: io
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
"Three words are required for input streams:"
{ $subsection stream-read1 }
{ $subsection stream-read }
{ $subsection stream-read-until }
{ $subsection stream-readln }
"Seven words are required for output streams:"
{ $subsection stream-flush }
{ $subsection stream-write1 }
{ $subsection stream-write }
{ $subsection stream-format }
{ $subsection stream-nl }
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "Default input and output streams"
"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
{ $list
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
{ "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
}
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader>"
"dup stream-readln number>string over stream-read 16 group"
"swap dispose"
}
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
" dup stream-readln number>string over stream-read"
" 16 group"
"] with-disposal"
}
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
" readln number>string read 16 group"
"] with-input-stream"
}
"An even better implementation that takes advantage of a utility word:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 ["
" readln number>string read 16 group"
"] with-file-reader"
}
"The default input stream is stored in a dynamically-scoped variable:"
{ $subsection input-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
$nl
"Words reading from the default input stream:"
{ $subsection read1 }
{ $subsection read }
{ $subsection read-until }
{ $subsection readln }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
"The default output stream is stored in a dynamically-scoped variable:"
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
"Words writing to the default input stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
"Formatted output:"
{ $subsection format }
{ $subsection with-style }
{ $subsection with-nesting }
"Tabular output:"
{ $subsection tabular-output }
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
"A pair of combinators for rebinding both default streams at once:"
{ $subsection with-streams }
{ $subsection with-streams* } ;
ARTICLE: "stream-utils" "Stream utilities"
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
$nl
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
{ $subsection stream-print }
"Sluring an entire stream into memory all at once:"
{ $subsection lines }
{ $subsection contents }
"Copying the contents of one stream to another:"
{ $subsection stream-copy } ;
ARTICLE: "streams" "Streams"
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
$nl
"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
{ $subsection "stream-utils" }
{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
ABOUT: "streams"
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
@ -147,6 +26,12 @@ HELP: stream-read-until
{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-read-partial
{ $values
{ "n" integer } { "stream" "an input stream" }
{ "str/f" "a string or " { $link f } } }
{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
HELP: stream-write1
{ $values { "ch" "a character" } { "stream" "an output stream" } }
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
@ -249,6 +134,12 @@ HELP: read-until
{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
$io-error ;
HELP: read-partial
{ $values
{ "n" null }
{ "str/f" null } }
{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
HELP: write1
{ $values { "ch" "a character" } }
{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
@ -363,3 +254,126 @@ HELP: contents
{ $values { "stream" "an input stream" } { "str" string } }
{ $description "Reads the entire contents of a stream into a string." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
"These words are required for input streams:"
{ $subsection stream-read1 }
{ $subsection stream-read }
{ $subsection stream-read-until }
{ $subsection stream-readln }
{ $subsection stream-read-partial }
"These words are required for output streams:"
{ $subsection stream-flush }
{ $subsection stream-write1 }
{ $subsection stream-write }
{ $subsection stream-format }
{ $subsection stream-nl }
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "Default input and output streams"
"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
{ $list
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
{ "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
}
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader>"
"dup stream-readln number>string over stream-read 16 group"
"swap dispose"
}
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
" dup stream-readln number>string over stream-read"
" 16 group"
"] with-disposal"
}
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
" readln number>string read 16 group"
"] with-input-stream"
}
"An even better implementation that takes advantage of a utility word:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 ["
" readln number>string read 16 group"
"] with-file-reader"
}
"The default input stream is stored in a dynamically-scoped variable:"
{ $subsection input-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
$nl
"Words reading from the default input stream:"
{ $subsection read1 }
{ $subsection read }
{ $subsection read-until }
{ $subsection readln }
{ $subsection read-partial }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
"The default output stream is stored in a dynamically-scoped variable:"
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
"Words writing to the default input stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
"Formatted output:"
{ $subsection format }
{ $subsection with-style }
{ $subsection with-nesting }
"Tabular output:"
{ $subsection tabular-output }
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
"A pair of combinators for rebinding both default streams at once:"
{ $subsection with-streams }
{ $subsection with-streams* } ;
ARTICLE: "stream-utils" "Stream utilities"
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
$nl
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
{ $subsection stream-print }
"Sluring an entire stream into memory all at once:"
{ $subsection lines }
{ $subsection contents }
"Copying the contents of one stream to another:"
{ $subsection stream-copy } ;
ARTICLE: "streams" "Streams"
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
$nl
"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
{ $subsection "stream-utils" }
{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
ABOUT: "streams"

2
core/io/io.factor
View File

@ -8,7 +8,7 @@ GENERIC: stream-readln ( stream -- str/f )
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )
GENERIC: stream-read-until ( seps stream -- str/f sep/f )
GENERIC: stream-read-partial ( max stream -- str/f )
GENERIC: stream-read-partial ( n stream -- str/f )
GENERIC: stream-write1 ( ch stream -- )
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )

582
core/kernel/kernel-docs.factor
View File

@ -4,289 +4,6 @@ kernel.private vectors combinators quotations strings words
assocs arrays math.order ;
IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
$nl
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
$nl
"Removing stack elements:"
{ $subsection drop }
{ $subsection 2drop }
{ $subsection 3drop }
{ $subsection nip }
{ $subsection 2nip }
"Duplicating stack elements:"
{ $subsection dup }
{ $subsection 2dup }
{ $subsection 3dup }
{ $subsection dupd }
{ $subsection over }
{ $subsection 2over }
{ $subsection pick }
{ $subsection tuck }
"Permuting stack elements:"
{ $subsection swap }
{ $subsection swapd }
{ $subsection rot }
{ $subsection -rot }
{ $subsection spin }
{ $subsection roll }
{ $subsection -roll }
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
{ $subsection >r }
{ $subsection r> }
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
{ $example "1 2 3 >r .s r>" "1\n2" }
"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
$nl
"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
$nl
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
{ $code
": keep [ ] bi ;"
": 2keep [ ] 2bi ;"
": 3keep [ ] 3bi ;"
""
": dup [ ] [ ] bi ;"
": 2dup [ ] [ ] 2bi ;"
": 3dup [ ] [ ] 3bi ;"
""
": tuck [ nip ] [ ] 2bi ;"
": swap [ nip ] [ drop ] 2bi ;"
""
": over [ ] [ drop ] 2bi ;"
": pick [ ] [ 2drop ] 3bi ;"
": 2over [ ] [ drop ] 3bi ;"
} ;
ARTICLE: "cleave-combinators" "Cleave combinators"
"The cleave combinators apply multiple quotations to a single value."
$nl
"Two quotations:"
{ $subsection bi }
{ $subsection 2bi }
{ $subsection 3bi }
"Three quotations:"
{ $subsection tri }
{ $subsection 2tri }
{ $subsection 3tri }
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
"[ 1 + ] keep"
"[ 1 - ] keep"
"2 *"
"! Second alternative: uses tri"
"[ 1 + ]"
"[ 1 - ]"
"[ 2 * ] tri"
}
"The latter is more aesthetically pleasing than the former."
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
$nl
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
{ $code
": dip [ ] bi* ;"
": 2dip [ ] [ ] tri* ;"
""
": slip [ call ] [ ] bi* ;"
": 2slip [ call ] [ ] [ ] tri* ;"
""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
": rot"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
""
": -rot"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" 3tri ;"
""
": spin"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
} ;
ARTICLE: "spread-combinators" "Spread combinators"
"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
$nl
"Two quotations:"
{ $subsection bi* }
{ $subsection 2bi* }
"Three quotations:"
{ $subsection tri* }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses retain stack explicitly"
">r >r 1 +"
"r> 1 -"
"r> 2 *"
"! Second alternative: uses tri*"
"[ 1 + ]"
"[ 1 - ]"
"[ 2 * ] tri*"
}
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
{ $subsection bi@ }
{ $subsection 2bi@ }
"Three quotations:"
{ $subsection tri@ }
"A pair of utility words built from " { $link bi@ } ":"
{ $subsection both? }
{ $subsection either? } ;
ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
{ $subsection slip }
{ $subsection 2slip }
{ $subsection 3slip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
{ $subsection 3keep } ;
ARTICLE: "compositional-combinators" "Compositional combinators"
"Quotations can be composed using efficient quotation-specific operations:"
{ $subsection curry }
{ $subsection 2curry }
{ $subsection 3curry }
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
{ $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
ARTICLE: "implementing-combinators" "Implementing combinators"
"The following pair of words invoke words and quotations reflectively:"
{ $subsection call }
{ $subsection execute }
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
"Word inlining is documented in " { $link "declarations" } "." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
{ $subsection f }
{ $subsection t }
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
$nl
"Here is the " { $link f } " object:"
{ $example "f ." "f" }
"Here is the " { $link f } " class:"
{ $example "\\ f ." "POSTPONE: f" }
"They are not equal:"
{ $example "f \\ f = ." "f" }
"Here is an array containing the " { $link f } " object:"
{ $example "{ f } ." "{ f }" }
"Here is an array containing the " { $link f } " class:"
{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
"The " { $link f } " object is an instance of the " { $link f } " class:"
{ $example "f class ." "POSTPONE: f" }
"The " { $link f } " class is an instance of " { $link word } ":"
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
$nl
"The following two lines are equivalent:"
{ $code "[ drop f ] unless" "swap and" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection if }
{ $subsection when }
{ $subsection unless }
"Forms abstracting a common stack shuffle pattern:"
{ $subsection if* }
{ $subsection when* }
{ $subsection unless* }
"Another form abstracting a common stack shuffle pattern:"
{ $subsection ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
{ $subsection ? }
"There are some logical operations on booleans:"
{ $subsection >boolean }
{ $subsection not }
{ $subsection and }
{ $subsection or }
{ $subsection xor }
{ $subsection "conditionals-boolean-equivalence" }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality"
"There are two distinct notions of ``sameness'' when it comes to objects."
$nl
"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
{ $subsection eq? }
"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
{ $subsection = }
"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
$nl
"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
{ $subsection equal? }
"Utility class:"
{ $subsection identity-tuple }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
{ $subsection "effects" }
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"
HELP: eq? ( obj1 obj2 -- ? )
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if two references point at the same object." } ;
@ -916,6 +633,20 @@ $nl
}
"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
HELP: loop
{ $values
{ "pred" quotation } }
{ $description "Calls the quotation repeatedly until the output is true." }
{ $examples "Loop until we hit a zero:"
{ $unchecked-example "USING: kernel random math io ; "
" [ \"hi\" write bl 10 random zero? not ] loop"
"hi hi hi" }
"A fun loop:"
{ $example "USING: kernel prettyprint math ; "
"3 [ dup . 7 + 11 mod dup 3 = not ] loop"
"3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" }
} ;
HELP: assert
{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
{ $description "Throws an " { $link assert } " error." }
@ -924,3 +655,288 @@ HELP: assert
HELP: assert=
{ $values { "a" object } { "b" object } }
{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
ARTICLE: "shuffle-words" "Shuffle words"
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
$nl
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
$nl
"Removing stack elements:"
{ $subsection drop }
{ $subsection 2drop }
{ $subsection 3drop }
{ $subsection nip }
{ $subsection 2nip }
"Duplicating stack elements:"
{ $subsection dup }
{ $subsection 2dup }
{ $subsection 3dup }
{ $subsection dupd }
{ $subsection over }
{ $subsection 2over }
{ $subsection pick }
{ $subsection tuck }
"Permuting stack elements:"
{ $subsection swap }
{ $subsection swapd }
{ $subsection rot }
{ $subsection -rot }
{ $subsection spin }
{ $subsection roll }
{ $subsection -roll }
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
{ $subsection >r }
{ $subsection r> }
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
{ $example "1 2 3 >r .s r>" "1\n2" }
"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
$nl
"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
$nl
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
{ $code
": keep [ ] bi ;"
": 2keep [ ] 2bi ;"
": 3keep [ ] 3bi ;"
""
": dup [ ] [ ] bi ;"
": 2dup [ ] [ ] 2bi ;"
": 3dup [ ] [ ] 3bi ;"
""
": tuck [ nip ] [ ] 2bi ;"
": swap [ nip ] [ drop ] 2bi ;"
""
": over [ ] [ drop ] 2bi ;"
": pick [ ] [ 2drop ] 3bi ;"
": 2over [ ] [ drop ] 3bi ;"
} ;
ARTICLE: "cleave-combinators" "Cleave combinators"
"The cleave combinators apply multiple quotations to a single value."
$nl
"Two quotations:"
{ $subsection bi }
{ $subsection 2bi }
{ $subsection 3bi }
"Three quotations:"
{ $subsection tri }
{ $subsection 2tri }
{ $subsection 3tri }
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
"[ 1 + ] keep"
"[ 1 - ] keep"
"2 *"
"! Second alternative: uses tri"
"[ 1 + ]"
"[ 1 - ]"
"[ 2 * ] tri"
}
"The latter is more aesthetically pleasing than the former."
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
$nl
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
{ $code
": dip [ ] bi* ;"
": 2dip [ ] [ ] tri* ;"
""
": slip [ call ] [ ] bi* ;"
": 2slip [ call ] [ ] [ ] tri* ;"
""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
": rot"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
""
": -rot"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" 3tri ;"
""
": spin"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
} ;
ARTICLE: "spread-combinators" "Spread combinators"
"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
$nl
"Two quotations:"
{ $subsection bi* }
{ $subsection 2bi* }
"Three quotations:"
{ $subsection tri* }
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
{ $code
"! First alternative; uses retain stack explicitly"
">r >r 1 +"
"r> 1 -"
"r> 2 *"
"! Second alternative: uses tri*"
"[ 1 + ]"
"[ 1 - ]"
"[ 2 * ] tri*"
}
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
{ $subsection bi@ }
{ $subsection 2bi@ }
"Three quotations:"
{ $subsection tri@ }
"A pair of utility words built from " { $link bi@ } ":"
{ $subsection both? }
{ $subsection either? } ;
ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
{ $subsection slip }
{ $subsection 2slip }
{ $subsection 3slip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
{ $subsection 3keep } ;
ARTICLE: "compositional-combinators" "Compositional combinators"
"Quotations can be composed using efficient quotation-specific operations:"
{ $subsection curry }
{ $subsection 2curry }
{ $subsection 3curry }
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
{ $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
ARTICLE: "implementing-combinators" "Implementing combinators"
"The following pair of words invoke words and quotations reflectively:"
{ $subsection call }
{ $subsection execute }
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
"Word inlining is documented in " { $link "declarations" } "." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
{ $subsection f }
{ $subsection t }
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
$nl
"Here is the " { $link f } " object:"
{ $example "f ." "f" }
"Here is the " { $link f } " class:"
{ $example "\\ f ." "POSTPONE: f" }
"They are not equal:"
{ $example "f \\ f = ." "f" }
"Here is an array containing the " { $link f } " object:"
{ $example "{ f } ." "{ f }" }
"Here is an array containing the " { $link f } " class:"
{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
"The " { $link f } " object is an instance of the " { $link f } " class:"
{ $example "f class ." "POSTPONE: f" }
"The " { $link f } " class is an instance of " { $link word } ":"
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
$nl
"The following two lines are equivalent:"
{ $code "[ drop f ] unless" "swap and" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection if }
{ $subsection when }
{ $subsection unless }
"Forms abstracting a common stack shuffle pattern:"
{ $subsection if* }
{ $subsection when* }
{ $subsection unless* }
"Another form abstracting a common stack shuffle pattern:"
{ $subsection ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
{ $subsection ? }
"There are some logical operations on booleans:"
{ $subsection >boolean }
{ $subsection not }
{ $subsection and }
{ $subsection or }
{ $subsection xor }
{ $subsection "conditionals-boolean-equivalence" }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality"
"There are two distinct notions of ``sameness'' when it comes to objects."
$nl
"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
{ $subsection eq? }
"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
{ $subsection = }
"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
$nl
"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
{ $subsection equal? }
"Utility class:"
{ $subsection identity-tuple }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
{ $subsection "effects" }
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"

120
core/math/math-docs.factor
View File

@ -2,64 +2,6 @@ USING: help.markup help.syntax kernel sequences quotations
math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
$nl
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
$nl
"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
ARTICLE: "number-protocol" "Number protocol"
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
$nl
"Two examples where you should note the types of the inputs and outputs:"
{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
{ $example "1/2 2.0 + ." "4.5" }
"The following usual operations are supported by all numbers."
{ $subsection + }
{ $subsection - }
{ $subsection * }
{ $subsection / }
"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
{ $subsection "division-by-zero" }
"Real numbers (but not complex numbers) can be ordered:"
{ $subsection < }
{ $subsection <= }
{ $subsection > }
{ $subsection >= }
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
{ $subsection number= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
{ $subsection bitand }
{ $subsection bitor }
{ $subsection bitxor }
{ $subsection bitnot }
{ $subsection shift }
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
{ $see-also "conditionals" } ;
ARTICLE: "arithmetic" "Arithmetic"
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
$nl
"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
{ $subsection "number-protocol" }
{ $subsection "modular-arithmetic" }
{ $subsection "bitwise-arithmetic" }
{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
ABOUT: "arithmetic"
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numeric value." }
@ -235,6 +177,9 @@ HELP: 1-
{ $code "1-" "1 -" }
} ;
HELP: ?1+
{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
HELP: sq
{ $values { "x" number } { "y" number } }
{ $description "Multiplies a number by itself." } ;
@ -357,3 +302,62 @@ HELP: find-last-integer
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
ARTICLE: "division-by-zero" "Division by zero"
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
$nl
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
$nl
"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
ARTICLE: "number-protocol" "Number protocol"
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
$nl
"Two examples where you should note the types of the inputs and outputs:"
{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
{ $example "1/2 2.0 + ." "4.5" }
"The following usual operations are supported by all numbers."
{ $subsection + }
{ $subsection - }
{ $subsection * }
{ $subsection / }
"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
{ $subsection "division-by-zero" }
"Real numbers (but not complex numbers) can be ordered:"
{ $subsection < }
{ $subsection <= }
{ $subsection > }
{ $subsection >= }
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
{ $subsection number= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
{ $subsection bitand }
{ $subsection bitor }
{ $subsection bitxor }
{ $subsection bitnot }
{ $subsection shift }
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
{ $see-also "conditionals" } ;
ARTICLE: "arithmetic" "Arithmetic"
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
$nl
"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
{ $subsection "number-protocol" }
{ $subsection "modular-arithmetic" }
{ $subsection "bitwise-arithmetic" }
{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
ABOUT: "arithmetic"

40
core/memory/memory-docs.factor
View File

@ -1,19 +1,7 @@
USING: help.markup help.syntax debugger sequences kernel ;
USING: help.markup help.syntax debugger sequences kernel
quotations math ;
IN: memory
ARTICLE: "images" "Images"
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
{ $subsection save-image-and-exit }
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
$nl
"New images can be created from scratch:"
{ $subsection "bootstrap.image" }
{ $see-also "tools.memory" "tools.deploy" } ;
ABOUT: "images"
HELP: begin-scan ( -- )
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
$nl
@ -67,3 +55,27 @@ HELP: save-image-and-exit ( path -- )
HELP: save
{ $description "Saves a snapshot of the heap to the current image file." } ;
HELP: count-instances
{ $values
{ "quot" quotation }
{ "n" integer } }
{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
{ $examples { $unchecked-example
"USING: memory words prettyprint ;"
"[ word? ] count-instances ."
"24210"
} } ;
ARTICLE: "images" "Images"
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
{ $subsection save-image-and-exit }
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
$nl
"New images can be created from scratch:"
{ $subsection "bootstrap.image" }
{ $see-also "tools.memory" "tools.deploy" } ;
ABOUT: "images"

574
core/sequences/sequences-docs.factor
View File

@ -3,271 +3,6 @@ sequences.private vectors strings kernel math.order layouts
quotations ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
$nl
"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
$nl
"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
$nl
"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
{ $subsection sequence }
{ $subsection sequence? }
"All sequences must know their length:"
{ $subsection length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection nth }
{ $subsection nth-unsafe }
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection set-nth }
{ $subsection set-nth-unsafe }
"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
{ $subsection immutable }
"The following two generic words are optional, as not all sequences are resizable:"
{ $subsection set-length }
{ $subsection lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "sequences-integers" "Integer sequences and counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
{ $subsection first }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
{ $see-also nth peek } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection repetition }
{ $subsection <repetition> }
"Reversing a sequence:"
{ $subsection reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection prepend }
{ $subsection 3append }
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
{ $subsection pad-left }
{ $subsection pad-right } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice }
{ $subsection slice? }
"Creating slices:"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection each }
{ $subsection each-index }
{ $subsection reduce }
{ $subsection interleave }
{ $subsection replicate }
{ $subsection replicate-as }
"Mapping:"
{ $subsection map }
{ $subsection map-as }
{ $subsection map-index }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection empty? }
"Testing indices:"
{ $subsection bounds-check? }
"Testing if a sequence contains an object:"
{ $subsection member? }
{ $subsection memq? }
"Testing if a sequence contains a subsequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
{ $subsection index-from }
{ $subsection last-index }
{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
{ $subsection find-from }
{ $subsection find-last }
{ $subsection find-last-from } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
{ $subsection trim-left }
{ $subsection trim-right }
"Potentially more efficient trim:"
{ $subsection trim-slice }
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
"In-place variant of " { $link reverse } ":"
{ $subsection reverse-here }
"In-place variant of " { $link append } ":"
{ $subsection push-all }
"In-place variant of " { $link remove } ":"
{ $subsection delete }
"In-place variant of " { $link map } ":"
{ $subsection change-each }
"Changing elements:"
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $emphasis "virtual sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
{ $subsection "sequences-add-remove" }
{ $subsection "sequences-appending" }
{ $subsection "sequences-slices" }
{ $subsection "sequences-reshape" }
{ $subsection "sequences-tests" }
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
ABOUT: "sequences"
HELP: sequence
{ $class-description "A mixin class whose instances are sequences. Custom implementations of the sequence protocol should be declared as instances of this mixin for all sequence functionality to work correctly:"
{ $code "INSTANCE: my-sequence sequence" }
@ -305,6 +40,18 @@ $nl
"Throws an error if the sequence cannot hold elements of the given type." }
{ $side-effects "seq" } ;
HELP: nths
{ $values
{ "indices" null } { "seq" sequence }
{ "seq'" sequence } }
{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 0 2 } { \"a\" \"b\" \"c\" } nths ."
"{ \"a\" \"c\" }"
}
} ;
HELP: immutable
{ $values { "seq" sequence } }
{ $description "Throws an " { $link immutable } " error." }
@ -514,6 +261,15 @@ HELP: reduce
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
} ;
HELP: reduce-index
{ $values
{ "seq" sequence } { "identity" object } { "quot" quotation } }
{ $description "Combines successive elements of the sequence and their indices using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 50 90 } 0 [ + + ] reduce-index ."
"153"
} } ;
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
@ -1309,3 +1065,291 @@ HELP: partition
"{ 2 4 }\n{ 1 3 5 }"
}
} ;
HELP: virtual-seq
{ $values
{ "seq" sequence }
{ "seq'" sequence } }
{ $description "Part of the virtual sequence protocol, this word is used to return an underlying array from which to look up a value at an index given by " { $link virtual@ } "." } ;
HELP: virtual@
{ $values
{ "n" integer } { "seq" sequence }
{ "n'" integer } { "seq'" sequence } }
{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
$nl
"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
$nl
"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
$nl
"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
{ $subsection sequence }
{ $subsection sequence? }
"All sequences must know their length:"
{ $subsection length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection nth }
{ $subsection nth-unsafe }
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection set-nth }
{ $subsection set-nth-unsafe }
"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
{ $subsection immutable }
"The following two generic words are optional, as not all sequences are resizable:"
{ $subsection set-length }
{ $subsection lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "sequences-virtual-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
{ $subsection length }
"The underlying sequence to look up a value in:"
{ $subsection virtual-seq }
"The index of the value in the underlying sequence:"
{ $subsection virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "sequences-virtual-protocol" } "." ;
ARTICLE: "sequences-integers" "Integer sequences and counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
{ $subsection first }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
{ $see-also nth peek } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection repetition }
{ $subsection <repetition> }
"Reversing a sequence:"
{ $subsection reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection prepend }
{ $subsection 3append }
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
{ $subsection pad-left }
{ $subsection pad-right } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice }
{ $subsection slice? }
"Creating slices:"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection each }
{ $subsection each-index }
{ $subsection reduce }
{ $subsection interleave }
{ $subsection replicate }
{ $subsection replicate-as }
"Mapping:"
{ $subsection map }
{ $subsection map-as }
{ $subsection map-index }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection empty? }
"Testing indices:"
{ $subsection bounds-check? }
"Testing if a sequence contains an object:"
{ $subsection member? }
{ $subsection memq? }
"Testing if a sequence contains a subsequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
{ $subsection index-from }
{ $subsection last-index }
{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
{ $subsection find-from }
{ $subsection find-last }
{ $subsection find-last-from } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
{ $subsection trim-left }
{ $subsection trim-right }
"Potentially more efficient trim:"
{ $subsection trim-slice }
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
"In-place variant of " { $link reverse } ":"
{ $subsection reverse-here }
"In-place variant of " { $link append } ":"
{ $subsection push-all }
"In-place variant of " { $link remove } ":"
{ $subsection delete }
"In-place variant of " { $link map } ":"
{ $subsection change-each }
"Changing elements:"
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
{ $subsection "sequences-add-remove" }
{ $subsection "sequences-appending" }
{ $subsection "sequences-slices" }
{ $subsection "sequences-reshape" }
{ $subsection "sequences-tests" }
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
ABOUT: "sequences"

8
core/sets/sets-docs.factor
View File

@ -1,4 +1,4 @@
USING: kernel help.markup help.syntax sequences ;
USING: kernel help.markup help.syntax sequences quotations ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
@ -111,3 +111,9 @@ HELP: subset?
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
HELP: gather
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;

2
extra/mason/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Eduardo Cavazos
Slava Pestov

5
extra/mason/build/build-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: mason.build tools.test sequences ;
IN: mason.build.tests
{ create-build-dir enter-build-dir clone-builds-factor record-id }
[ must-infer ] each

30
extra/mason/build/build.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
calendar namespaces mason.common mason.child
mason.release mason.report mason.email mason.cleanup ;
IN: mason.build
: create-build-dir ( -- )
now datestamp stamp set
build-dir make-directory ;
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
"git" "clone" builds/factor 3array try-process ;
: record-id ( -- )
"factor" [ git-id ] with-directory "git-id" to-file ;
: build ( -- )
create-build-dir
enter-build-dir
clone-builds-factor
record-id
build-child
release
email-report
cleanup ;
MAIN: build

34
extra/mason/child/child-tests.factor Normal file
View File

@ -0,0 +1,34 @@
IN: mason.child.tests
USING: mason.child mason.config tools.test namespaces ;
[ { "make" "clean" "winnt-x86-32" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
make-cmd
] with-scope
] unit-test
[ { "make" "clean" "macosx-x86-32" } ] [
[
"macosx" target-os set
"x86.32" target-cpu set
make-cmd
] with-scope
] unit-test
[ { "gmake" "clean" "netbsd-ppc" } ] [
[
"netbsd" target-os set
"ppc" target-cpu set
make-cmd
] with-scope
] unit-test
[ { "./factor" "-i=boot.macosx-ppc.image" "-no-user-init" } ] [
[
"macosx" target-os set
"ppc" target-cpu set
boot-cmd
] with-scope
] unit-test

80
extra/mason/child/child.factor Normal file
View File

@ -0,0 +1,80 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make debugger sequences io.files
io.launcher arrays accessors calendar continuations
combinators.short-circuit mason.common mason.report mason.platform ;
IN: mason.child
: make-cmd ( -- args )
[ gnu-make , "clean" , platform , ] { } make ;
: make-vm ( -- )
"factor" [
<process>
make-cmd >>command
"../compile-log" >>stdout
+stdout+ >>stderr
try-process
] with-directory ;
: builds-factor-image ( -- img )
builds/factor boot-image-name append-path ;
: copy-image ( -- )
builds-factor-image "." copy-file-into
builds-factor-image "factor" copy-file-into ;
: boot-cmd ( -- cmd )
"./factor"
"-i=" boot-image-name append
"-no-user-init"
3array ;
: boot ( -- )
"factor" [
<process>
boot-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
1 hours >>timeout
try-process
] with-directory ;
: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
: test ( -- )
"factor" [
<process>
test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
4 hours >>timeout
try-process
] with-directory ;
: return-with ( obj -- ) return-continuation get continue-with ;
: build-clean? ( -- ? )
{
[ load-everything-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
} 0&& ;
: build-child ( -- )
[
return-continuation set
copy-image
[ make-vm ] [ compile-failed-report status-error return-with ] recover
[ boot ] [ boot-failed-report status-error return-with ] recover
[ test ] [ test-failed-report status-error return-with ] recover
successful-report
build-clean? status-clean status-dirty ? return-with
] callcc1
status set ;

4
extra/mason/cleanup/cleanup-tests.factor Normal file
View File

@ -0,0 +1,4 @@
USING: tools.test mason.cleanup ;
IN: mason.cleanup.tests
\ cleanup must-infer

22
extra/mason/cleanup/cleanup.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays continuations io.files io.launcher
mason.common mason.platform mason.config ;
IN: mason.cleanup
: compress-image ( -- )
"bzip2" boot-image-name 2array try-process ;
: compress-test-log ( -- )
"test-log" exists? [
{ "bzip2" "test-log" } try-process
] when ;
: cleanup ( -- )
builder-debug get [
build-dir [
compress-image
compress-test-log
"factor" delete-tree
] with-directory
] unless ;

34
extra/mason/common/common-tests.factor Normal file
View File

@ -0,0 +1,34 @@
IN: mason.common.tests
USING: prettyprint mason.common mason.config
namespaces calendar tools.test io.files io.encodings.utf8 ;
[ "00:01:01" ] [ 61000 milli-seconds>time ] unit-test
[ "/home/bobby/builds/factor" ] [
[
"/home/bobby/builds" builds-dir set
builds/factor
] with-scope
] unit-test
[ "/home/bobby/builds/2008-09-11-12-23" ] [
[
"/home/bobby/builds" builds-dir set
T{ timestamp
{ year 2008 }
{ month 9 }
{ day 11 }
{ hour 12 }
{ minute 23 }
} datestamp stamp set
build-dir
] with-scope
] unit-test
[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
[ "empty-test" temp-file eval-file ] must-fail
[ ] [ "eval-file-test" temp-file utf8 [ { 1 2 3 } . ] with-file-writer ] unit-test
[ { 1 2 3 } ] [ "eval-file-test" temp-file eval-file ] unit-test

81
extra/mason/common/common.factor Normal file
View File

@ -0,0 +1,81 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.launcher io.encodings.utf8
prettyprint combinators.short-circuit parser combinators
calendar calendar.format arrays mason.config ;
IN: mason.common
: short-running-process ( command -- )
#! Give network operations at most 15 minutes to complete.
<process>
swap >>command
15 minutes >>timeout
try-process ;
: eval-file ( file -- obj )
dup utf8 file-lines parse-fresh
[ "Empty file: " swap append throw ] [ nip first ] if-empty ;
: cat ( file -- ) utf8 file-contents print ;
: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
: datestamp ( timestamp -- string )
[
{
[ year>> , ]
[ month>> , ]
[ day>> , ]
[ hour>> , ]
[ minute>> , ]
} cleave
] { } make [ pad-00 ] map "-" join ;
: milli-seconds>time ( n -- string )
millis>timestamp
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
[ pad-00 ] map ":" join ;
SYMBOL: stamp
: builds/factor ( -- path ) builds-dir get "factor" append-path ;
: build-dir ( -- path ) builds-dir get stamp get append-path ;
: prepare-build-machine ( -- )
builds-dir get make-directories
builds-dir get
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
with-directory ;
: git-id ( -- id )
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
" " split second ;
: ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ;
: load-everything-vocabs-file "load-everything-vocabs" ;
: load-everything-errors-file "load-everything-errors" ;
: test-all-vocabs-file "test-all-vocabs" ;
: test-all-errors-file "test-all-errors" ;
: help-lint-vocabs-file "help-lint-vocabs" ;
: help-lint-errors-file "help-lint-errors" ;
: boot-time-file "boot-time" ;
: load-time-file "load-time" ;
: test-time-file "test-time" ;
: help-lint-time-file "help-lint-time" ;
: benchmark-time-file "benchmark-time" ;
: benchmarks-file "benchmarks" ;
SYMBOL: status
SYMBOL: status-error ! didn't bootstrap, or crashed
SYMBOL: status-dirty ! bootstrapped but not all tests passed
SYMBOL: status-clean ! everything good

66
extra/mason/config/config.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system io.files namespaces kernel accessors ;
IN: mason.config
! (Optional) Location for build directories
SYMBOL: builds-dir
builds-dir get-global [
home "builds" append-path builds-dir set-global
] unless
! Who sends build reports.
SYMBOL: builder-from
! Who receives build reports.
SYMBOL: builder-recipients
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
target-cpu get-global [
cpu name>> target-cpu set-global
] unless
! (Optional) OS to build for.
SYMBOL: target-os
target-os get-global [
os name>> target-os set-global
] unless
! Keep test-log around?
SYMBOL: builder-debug
! Boolean. Do we release binaries and update the clean branch?
SYMBOL: upload-to-factorcode
! The below are only needed if upload-to-factorcode is true.
! Host with clean git repo.
SYMBOL: branch-host
! Username to log in.
SYMBOL: branch-username
! Directory with git repo.
SYMBOL: branch-directory
! Host to upload clean image to.
SYMBOL: image-host
! Username to log in.
SYMBOL: image-username
! Directory with clean images.
SYMBOL: image-directory
! Host to upload binary package to.
SYMBOL: upload-host
! Username to log in.
SYMBOL: upload-username
! Directory with binary packages.
SYMBOL: upload-directory

11
extra/mason/email/email-tests.factor Normal file
View File

@ -0,0 +1,11 @@
IN: mason.email.tests
USING: mason.email mason.common mason.config namespaces tools.test ;
[ "mason on linux-x86-64: error" ] [
[
"linux" target-os set
"x86.64" target-cpu set
status-error status set
subject prefix-subject
] with-scope
] unit-test

35
extra/mason/email/email.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors combinators make smtp
debugger prettyprint io io.streams.string io.encodings.utf8
io.files io.sockets
mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ;
: email-status ( body subject -- )
<email>
builder-from get >>from
builder-recipients get >>to
swap prefix-subject >>subject
swap >>body
send-email ;
: subject ( -- str )
status get {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
: email-report ( -- )
"report" utf8 file-contents subject email-status ;
: email-error ( error callstack -- )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
] with-string-writer "fatal error"
email-status ;

30
extra/mason/mason.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel debugger io io.files threads debugger continuations
namespaces accessors calendar mason.common mason.updates
mason.build mason.email ;
IN: mason
: build-loop-error ( error -- )
error-continuation get call>> email-error ;
: build-loop-fatal ( error -- )
"FATAL BUILDER ERROR:" print
error. flush ;
: build-loop ( -- )
?prepare-build-machine
[
[
builds/factor set-current-directory
new-code-available? [ build ] when
] [
build-loop-error
] recover
] [
build-loop-fatal
] recover
5 minutes sleep
build-loop ;
MAIN: build-loop

19
extra/mason/platform/platform.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel system accessors namespaces splitting sequences make
mason.config ;
IN: mason.platform
: platform ( -- string )
target-os get "-" target-cpu get "." split "-" join 3append ;
: gnu-make ( -- string )
target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
: boot-image-name ( -- string )
[
"boot." %
target-cpu get "ppc" = [ target-os get % "-" % ] when
target-cpu get %
".image" %
] "" make ;

47
extra/mason/release/archive/archive.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators sequences make namespaces io.files
io.launcher prettyprint arrays
mason.common mason.platform mason.config ;
IN: mason.release.archive
: base-name ( -- string )
[ "factor-" % platform % "-" % stamp get % ] "" make ;
: extension ( -- extension )
target-os get {
{ "winnt" [ ".zip" ] }
{ "macosx" [ ".dmg" ] }
[ drop ".tar.gz" ]
} case ;
: archive-name ( -- string ) base-name extension append ;
: make-windows-archive ( -- )
[ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
: make-macosx-archive ( -- )
{ "mkdir" "dmg-root" } try-process
{ "cp" "-R" "factor" "dmg-root" } try-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor" }
archive-name suffix try-process
"dmg-root" delete-tree ;
: make-unix-archive ( -- )
[ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
: make-archive ( -- )
target-os get {
{ "winnt" [ make-windows-archive ] }
{ "macosx" [ make-macosx-archive ] }
[ drop make-unix-archive ]
} case ;
: releases ( -- path )
builds-dir get "releases" append-path dup make-directories ;
: save-archive ( -- )
archive-name releases move-file-into ;

24
extra/mason/release/branch/branch-tests.factor Normal file
View File

@ -0,0 +1,24 @@
IN: mason.release.branch.tests
USING: mason.release.branch mason.config tools.test namespaces ;
[ { "git" "push" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [
[
"joe" branch-username set
"blah.com" branch-host set
"/my/git" branch-directory set
"linux" target-os set
"x86.32" target-cpu set
push-to-clean-branch-cmd
] with-scope
] unit-test
[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
[
"joe" image-username set
"blah.com" image-host set
"/stuff/clean" image-directory set
"netbsd" target-os set
"x86.64" target-cpu set
upload-clean-image-cmd
] with-scope
] unit-test

48
extra/mason/release/branch/branch.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences prettyprint io.files
io.launcher make
mason.common mason.platform mason.config ;
IN: mason.release.branch
: branch-name ( -- string ) "clean-" platform append ;
: refspec ( -- string ) "master:" branch-name append ;
: push-to-clean-branch-cmd ( -- args )
[
"git" , "push" ,
[
branch-username get % "@" %
branch-host get % ":" %
branch-directory get %
] "" make ,
refspec ,
] { } make ;
: push-to-clean-branch ( -- )
push-to-clean-branch-cmd short-running-process ;
: upload-clean-image-cmd ( -- args )
[
"scp" ,
boot-image-name ,
[
image-username get % "@" %
image-host get % ":" %
image-directory get % "/" %
platform %
] "" make ,
] { } make ;
: upload-clean-image ( -- )
upload-clean-image-cmd short-running-process ;
: (update-clean-branch) ( -- )
"factor" [
push-to-clean-branch
upload-clean-image
] with-directory ;
: update-clean-branch ( -- )
upload-to-factorcode get [ (update-clean-branch) ] when ;

16
extra/mason/release/release.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel debugger namespaces sequences splitting
combinators io io.files io.launcher prettyprint bootstrap.image
mason.common mason.release.branch mason.release.tidy
mason.release.archive mason.release.upload ;
IN: mason.release
: (release) ( -- )
update-clean-branch
tidy
make-archive
upload
save-archive ;
: release ( -- ) status get status-clean eq? [ (release) ] when ;

2
extra/mason/release/tidy/tidy-tests.factor Normal file
View File

@ -0,0 +1,2 @@
IN: mason.release.tidy.tests
USING: mason.release.tidy tools.test ;

33
extra/mason/release/tidy/tidy.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces continuations debugger sequences fry
io.files io.launcher mason.common mason.platform
mason.config ;
IN: mason.release.tidy
: common-files ( -- seq )
{
"boot.x86.32.image"
"boot.x86.64.image"
"boot.macosx-ppc.image"
"boot.linux-ppc.image"
"vm"
"temp"
"logs"
".git"
".gitignore"
"Makefile"
"unmaintained"
"unfinished"
"build-support"
} ;
: remove-common-files ( -- )
common-files [ delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
[ "Factor.app" delete-tree ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;

38
extra/mason/release/upload/upload-tests.factor Normal file
View File

@ -0,0 +1,38 @@
IN: mason.release.upload.tests
USING: mason.release.upload mason.common mason.config
mason.common namespaces calendar tools.test ;
[
{
"scp"
"factor-linux-ppc-2008-09-11-23-12.tar.gz"
"slava@www.apple.com:/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
}
{
"ssh"
"www.apple.com"
"-l" "slava"
"mv"
"/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
"/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz"
}
] [
[
"slava" upload-username set
"www.apple.com" upload-host set
"/uploads" upload-directory set
"linux" target-os set
"ppc" target-cpu set
T{ timestamp
{ year 2008 }
{ month 09 }
{ day 11 }
{ hour 23 }
{ minute 12 }
} datestamp stamp set
upload-command
rename-command
] with-scope
] unit-test
\ upload must-infer

47
extra/mason/release/upload/upload.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences arrays io io.files
io.launcher mason.common mason.platform
mason.release.archive mason.config ;
IN: mason.release.upload
: remote-location ( -- dest )
upload-directory get "/" platform 3append ;
: remote-archive-name ( -- dest )
remote-location "/" archive-name 3append ;
: temp-archive-name ( -- dest )
remote-archive-name ".incomplete" append ;
: upload-command ( -- args )
"scp"
archive-name
[
upload-username get % "@" %
upload-host get % ":" %
temp-archive-name %
] "" make
3array ;
: rename-command ( -- args )
[
"ssh" ,
upload-host get ,
"-l" ,
upload-username get ,
"mv" ,
temp-archive-name ,
remote-archive-name ,
] { } make ;
: upload-temp-file ( -- )
upload-command short-running-process ;
: rename-temp-file ( -- )
rename-command short-running-process ;
: upload ( -- )
upload-to-factorcode get
[ upload-temp-file rename-temp-file ]
when ;

2
extra/mason/report/report-tests.factor Normal file
View File

@ -0,0 +1,2 @@
IN: mason.report.tests
USING: mason.report tools.test ;

66
extra/mason/report/report.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces debugger fry io io.files io.sockets
io.encodings.utf8 prettyprint benchmark mason.common
mason.platform mason.config ;
IN: mason.report
: time. ( file -- )
[ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
: common-report ( -- )
"Build machine: " write host-name print
"CPU: " write target-cpu get print
"OS: " write target-os get print
"Build directory: " write build-dir print
"git id: " write "git-id" eval-file print nl ;
: with-report ( quot -- )
[ "report" utf8 ] dip '[ common-report @ ] with-file-writer ;
: compile-failed-report ( error -- )
[
"VM compile failed:" print nl
"compile-log" cat nl
error.
] with-report ;
: boot-failed-report ( error -- )
[
"Bootstrap failed:" print nl
"boot-log" 100 cat-n nl
error.
] with-report ;
: test-failed-report ( error -- )
[
"Tests failed:" print nl
"test-log" 100 cat-n nl
error.
] with-report ;
: successful-report ( -- )
[
boot-time-file time.
load-time-file time.
test-time-file time.
help-lint-time-file time.
benchmark-time-file time.
nl
"Did not pass load-everything:" print
load-everything-vocabs-file cat
load-everything-errors-file cat
"Did not pass test-all:" print
test-all-vocabs-file cat
test-all-errors-file cat
"Did not pass help-lint:" print
help-lint-vocabs-file cat
help-lint-errors-file cat
"Benchmarks:" print
benchmarks-file eval-file benchmarks.
] with-report ;

1
extra/mason/summary.txt Normal file
View File

@ -0,0 +1 @@
Continuous build system for Factor

38
extra/mason/test/test.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs io.files io.encodings.utf8
prettyprint help.lint benchmark tools.time bootstrap.stage2
tools.test tools.vocabs mason.common ;
IN: mason.test
: do-load ( -- )
try-everything
[ keys load-everything-vocabs-file to-file ]
[ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
bi ;
: do-tests ( -- )
run-all-tests
[ keys test-all-vocabs-file to-file ]
[ test-all-errors-file utf8 [ test-failures. ] with-file-writer ]
bi ;
: do-help-lint ( -- )
"" run-help-lint
[ keys help-lint-vocabs-file to-file ]
[ help-lint-errors-file utf8 [ typos. ] with-file-writer ]
bi ;
: do-benchmarks ( -- )
run-benchmarks benchmarks-file to-file ;
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
[ do-load ] benchmark load-time-file to-file
[ do-tests ] benchmark test-time-file to-file
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
] with-directory ;
MAIN: do-all

28
extra/mason/updates/updates.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.launcher bootstrap.image.download
mason.common mason.platform ;
IN: mason.updates
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull-cmd short-running-process
git-id
= not ;
: new-image-available? ( -- ? )
boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
: new-code-available? ( -- ? )
updates-available?
new-image-available?
or ;

221
unfinished/compiler/backend/backend.factor
View File

@ -1,10 +1,223 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system ;
USING: accessors assocs arrays generic kernel kernel.private
math memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets classes.algebra
compiler.cfg.registers compiler.cfg.instructions ;
IN: compiler.backend
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( size -- ? )
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
! Sequence of registers used for parameter passing in class
GENERIC: param-regs ( register-class -- regs )
GENERIC: param-reg ( n register-class -- reg )
M: object param-reg param-regs nth ;
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
! Call another word
HOOK: %call cpu ( word -- )
! Local jump for branches
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-f cpu ( label vreg -- )
! Test if vreg is 't' or not
HOOK: %jump-t cpu ( label vreg -- )
HOOK: %dispatch cpu ( -- )
HOOK: %dispatch-label cpu ( word -- )
! Return to caller
HOOK: %return cpu ( -- )
! Change datastack height
HOOK: %inc-d cpu ( n -- )
! Change callstack height
HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
HOOK: %replace cpu ( vreg loc -- )
! Copy values between vregs
HOOK: %copy cpu ( dst src -- )
HOOK: %copy-float cpu ( dst src -- )
! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass explode value structs?
HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
HOOK: fp-shadows-int? cpu ( -- ? )
HOOK: %prepare-unbox cpu ( -- )
HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct cpu ( c-type -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
HOOK: %box cpu ( n reg-class func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( c-type -- )
HOOK: %box-large-struct cpu ( n c-type -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( alien-node -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
HOOK: %unwind cpu ( n -- )
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
GENERIC: v>operand ( obj -- operand )
SYMBOL: registers
M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
M: object load-literal v>operand load-indirect ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip
[ [ nip ] prepose ] dip if ;
inline
: %unbox-struct ( n c-type -- )
[
%unbox-small-struct
] [
%unbox-large-struct
] if-small-struct ;
: %box-struct ( n c-type -- )
[
%box-small-struct
] [
%box-large-struct
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array cpu ( dst src -- )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu ( -- )
SYMBOL: operands
: init-intrinsic ( insn -- )
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
: (operand) ( name -- operand )
operands get at* [ "Bad operand name" throw ] unless ;
: operand ( name -- operand )
(operand) v>operand ;
: operand-class ( var -- class )
(operand) value-class ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline

313
unfinished/compiler/backend/x86/32/32.factor
View File

@ -1,11 +1,318 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers
compiler.backend ;
USING: alien.c-types arrays kernel kernel.private math
namespaces sequences stack-checker.known-words system layouts
combinators command-line io vocabs.loader accessors init
compiler compiler.units compiler.constants compiler.codegen
compiler.cfg.builder compiler.alien compiler.codegen.fixup
cpu.x86 compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs push-return-reg return-reg PUSH ;
: load/store-int-return ( n reg-class -- src dst )
return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
: load/store-float-return ( n reg-class -- op size )
[ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
: align-sub ( n -- )
dup 16 align swap - ESP swap SUB ;
: align-add ( n -- )
16 align ESP swap ADD ;
: with-aligned-stack ( n quot -- )
swap dup align-sub slip align-add ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
: box@ ( n reg-class -- stack@ )
#! Used for callbacks; we want to box the values given to
#! us by the C function caller. Computes stack location of
#! nth parameter; note that we must go back one more stack
#! frame, since %box sets one up to call the one-arg boxer
#! function. The size of this stack frame so far depends on
#! the reg-class of the boxer's arg.
reg-size neg + stack-frame* + 20 + ;
: (%box) ( n reg-class -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
EDX PUSH
EAX PUSH ;
M: x86.32 %box-long-long ( n func -- )
8 [
[ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
: struct-return@ ( size n -- n )
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
M: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
heap-size
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
8 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 [
heap-size PUSH
EDX PUSH
EAX PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
#! Alien must be in EAX.
heap-size
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
%prepare-unbox
EAX PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
EAX POP
! Restore C stack
ESP 12 ADD
! Unbox EAX
unbox-return ;
M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
#! b) If we just called a function returning a struct, we
#! have to fix ESP.
{
{
[ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
}
[ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) RET ;
os windows? [
cell "longlong" c-type (>>align)
cell "ulonglong" c-type (>>align)
4 "double" c-type (>>align)
] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ;
<<
\ (sse2?) [
{ EAX EBX ECX EDX } [ PUSH ] each
EAX 1 MOV
CPUID
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
JE
] { } define-if-intrinsic
\ (sse2?) { } { object } define-primitive
>>
: sse2? ( -- ? ) (sse2?) ;
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ optimized-recompile-hook ] recompile-hook [
[ sse2? ] compile-call
] with-variable
[
" - yes" print
"compiler.backend.x86.sse2" require
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
"You will need to bootstrap Factor again." print
flush
1 exit
] unless
] "compiler.backend.x86" add-init-hook
] [
" - no" print
] if
] unless

218
unfinished/compiler/backend/x86/64/64.factor
View File

@ -1,7 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers
compiler.backend ;
USING: accessors alien.c-types arrays kernel kernel.private math
namespaces make sequences system layouts alien alien.accessors
alien.structs slots splitting assocs combinators
cpu.x86 compiler.codegen compiler.constants
compiler.codegen.fixup compiler.cfg.registers compiler.backend
compiler.backend.x86 compiler.backend.x86.sse2 ;
IN: compiler.backend.x86.64
M: x86.64 machine-registers
@ -12,3 +16,211 @@ M: x86.64 machine-registers
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: int-regs return-reg drop RAX ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
drop
>r R11 swap stack@ MOV
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- )
int-regs swap %unbox ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in RDI.
RDI swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Move alien_offset() return value to RDI so that we don't
! clobber it.
RDI RAX MOV
[
flatten-small-struct [ %unbox-struct-field ] each-index
] with-return-regs ;
M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in RDI
heap-size
! Load destination address
RSI RSP roll [+] LEA
! Load structure size
RDX swap MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
: load-return-value ( reg-class -- )
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
swap load-return-value
] if*
f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
{ int-regs [ int-regs get pop MOV ] }
{ double-float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct.
[
[ flatten-small-struct [ %box-struct-field ] each-index ]
[ RDX swap heap-size MOV ] bi
RDI 0 box-struct-field@ MOV
RSI 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( size n -- n )
[ ] [ \ stack-frame get swap - ] ?if ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
heap-size
RSI over MOV
! Compute destination address
swap struct-return@ RDI RSP rot [+] LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
cell temp@ RDI MOV
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
RDI cell temp@ MOV
! Unbox former top of data stack to return registers
unbox-return ;
M: x86.64 %cleanup ( alien-node -- ) drop ;
M: x86.64 %unwind ( n -- ) drop 0 RET ;
USE: cpu.x86.intrinsics
! On 64-bit systems, the result of reading 4 bytes from memory
! is a fixnum.
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
\ set-alien-unsigned-4 small-reg-32 define-setter
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter

110
unfinished/compiler/backend/x86/sse2/sse2.factor Normal file
View File

@ -0,0 +1,110 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays generic kernel system
kernel.private math math.private memory namespaces sequences
words math.floats.private layouts quotations cpu.x86
compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
compiler.constants compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.sse2
M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
8 (object@) swap v>operand MOVSD
float %store-tagged
] %allot ;
M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
: define-float-op ( word op -- )
[ "x" operand "y" operand ] swap suffix T{ template
{ input { { float "x" } { float "y" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic ;
{
{ float+ ADDSD }
{ float- SUBSD }
{ float* MULSD }
{ float/f DIVSD }
} [
first2 define-float-op
] each
: define-float-jump ( word op -- )
[ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< JAE }
{ float<= JA }
{ float> JBE }
{ float>= JB }
{ float= JNE }
} [
first2 define-float-jump
] each
\ float>fixnum [
"out" operand "in" operand CVTTSD2SI
"out" operand tag-bits get SHL
] T{ template
{ input { { float "in" } } }
{ scratch { { f "out" } } }
{ output { "out" } }
} define-intrinsic
\ fixnum>float [
"in" operand %untag-fixnum
"out" operand "in" operand CVTSI2SD
] T{ template
{ input { { f "in" } } }
{ scratch { { float "out" } } }
{ output { "out" } }
{ clobber { "in" } }
{ gc t }
} define-intrinsic
: alien-float-get-template
T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { float "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} ;
: alien-float-set-template
T{ template
{ input {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ "value" operand swap %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ "value" operand swap %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;
\ alien-double
[ MOVSD ]
\ set-alien-double
[ swap MOVSD ]
define-alien-float-intrinsics
\ alien-float
[ dupd MOVSS dup CVTSS2SD ]
\ set-alien-float
[ swap dup dup CVTSD2SS MOVSS ]
define-alien-float-intrinsics

755
unfinished/compiler/backend/x86/x86.factor Normal file
View File

@ -0,0 +1,755 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays alien.accessors
compiler.backend kernel kernel.private math memory namespaces
make sequences words system layouts combinators math.order
math.private alien alien.c-types slots.private cpu.x86
cpu.x86.private compiler.backend compiler.codegen.fixup
compiler.constants compiler.intrinsics compiler.cfg.builder
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.templates ;
IN: compiler.backend.x86
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
M: word JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: word CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: word JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
HOOK: stack-save-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: rs-loc v>operand n>> rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
M: f load-literal
v>operand \ f tag-number MOV drop ;
M: fixnum load-literal
v>operand swap tag-fixnum MOV ;
M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this
dup cell + PUSH
temp-reg-1 PUSH
stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
HOOK: %alien-global cpu ( symbol dll register -- )
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f temp-reg-1 %alien-global
temp-reg-1 [] stack-reg MOV
temp-reg-1 [] cell SUB
temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch ( -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
temp-reg-1 fixnum>slot@
! Add jump table base
temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
temp-reg-1 temp-reg-2 ADD
temp-reg-1 HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86 %replace swap %peek ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86 value-structs? t ;
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
rs-reg swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
rs-reg \ f tag-number CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD
! Now recurse on the underlying alien
rs-reg rs-reg underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
ds-reg rs-reg ADD
! Add an offset to start of byte array's data
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
ds-reg POP ;
: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
ds-reg ;
: (object@) ( n -- operand ) allot-reg swap [+] ;
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
: inc-allot-ptr ( n -- )
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;
: %allot ( header size quot -- )
allot-reg PUSH
swap >r >r
load-allot-ptr
store-header
r> call
r> inc-allot-ptr
allot-reg POP ; inline
: fresh-object drop ;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand r>
allot-reg swap tag-number OR
allot-reg MOV ;
: %allot-bignum-signed-1 ( outreg inreg -- )
#! on entry, inreg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in outreg
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
{ "end" "nonzero" "positive" "store" }
[ define-label ] each
dup v>operand 0 CMP ! is it zero?
"nonzero" get JNE
0 >bignum pick v>operand load-indirect ! this is our result
"end" get JMP
"nonzero" resolve-label
bignum 4 cells [
! Write length
1 object@ 2 v>operand MOV
! Test sign
dup v>operand 0 CMP
"positive" get JGE
2 object@ 1 MOV ! negative sign
dup v>operand NEG
"store" get JMP
"positive" resolve-label
2 object@ 0 MOV ! positive sign
"store" resolve-label
3 object@ swap v>operand MOV
! Store tagged ptr in reg
bignum %store-tagged
] %allot
"end" resolve-label
] with-scope ;
M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
"f" get JE
alien 4 cells [
1 object@ \ f tag-number MOV
2 object@ \ f tag-number MOV
! Store src in alien-offset slot
3 object@ swap v>operand MOV
! Store tagged ptr in dst
dup object %store-tagged
] %allot
"end" get JMP
"f" resolve-label
f [ v>operand ] bi@ MOV
"end" resolve-label
] with-scope ;
! Type checks
\ tag [
"in" operand tag-mask get AND
"in" operand %tag-fixnum
] T{ template
{ input { { f "in" } } }
{ output { "in" } }
} define-intrinsic
! Slots
: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" operand-tag - [+] ;
: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
\ slot {
! Slot number is literal and the tag is known
{
[ "val" operand %slot-literal-known-tag MOV ] T{ template
{ input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ scratch { { f "val" } } }
{ output { "val" } }
}
}
! Slot number is literal
{
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
{ input { { f "obj" } { [ small-slot? ] "n" } } }
{ output { "obj" } }
}
}
! Slot number in a register
{
[ "obj" operand %slot-any MOV ] T{ template
{ input { { f "obj" } { f "n" } } }
{ output { "obj" } }
{ clobber { "n" } }
}
}
} define-intrinsics
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" operand-immediate? "obj" fresh-object? or [
! Mark the card
"obj" operand card-bits SHR
"cards_offset" f "scratch" operand %alien-global
"scratch" operand "obj" operand [+] card-mark <byte> MOV
! Mark the card deck
"obj" operand deck-bits card-bits - SHR
"decks_offset" f "scratch" operand %alien-global
"scratch" operand "obj" operand [+] card-mark <byte> MOV
] unless ;
\ set-slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" } }
}
}
! Slot number in a register
{
[ %slot-any "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" } { f "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" "n" } }
}
}
} define-intrinsics
! Sometimes, we need to do stuff with operands which are
! less than the word size. Instead of teaching the register
! allocator about the different sized registers, with all
! the complexity this entails, we just push/pop a register
! which is guaranteed to be unused (the tempreg)
: small-reg cell 8 = RBX EBX ? ; inline
: small-reg-8 BL ; inline
: small-reg-16 BX ; inline
: small-reg-32 EBX ; inline
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ output { "x" } }
} fixnum-op ;
: fixnum-register-op ( op -- pair )
T{ template
{ input { { f "x" } { f "y" } } }
{ output { "x" } }
} fixnum-op ;
: define-fixnum-op ( word op -- )
[ fixnum-value-op ] keep fixnum-register-op
2array define-intrinsics ;
{
{ fixnum+fast ADD }
{ fixnum-fast SUB }
{ fixnum-bitand AND }
{ fixnum-bitor OR }
{ fixnum-bitxor XOR }
} [
first2 define-fixnum-op
] each
\ fixnum-bitnot [
"x" operand NOT
"x" operand tag-mask get XOR
] T{ template
{ input { { f "x" } } }
{ output { "x" } }
} define-intrinsic
\ fixnum*fast {
{
[
"x" operand "y" get IMUL2
] T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ output { "x" } }
}
} {
[
"out" operand "x" operand MOV
"out" operand %untag-fixnum
"y" operand "out" operand IMUL2
] T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "out" } } }
{ output { "out" } }
}
}
} define-intrinsics
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast [
"x" operand "y" get
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits
"x" operand %untag
] T{ template
{ input { { f "x" } { [ ] "y" } } }
{ output { "x" } }
} define-intrinsic
: overflow-check ( word -- )
"end" define-label
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! turn the result into a bignum and leave it in EAX.
"end" get JNO
! There was an overflow. Recompute the original operand.
{ "y" "x" } %untag-fixnums
"x" operand "y" operand rot execute
"z" get "x" get %allot-bignum-signed-1
"end" resolve-label ; inline
: overflow-template ( word insn -- )
[ overflow-check ] curry T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "z" } } }
{ output { "z" } }
{ clobber { "x" "y" } }
{ gc t }
} define-intrinsic ;
\ fixnum+ \ ADD overflow-template
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
: fixnum-register-jump ( op -- pair )
{ { f "x" } { f "y" } } fixnum-jump ;
: define-fixnum-jump ( word op -- )
[ fixnum-value-jump ] keep fixnum-register-jump
2array define-if-intrinsics ;
{
{ fixnum< JL }
{ fixnum<= JLE }
{ fixnum> JG }
{ fixnum>= JGE }
{ eq? JE }
} [
first2 define-fixnum-jump
] each
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" get dup %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label
"end" define-label
"x" operand %untag
"y" operand "x" operand cell [+] MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
"y" operand 1 v>operand CMP
"nonzero" get JNE
"y" operand 0 MOV
"end" get JMP
"nonzero" resolve-label
! load the value
"y" operand "x" operand 3 cells [+] MOV
! load the sign
"x" operand "x" operand 2 cells [+] MOV
! is the sign negative?
"x" operand 0 CMP
"positive" get JE
"y" operand -1 IMUL2
"positive" resolve-label
"y" operand 3 SHL
"end" resolve-label
] T{ template
{ input { { f "x" } } }
{ scratch { { f "y" } } }
{ clobber { "x" } }
{ output { "y" } }
} define-intrinsic
! User environment
: %userenv ( -- )
"x" operand 0 MOV
"userenv" f rc-absolute-cell rel-dlsym
"n" operand fixnum>slot@
"n" operand "x" operand ADD ;
\ getenv [
%userenv "n" operand dup [] MOV
] T{ template
{ input { { f "n" } } }
{ scratch { { f "x" } } }
{ output { "n" } }
} define-intrinsic
\ setenv [
%userenv "n" operand [] "val" operand MOV
] T{ template
{ input { { f "val" } { f "n" } } }
{ scratch { { f "x" } } }
{ clobber { "n" } }
} define-intrinsic
\ (tuple) [
tuple "layout" get size>> 2 + cells [
! Store layout
"layout" get "scratch" operand load-indirect
1 object@ "scratch" operand MOV
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
] T{ template
{ input { { [ ] "layout" } } }
{ scratch { { f "tuple" } { f "scratch" } } }
{ output { "tuple" } }
{ gc t }
} define-intrinsic
\ (array) [
array "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] T{ template
{ input { { [ ] "n" } } }
{ scratch { { f "array" } } }
{ output { "array" } }
{ gc t }
} define-intrinsic
\ (byte-array) [
byte-array "n" get 2 cells + [
! Store length
1 object@ "n" operand MOV
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] T{ template
{ input { { [ ] "n" } } }
{ scratch { { f "array" } } }
{ output { "array" } }
{ gc t }
} define-intrinsic
\ <ratio> [
ratio 3 cells [
1 object@ "numerator" operand MOV
2 object@ "denominator" operand MOV
! Store tagged ptr in reg
"ratio" get ratio %store-tagged
] %allot
] T{ template
{ input { { f "numerator" } { f "denominator" } } }
{ scratch { { f "ratio" } } }
{ output { "ratio" } }
{ gc t }
} define-intrinsic
\ <complex> [
complex 3 cells [
1 object@ "real" operand MOV
2 object@ "imaginary" operand MOV
! Store tagged ptr in reg
"complex" get complex %store-tagged
] %allot
] T{ template
{ input { { f "real" } { f "imaginary" } } }
{ scratch { { f "complex" } } }
{ output { "complex" } }
{ gc t }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells [
1 object@ "obj" operand MOV
! Store tagged ptr in reg
"wrapper" get object %store-tagged
] %allot
] T{ template
{ input { { f "obj" } } }
{ scratch { { f "wrapper" } } }
{ output { "wrapper" } }
{ gc t }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand %untag-fixnum
"offset" operand "alien" operand ADD
"offset" operand [] swap call ; inline
: %alien-integer-get ( quot reg -- )
small-reg PUSH
swap %alien-accessor
"value" operand small-reg MOV
"value" operand %tag-fixnum
small-reg POP ; inline
: alien-integer-get-template
T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { f "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} ;
: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
small-reg PUSH
small-reg "value" operand MOV
small-reg %untag-fixnum
swap %alien-accessor
small-reg POP ; inline
: alien-integer-set-template
T{ template
{ input {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "value" "offset" } }
} ;
: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template
define-intrinsic ;
\ alien-unsigned-1 small-reg-8 define-unsigned-getter
\ set-alien-unsigned-1 small-reg-8 define-setter
\ alien-signed-1 small-reg-8 define-signed-getter
\ set-alien-signed-1 small-reg-8 define-setter
\ alien-unsigned-2 small-reg-16 define-unsigned-getter
\ set-alien-unsigned-2 small-reg-16 define-setter
\ alien-signed-2 small-reg-16 define-signed-getter
\ set-alien-signed-2 small-reg-16 define-setter
\ alien-cell [
"value" operand [ MOV ] %alien-accessor
] T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { unboxed-alien "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} define-intrinsic
\ set-alien-cell [
"value" operand [ swap MOV ] %alien-accessor
] T{ template
{ input {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "offset" } }
} define-intrinsic

109
unfinished/compiler/cfg/builder/builder.factor
View File

@ -32,18 +32,9 @@ IN: compiler.cfg.builder
: stop-iterating ( -- next ) end-basic-block f ;
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
! Basic block after prologue, makes recursion faster
@ -81,8 +72,8 @@ GENERIC: emit-node ( node -- next )
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
init-phantoms
%prologue
%branch
##prologue
##branch
begin-basic-block
current-label get remember-loop ;
@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
[ emit-nodes ] with-node-iterator
] with-cfg-builder ;
: build-cfg ( nodes word label -- procedures )
: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
(build-cfg)
dup (build-cfg)
] with-variable
] keep ;
SYMBOL: +intrinsics+
SYMBOL: +if-intrinsics+
: if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ;
word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next )
%branch
##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
finalize-phantoms
{
{ [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
{ [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ %epilogue %jump stop-iterating ]
[ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
@ -130,50 +124,52 @@ M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: emit-branch ( nodes -- final-bb )
[
: emit-branch ( obj quot -- final-bb )
'[
begin-basic-block copy-phantoms
emit-nodes
basic-block get dup [ %branch ] when
@
basic-block get dup [ ##branch ] when
] with-scope ;
: emit-if ( node -- next )
children>> [ emit-branch ] map
: emit-branches ( seq quot -- )
'[ _ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each
init-phantoms
iterate-next ;
init-phantoms ;
: emit-if ( node -- next )
children>> [ emit-nodes ] emit-branches ;
M: #if emit-node
{ { f "flag" } } lazy-load first %branch-t
emit-if ;
{ { f "flag" } } lazy-load first ##branch-t
emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
#! The order here is important, dispatch-branches must
#! run after ##dispatch, so that each branch gets the
#! correct register state
gensym [
[
copy-phantoms
%prologue
##prologue
[ emit-nodes ] with-node-iterator
%epilogue
%return
##epilogue
##return
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
%dispatch-label
##dispatch-label
] each ;
: emit-dispatch ( node -- )
%dispatch dispatch-branches init-phantoms ;
##epilogue ##dispatch dispatch-branches init-phantoms ;
M: #dispatch emit-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
emit-dispatch iterate-next
] [
@ -187,23 +183,23 @@ M: #dispatch emit-node
! #call
: define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ;
+intrinsics+ set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map
"if-intrinsics" set-word-prop ;
[ template new swap >>input ] assoc-map
+if-intrinsics+ set-word-prop ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f )
word>> "intrinsics" word-prop find-template ;
word>> +intrinsics+ word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f )
word>> "if-intrinsics" word-prop find-template ;
word>> +if-intrinsics+ word-prop find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
@ -213,21 +209,24 @@ M: #dispatch emit-node
} cond ;
: do-if-intrinsic ( pair -- next )
[ %if-intrinsic ] apply-template skip-next emit-if ;
[ ##if-intrinsic ] apply-template skip-next emit-if
iterate-next ;
: do-boolean-intrinsic ( pair -- next )
[
f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
] apply-template iterate-next ;
[ ##if-intrinsic ] apply-template
{ t f } [
<constant> phantom-push finalize-phantoms
] emit-branches
iterate-next ;
: do-intrinsic ( pair -- next )
[ %intrinsic ] apply-template iterate-next ;
[ ##intrinsic ] apply-template iterate-next ;
: setup-operand-classes ( #call -- )
node-input-infos [ class>> ] map set-operand-classes ;
: setup-value-classes ( #call -- )
node-input-infos [ class>> ] map set-value-classes ;
M: #call emit-node
dup setup-operand-classes
dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
@ -259,12 +258,12 @@ M: #r> emit-node
! #return
M: #return emit-node
drop finalize-phantoms %epilogue %return f ;
drop finalize-phantoms ##epilogue ##return f ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
[ %epilogue %return ] unless f ;
[ ##epilogue ##return ] unless f ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
! FFI
M: #alien-invoke emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-invoke iterate-next ]
[ alien-invoke-frame ##frame-required ]
[ ##alien-invoke iterate-next ]
bi ;
M: #alien-indirect emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-indirect iterate-next ]
[ alien-invoke-frame ##frame-required ]
[ ##alien-indirect iterate-next ]
bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
[ init-phantoms %alien-callback ] with-cfg-builder
[ init-phantoms ##alien-callback ] with-cfg-builder
iterate-next ;
! No-op nodes

7
unfinished/compiler/cfg/cfg.factor
View File

@ -11,16 +11,13 @@ C: <cfg> cfg
TUPLE: basic-block < identity-tuple
visited
number
label
instructions
successors
predecessors ;
successors ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors ;
V{ } clone >>successors ;
TUPLE: mr instructions word label ;

5
unfinished/compiler/cfg/debugger/debugger.factor
View File

@ -9,11 +9,10 @@ IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
build-tree optimize-tree gensym gensym build-cfg ;
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep dup
build-cfg ;
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;

115
unfinished/compiler/cfg/instructions/instructions.factor
View File

@ -6,103 +6,102 @@ IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: %cond-branch < insn src ;
TUPLE: %unary < insn dst src ;
TUPLE: %nullary < insn dst ;
TUPLE: ##cond-branch < insn src ;
TUPLE: ##unary < insn dst src ;
TUPLE: ##nullary < insn dst ;
! Stack operations
INSN: %load-literal < %nullary obj ;
INSN: %peek < %nullary loc ;
INSN: %replace src loc ;
INSN: %inc-d n ;
INSN: %inc-r n ;
INSN: ##load-literal < ##nullary obj ;
INSN: ##peek < ##nullary loc ;
INSN: ##replace src loc ;
INSN: ##inc-d n ;
INSN: ##inc-r n ;
! Calling convention
INSN: %return ;
INSN: ##return ;
! Subroutine calls
INSN: %call word ;
INSN: %jump word ;
INSN: %intrinsic quot regs ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
INSN: %dispatch-label label ;
INSN: %dispatch ;
INSN: ##dispatch-label label ;
INSN: ##dispatch ;
! Boxing and unboxing
INSN: %copy < %unary ;
INSN: %copy-float < %unary ;
INSN: %unbox-float < %unary ;
INSN: %unbox-f < %unary ;
INSN: %unbox-alien < %unary ;
INSN: %unbox-byte-array < %unary ;
INSN: %unbox-any-c-ptr < %unary ;
INSN: %box-float < %unary ;
INSN: %box-alien < %unary ;
INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ;
INSN: ##box-float < ##unary ;
INSN: ##box-alien < ##unary ;
INSN: %gc ;
INSN: ##gc ;
! FFI
INSN: %alien-invoke params ;
INSN: %alien-indirect params ;
INSN: %alien-callback params ;
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
INSN: ##alien-callback params ;
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: %nullary defs-vregs dst>> >vreg 1array ;
M: %unary defs-vregs dst>> >vreg 1array ;
M: ##nullary defs-vregs dst>> >vreg 1array ;
M: ##unary defs-vregs dst>> >vreg 1array ;
M: insn defs-vregs drop f ;
M: %replace uses-vregs src>> >vreg 1array ;
M: %unary uses-vregs src>> >vreg 1array ;
M: ##replace uses-vregs src>> >vreg 1array ;
M: ##unary uses-vregs src>> >vreg 1array ;
M: insn uses-vregs drop f ;
! M: %intrinsic uses-vregs vregs>> values ;
: intrinsic-vregs ( assoc -- seq' )
[ nip >vreg ] { } assoc>map sift ;
: intrinsic-defs-vregs ( insn -- seq )
defs-vregs>> intrinsic-vregs ;
: intrinsic-uses-vregs ( insn -- seq )
uses-vregs>> intrinsic-vregs ;
M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by CFG IR only.
INSN: %prologue ;
INSN: %epilogue ;
INSN: %frame-required n ;
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##frame-required n ;
INSN: %branch ;
INSN: %branch-f < %cond-branch ;
INSN: %branch-t < %cond-branch ;
INSN: %if-intrinsic quot vregs ;
INSN: %boolean-intrinsic quot vregs dst ;
INSN: ##branch ;
INSN: ##branch-f < ##cond-branch ;
INSN: ##branch-t < ##cond-branch ;
INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
M: %cond-branch uses-vregs src>> 1array ;
M: ##cond-branch uses-vregs src>> >vreg 1array ;
! M: %if-intrinsic uses-vregs vregs>> values ;
M: %boolean-intrinsic defs-vregs dst>> 1array ;
! M: %boolean-intrinsic uses-vregs
! [ vregs>> values ] [ out>> ] bi suffix ;
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
INSN: _prologue n ;
INSN: _epilogue n ;
TUPLE: label id ;
INSN: _label label ;
: <label> ( -- label ) \ <label> counter label boa ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- )
dup label? [ get ] unless _label ;
INSN: _label id ;
TUPLE: _cond-branch < insn src label ;
INSN: _branch label ;
INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ;
INSN: _if-intrinsic label quot vregs ;
INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
M: _cond-branch uses-vregs src>> >vreg 1array ;
! M: _if-intrinsic uses-vregs vregs>> values ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
INSN: _spill src n ;
INSN: _reload dst n ;

5
unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -3,6 +3,7 @@ USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
compiler.cfg.registers
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.debugger ;
@ -98,3 +99,7 @@ SYMBOL: max-uses
[ ] [ 10 4 2 60 random-test ] unit-test
[ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 random-test ] unit-test
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test

13
unfinished/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -8,9 +8,20 @@ compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
! References:
! Linear Scan Register Allocation
! by Massimiliano Poletto and Vivek Sarkar
! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
! Linear Scan Register Allocation for the Java HotSpot Client Compiler
! by Christian Wimmer
! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
! Quality and Speed in Linear-scan Register Allocation
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: linear-scan ( mr -- mr' )
[
dup compute-live-intervals

1
unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -28,7 +28,6 @@ SYMBOL: live-intervals
at [ (>>end) ] [ uses>> push ] 2bi ;
: new-live-interval ( n vreg live-intervals -- )
2dup key? [ "Multiple defs" throw ] when
[ [ <live-interval> ] keep ] dip set-at ;
: compute-live-intervals* ( insn n -- )

42
unfinished/compiler/cfg/linearization/linearization.factor
View File

@ -12,7 +12,7 @@ IN: compiler.cfg.linearization
SYMBOL: frame-size
: compute-frame-size ( rpo -- )
[ instructions>> [ %frame-required? ] filter ] map concat
[ instructions>> [ ##frame-required? ] filter ] map concat
[ f ] [ [ n>> ] map supremum ] if-empty
frame-size set ;
@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
M: insn linearize-insn , drop ;
M: %frame-required linearize-insn 2drop ;
M: ##frame-required linearize-insn 2drop ;
M: %prologue linearize-insn
M: ##prologue linearize-insn
2drop frame-size get [ _prologue ] when* ;
M: %epilogue linearize-insn
M: ##epilogue linearize-insn
2drop frame-size get [ _epilogue ] when* ;
: useless-branch? ( basic-block successor -- ? )
@ -39,50 +39,40 @@ M: %epilogue linearize-insn
: branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned.
instructions>> dup length 2 = [
[ first %epilogue? ] [ second %return? ] bi and
[ first ##epilogue? ] [ second ##return? ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-return? ] [ nip linearize-insns ] }
[ nip label>> _branch ]
[ nip number>> _branch ]
} cond ;
M: %branch linearize-insn
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 )
dup successors>> first2 swap label>> ; inline
dup successors>> first2 swap number>> ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
[ conditional ] [ src>> ] bi* swap ; inline
M: %branch-f linearize-insn
M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ;
M: %branch-t linearize-insn
M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ;
M: %if-intrinsic linearize-insn
[ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
: >intrinsic< ( insn -- quot defs uses )
[ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
M: ##if-intrinsic linearize-insn
[ conditional ] [ >intrinsic< ] bi*
_if-intrinsic emit-branch ;
M: %boolean-intrinsic linearize-insn
[
"false" define-label
"end" define-label
"false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
dup dst>> t %load-literal
"end" get _branch
"false" resolve-label
dup dst>> f %load-literal
"end" resolve-label
] with-scope
2drop ;
: linearize-basic-block ( bb -- )
[ label>> _label ] [ linearize-insns ] bi ;
[ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;

22
unfinished/compiler/cfg/registers/registers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces math kernel ;
USING: accessors namespaces math kernel alien classes ;
IN: compiler.cfg.registers
! Virtual CPU registers, used by CFG and machine IRs
@ -8,8 +8,14 @@ IN: compiler.cfg.registers
MIXIN: value
GENERIC: >vreg ( obj -- vreg )
GENERIC: set-value-class ( class obj -- )
GENERIC: value-class* ( operand -- class )
: value-class ( operand -- class ) value-class* object or ;
M: value >vreg drop f ;
M: value set-value-class 2drop ;
M: value value-class* drop f ;
! Register classes
SINGLETON: int-regs
@ -47,6 +53,8 @@ INSTANCE: loc value
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached set-value-class vreg>> set-value-class ;
M: cached value-class* vreg>> value-class* ;
M: cached >vreg vreg>> >vreg ;
INSTANCE: cached value
@ -55,6 +63,8 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) f tagged boa ;
M: tagged set-value-class (>>class) ;
M: tagged value-class* class>> ;
M: tagged >vreg vreg>> ;
INSTANCE: tagged value
@ -71,20 +81,30 @@ INSTANCE: unboxed value
TUPLE: unboxed-alien < unboxed ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien value-class* drop simple-alien ;
! Untagged byte array pointer
TUPLE: unboxed-byte-array < unboxed ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array value-class* drop c-ptr ;
! A register set to f
TUPLE: unboxed-f < unboxed ;
C: <unboxed-f> unboxed-f
M: unboxed-f value-class* drop \ f ;
! An alien, byte array or f
TUPLE: unboxed-c-ptr < unboxed ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr value-class* drop c-ptr ;
! A constant value
TUPLE: constant value ;
C: <constant> constant
M: constant value-class* value>> class ;
INSTANCE: constant value

1
unfinished/compiler/cfg/rpo/rpo.factor
View File

@ -7,7 +7,6 @@ IN: compiler.cfg.rpo
: post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [
t >>visited
<label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;

91
unfinished/compiler/cfg/stacks/stacks.factor
View File

@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
@ -32,23 +30,19 @@ DEFER: %move
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
M: vreg value-class* reg-class>> value-class* ;
M: int-regs move-spec drop f ;
M: int-regs operand-class* drop object ;
M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
M: float-regs value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
@ -57,15 +51,13 @@ M: ds-loc live-loc?
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc value-class* class>> ;
M: loc set-value-class (>>class) ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
M: f operand-class* ;
M: f value-class* ;
M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
@ -75,41 +67,34 @@ M: cached lazy-store
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: constant operand-class* value>> class ;
M: constant move-spec class ;
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
dup value-class {
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
[ drop ##unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
int-regs next-vreg [ over %move operand-class ] keep
int-regs next-vreg [ over %move value-class ] keep
tagged new
swap >>vreg
swap >>class
@ -117,28 +102,28 @@ M: constant move-spec class ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ %copy ] }
{ { unboxed-alien unboxed-alien } [ %copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ %copy ] }
{ { unboxed-f unboxed-f } [ %copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
{ { float float } [ %copy-float ] }
{ { f f } [ ##copy ] }
{ { unboxed-alien unboxed-alien } [ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
{ { unboxed-f unboxed-f } [ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
{ { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> %load-literal ] }
{ { f constant } [ value>> ##load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { f float } [ ##box-float ] }
{ { f unboxed-alien } [ ##box-alien ] }
{ { f loc } [ ##peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { float f } [ ##unbox-float ] }
{ { unboxed-alien f } [ ##unbox-alien ] }
{ { unboxed-byte-array f } [ ##unbox-byte-array ] }
{ { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
{ { loc f } [ swap ##replace ] }
[ drop %move-via-temp ]
} case ;
@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
\ ##inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ;
\ ##inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
@ -265,7 +250,7 @@ SYMBOL: fresh-objects
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class
alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
@ -301,7 +286,7 @@ M: loc lazy-store
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
value-class over set-value-class
] if
] 2map
over stack>> delete-all
@ -330,10 +315,10 @@ M: loc lazy-store
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
: set-operand-classes ( classes -- )
: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ;
stack>> [ set-value-class ] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@ -342,7 +327,7 @@ M: loc lazy-store
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
: fresh-object ( obj -- ) fresh-objects get push ;
@ -358,14 +343,6 @@ M: loc lazy-store
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;

31
unfinished/compiler/cfg/templates/templates.factor
View File

@ -5,16 +5,7 @@ quotations combinators classes.algebra compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
: template-input +input+ swap at ; inline
: template-output +output+ swap at ; inline
: template-scratch +scratch+ swap at ; inline
: template-clobber +clobber+ swap at ; inline
TUPLE: template input output scratch clobber gc ;
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
[ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq )
[ template-output ] [ template-clobber ] bi append ;
[ output>> ] [ clobber>> ] bi append ;
: clobbered? ( value name -- ? )
\ clobbered get member? [
@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
[
live-vregs \ live-vregs set
dup clobbered \ clobbered set
template-input [ values ] [ lazy-load ] bi zip
input>> [ values ] [ lazy-load ] bi zip
] with-scope ;
: alloc-scratch ( template -- assoc )
template-scratch [ swap alloc-vreg ] assoc-map ;
scratch>> [ swap alloc-vreg ] assoc-map ;
: do-template-inputs ( template -- inputs )
: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
#! registers.
[ load-inputs ] [ alloc-scratch ] bi assoc-union ;
[ alloc-scratch ] [ load-inputs ] bi ;
: do-template-outputs ( template inputs -- )
[ template-output ] dip '[ _ at ] map
: do-template-outputs ( template defs uses -- )
[ output>> ] 2dip assoc-union '[ _ at ] map
phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs )
[
first2 dup do-template-inputs
[ do-template-outputs ] keep
[ do-template-outputs ] 2keep
] dip call ; inline
: value-matches? ( value spec -- ? )
@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
>r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
template-input phantom-datastack get swap
input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f )

222
unfinished/compiler/backend/alien/alien.factor → unfinished/compiler/codegen/codegen.factor
View File

@ -1,16 +1,128 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.backend.alien
USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
threads continuations.private libc combinators
alien alien.c-types alien.structs alien.strings
compiler.errors
compiler.alien
compiler.backend
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ;
SYMBOL: calls
: add-call ( word -- )
#! Compile this word later.
calls get push ;
SYMBOL: compiling-word
: compiled-stack-traces? ( -- ? ) 59 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
: init-generator ( word -- )
H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? compiling-word get f ? add-literal drop ;
: generate ( mr -- asm )
[
[ label>> ]
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
asm boa
] with-scope ;
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
M: _label generate-insn
id>> lookup-label , ;
M: _prologue generate-insn
n>> %prologue ;
M: _epilogue generate-insn
n>> %epilogue ;
M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
M: ##return generate-insn drop %return ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
M: ##intrinsic generate-insn
[ init-intrinsic ] [ quot>> call ] bi ;
M: _if-intrinsic generate-insn
[ init-intrinsic ]
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-t ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn drop %dispatch ;
M: ##copy generate-insn %copy ;
M: ##copy-float generate-insn %copy-float ;
M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
M: ##gc generate-insn drop %gc ;
! #alien-invoke
: set-stack-frame ( n -- )
dup [ frame-required ] when* \ stack-frame set ;
: with-stack-frame ( n quot -- )
swap set-stack-frame
call
f set-stack-frame ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@ -55,17 +167,17 @@ M: object reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" c-type <repetition> % ;
: (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- )
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type , ;
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- )
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type
flatten-value-type %
] reduce drop
] { } make ;
@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
M: #alien-invoke generate-node
M: ##alien-invoke generate-insn
params>>
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
dup objects>registers
%prepare-var-args
dup alien-invoke-dlsym %alien-invoke
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! Save registers for GC
%prepare-alien-invoke
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call function
dup alien-invoke-dlsym %alien-invoke
! Box return value
dup %cleanup
box-return* ;
! #alien-indirect
M: #alien-indirect generate-node
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
dup alien-invoke-frame [
! Flush registers
end-basic-block
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
! Box return value
dup %cleanup
box-return* ;
! #alien-callback
! ##alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
@ -264,18 +373,9 @@ TUPLE: callback-context ;
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
: generate-callback ( params -- )
dup xt>> dup [
init-templates
%prologue
dup alien-stack-frame [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-cfg-builder ;
M: #alien-callback generate-node
end-basic-block
params>> generate-callback iterate-next ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri ;

77
unfinished/compiler/codegen/fixup/fixup.factor
View File

@ -3,76 +3,20 @@
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.cfg.fixup
combinators math.bitwise words.private math.order accessors
growable compiler.constants compiler.backend ;
IN: compiler.codegen.fixup
: no-stack-frame -1 ; inline
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
GENERIC: fixup* ( frame-size obj -- frame-size )
GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
TUPLE: label offset ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset >>offset drop ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
[ 2drop ] [ stack-frame swap call ] if ; inline
M: word fixup*
{
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
SYMBOL: label-table
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute? ( n -- ? )
dup rc-absolute-cell =
over rc-absolute =
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
M: label fixup* compiled-offset >>offset drop ;
TUPLE: label-fixup label class ;
@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label>> swap class>> compiled-offset 4 - rot
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
@ -97,8 +41,6 @@ M: rel-fixup fixup*
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
: adjoin* ( obj table -- n )
@ -143,12 +85,11 @@ SYMBOL: literal-table
3array
] map concat ;
: fixup ( code -- literals relocation labels code )
: fixup ( fixup-directives -- code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
[ fixup* ] each
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;
] { } make 4array ;

116
unfinished/compiler/new/new.factor Normal file
View File

@ -0,0 +1,116 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.linear-scan
compiler.codegen ;
IN: compiler.new
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
: ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word effect -- ? )
#! If the word has previously been compiled and had a
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- )
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ]
2bi ;
: start ( word -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
: fail ( word error -- )
[ swap compiler-error ]
[
drop
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
] 2bi
return ;
: frontend ( word -- effect nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
compiled-xref
] [ drop ] if
] tri ;
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ calls>> [ queue-compile ] each ]
bi ;
: backend ( nodes word -- )
build-cfg [ build-mr linear-scan generate save-asm ] each ;
: (compile) ( word -- )
'[
_ {
[ start ]
[ frontend ]
[ backend ]
[ finish ]
} cleave
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;

16
unfinished/cpu/x86/syntax/syntax.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences lexer parser fry ;
IN: cpu.x86.syntax
: define-register ( name num size -- )
[ "cpu.x86" create dup define-symbol ]
[ dupd "register" set-word-prop ]
[ "register-size" set-word-prop ]
tri* ;
: define-registers ( names size -- )
[ dup length ] dip '[ _ define-register ] 2each ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing

1
unfinished/cpu/x86/syntax/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

470
unfinished/cpu/x86/x86.factor Executable file
View File

@ -0,0 +1,470 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.constants compiler.backend
compiler.codegen.fixup io.binary kernel combinators
kernel.private math namespaces make sequences words system
layouts math.order accessors cpu.x86.syntax ;
IN: cpu.x86
! A postfix assembler for x86 and AMD64.
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
TUPLE: byte value ;
C: <byte> byte
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
] when ;
: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
: indirect-base* ( op -- n ) base>> EBP or reg-code ;
: indirect-index* ( op -- n ) index>> ESP or reg-code ;
: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
[ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
M: register sib-present? drop f ;
GENERIC: r/m ( operand -- n )
M: indirect r/m
dup sib-present?
[ drop ESP reg-code ] [ indirect-base* ] if ;
M: register r/m reg-code ;
! Immediate operands
UNION: immediate byte integer ;
GENERIC: fits-in-byte? ( value -- ? )
M: byte fits-in-byte? drop t ;
M: integer fits-in-byte? -128 127 between? ;
GENERIC: modifier ( op -- n )
M: indirect modifier
dup base>> [
displacement>> {
{ [ dup not ] [ BIN: 00 ] }
{ [ dup fits-in-byte? ] [ BIN: 01 ] }
{ [ dup immediate? ] [ BIN: 10 ] }
} cond nip
] [
drop BIN: 00
] if ;
M: register modifier drop BIN: 11 ;
GENERIC# n, 1 ( value n -- )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
: 1, ( n -- ) 1 n, ; inline
: 4, ( n -- ) 4 n, ; inline
: 2, ( n -- ) 2 n, ; inline
: cell, ( n -- ) bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
: sib, ( indirect -- )
dup sib-present? [
[ indirect-base* ]
[ indirect-index* 3 shift ]
[ indirect-scale* 6 shift ] tri bitor bitor ,
] [
drop
] if ;
GENERIC: displacement, ( op -- )
M: indirect displacement,
dup displacement>> dup [
swap base>>
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
] [
2drop
] if ;
M: register displacement, drop ;
: addressing ( reg# indirect -- )
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
! Utilities
UNION: operand register indirect ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
: rex.w? ( rex.w reg r/m -- ? )
{
{ [ dup register-128? ] [ drop operand-64? ] }
{ [ dup not ] [ drop operand-64? ] }
[ nip operand-64? ]
} cond and ;
: rex.r ( m op -- n )
extended? [ BIN: 00000100 bitor ] when ;
: rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
index>> extended? [ BIN: 00000010 bitor ] when
] [
drop
] if ;
: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix.
2over rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b
dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ;
: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
: prefix-1 ( reg rex.w -- ) f swap prefix ;
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
: opcode-or ( opcode mask -- opcode' )
swap dup array?
[ unclip-last rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 1, ;
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
#! If imm is a byte, compile the opcode and the byte.
#! Otherwise, set the 8-bit operand flag in the opcode, and
#! compile the cell. The 'reg' is not really a register, but
#! a value for the 'reg' field of the mod-r/m byte.
pick fits-in-byte? [
immediate-fits-in-size-bit immediate-1
] [
immediate-4
] if ;
: (2-operand) ( dst src op -- )
>r 2dup t rex-prefix r> opcode,
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
pick register? [ BIN: 10 opcode-or swapd ] when ;
: operand-size-bit ( dst src op -- dst' src' op' )
over register-8? [ BIN: 1 opcode-or ] unless ;
: 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand.
2over 16-prefix
direction-bit
operand-size-bit
(2-operand) ;
PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when >r f f r> ]
[ f f ] if
<indirect> ;
! Moving stuff
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;
M: immediate PUSH HEX: 68 , 4, ;
M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
GENERIC: POP ( op -- )
M: register POP f HEX: 58 short-operand ;
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
! Control flow
GENERIC: JMP ( op -- )
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: word JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: word CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: word JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
: JB ( dst -- ) HEX: 82 JUMPcc ;
: JAE ( dst -- ) HEX: 83 JUMPcc ;
: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
: JNE ( dst -- ) HEX: 85 JUMPcc ;
: JBE ( dst -- ) HEX: 86 JUMPcc ;
: JA ( dst -- ) HEX: 87 JUMPcc ;
: JS ( dst -- ) HEX: 88 JUMPcc ;
: JNS ( dst -- ) HEX: 89 JUMPcc ;
: JP ( dst -- ) HEX: 8a JUMPcc ;
: JNP ( dst -- ) HEX: 8b JUMPcc ;
: JL ( dst -- ) HEX: 8c JUMPcc ;
: JGE ( dst -- ) HEX: 8d JUMPcc ;
: JLE ( dst -- ) HEX: 8e JUMPcc ;
: JG ( dst -- ) HEX: 8f JUMPcc ;
: LEAVE ( -- ) HEX: c9 , ;
: NOP ( -- ) HEX: 90 , ;
: RET ( n -- )
dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
! Arithmetic
GENERIC: ADD ( dst src -- )
M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
M: operand ADD OCT: 000 2-operand ;
GENERIC: OR ( dst src -- )
M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
M: operand OR OCT: 010 2-operand ;
GENERIC: ADC ( dst src -- )
M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
M: operand ADC OCT: 020 2-operand ;
GENERIC: SBB ( dst src -- )
M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
M: operand SBB OCT: 030 2-operand ;
GENERIC: AND ( dst src -- )
M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
M: operand AND OCT: 040 2-operand ;
GENERIC: SUB ( dst src -- )
M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
M: operand SUB OCT: 050 2-operand ;
GENERIC: XOR ( dst src -- )
M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
M: operand XOR OCT: 060 2-operand ;
GENERIC: CMP ( dst src -- )
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
: CDQ ( -- ) HEX: 99 , ;
: CQO ( -- ) HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
GENERIC: IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: MOVSX ( dst src -- )
dup register-32? OCT: 143 OCT: 276 extended-opcode ?
over register-16? [ BIN: 1 opcode-or ] when
swapd
(2-operand) ;
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
! CPU Identification
: CPUID ( -- ) HEX: a2 extended-opcode, ;
! x87 Floating Point Unit
: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
! SSE multimedia instructions
<PRIVATE
: direction-bit-sse ( dst src op1 -- dst' src' op1' )
pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
: 2-operand-sse ( dst src op1 op2 -- )
, direction-bit-sse extended-opcode (2-operand) ;
: 2-operand-int/sse ( dst src op1 op2 -- )
, swapd extended-opcode (2-operand) ;
PRIVATE>
: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;