: 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 ;
(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 ;
ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsection "sequences" }
+{ $subsection "virtual-sequences" }
{ $subsection "namespaces-make" }
"Fixed-length sequences:"
{ $subsection "arrays" }
! 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
! 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
{ "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" }
"{ $description \"\" } ;" print ;
: help-header. ( word -- )
- "HELP: " write name>> print ;
+ "HELP: " write . ;
: (help.) ( word -- )
[ help-header. ] [ $values. ] [ $description. ] tri ;
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
+ SunOS) OS=solaris;;
esac
}
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
+ i86pc) ARCH=x86;;
amd64) ARCH=x86;;
ppc64) ARCH=ppc;;
*86) ARCH=x86;;
$ECHO "ARCH: $ARCH"
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
+
+ echo $MAKE_TARGET
exit 5
fi
}
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
"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" } "."
{ $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
-USING: help.markup help.syntax libc kernel continuations io ;
+USING: help.markup help.syntax libc kernel continuations io
+sequences ;
IN: destructors
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
{ $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." } ;
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." }
{ $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." }
{ $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." }
{ $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"
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 -- )
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." } ;
{ $example "USING: kernel math prettyprint ;" "5 4 [ + ] 2curry ." "[ 5 4 + ]" }
} ;
-HELP: 3curry
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curry" curry } }
-{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
-{ $notes "This operation is efficient and does not copy the quotation." } ;
-
-HELP: with
-{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
-{ $description "Partial application on the left. The following two lines are equivalent:"
- { $code "swap [ swap A ] curry B" }
- { $code "[ A ] with B" }
-
+HELP: 3curry
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curry" curry } }
+{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
+{ $notes "This operation is efficient and does not copy the quotation." } ;
+
+HELP: with
+{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $description "Partial application on the left. The following two lines are equivalent:"
+ { $code "swap [ swap A ] curry B" }
+ { $code "[ A ] with B" }
+
+}
+{ $notes "This operation is efficient and does not copy the quotation." }
+{ $examples
+ { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
+} ;
+
+HELP: compose
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
+{ $notes
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
+ { $code
+ "compose call"
+ "append call"
+ }
+ "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
+} ;
+
+
+HELP: prepose
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
+{ $notes "See " { $link compose } " for details." } ;
+
+{ compose prepose } related-words
+
+HELP: 3compose
+{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
+{ $notes
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
+ { $code
+ "3compose call"
+ "3append call"
+ }
+ "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
+} ;
+
+HELP: dip
+{ $values { "obj" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+ { $code ">r foo bar r>" }
+ { $code "[ foo bar ] dip" }
+} ;
+
+HELP: 2dip
+{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+ { $code ">r >r foo bar r> r>" }
+ { $code "[ foo bar ] 2dip" }
+} ;
+
+HELP: while
+{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
+{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
+$nl
+"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
+{ $code
+ "[ P ] [ Q ] [ T ] while"
+ "[ P ] [ Q ] [ ] while T"
+}
+"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." }
+{ $error-description "Thrown when a unit test or other assertion fails." } ;
+
+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*"
}
-{ $notes "This operation is efficient and does not copy the quotation." }
-{ $examples
- { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
-} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
-{ $notes
- "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
- { $code
- "[ 3 >r ] [ r> . ] compose"
- }
- "Except for this restriction, the following two lines are equivalent:"
- { $code
- "compose call"
- "append call"
- }
- "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
-} ;
+$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? } ;
-HELP: prepose
-{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
-{ $notes "See " { $link compose } " for details." } ;
+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 } ;
-{ compose prepose } related-words
+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" } "." ;
-HELP: 3compose
-{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
-{ $notes
- "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
- { $code
- "[ >r ] swap [ r> ] 3compose"
- }
- "The correct way to achieve the effect of the above is the following:"
- { $code
- "[ dip ] curry"
- }
- "Excepting the retain stack restriction, the following two lines are equivalent:"
- { $code
- "3compose call"
- "3append call"
- }
- "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed 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" } "." ;
-HELP: dip
-{ $values { "obj" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r foo bar r>" }
- { $code "[ foo bar ] dip" }
-} ;
+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* } "." ;
-HELP: 2dip
-{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r >r foo bar r> r>" }
- { $code "[ foo bar ] 2dip" }
-} ;
+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" } ;
-HELP: while
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
-{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
-{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
+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
-"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
-{ $code
- "[ P ] [ Q ] [ T ] while"
- "[ P ] [ Q ] [ ] while T"
-}
-"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." } ;
+"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 } ;
-HELP: assert
-{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
-{ $description "Throws an " { $link assert } " error." }
-{ $error-description "Thrown when a unit test or other assertion fails." } ;
+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: assert=
-{ $values { "a" object } { "b" object } }
-{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
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." }
{ $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." } ;
{ $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"
+
-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
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"
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 } "." ;
+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" }
+} ;
-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" } ;
+HELP: length
+{ $values { "seq" sequence } { "n" "a non-negative integer" } }
+{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
-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." ;
+HELP: set-length
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
+{ $contract "Resizes the sequence. Not all sequences are resizable." }
+{ $errors "Throws a " { $link bounds-error } " if the new length is negative." }
+{ $side-effects "seq" } ;
-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 } ;
+HELP: lengthen
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
+{ $contract "Ensures the sequence has a length of at least " { $snippet "n" } " elements. This word differs from " { $link set-length } " in two respects:"
+ { $list
+ { "This word does not shrink the sequence if " { $snippet "n" } " is less than its length." }
+ { "The word doubles the underlying storage of " { $snippet "seq" } ", whereas " { $link set-length } " is permitted to set it to equal " { $snippet "n" } ". This ensures that repeated calls to this word with constant increments of " { $snippet "n" } " do not result in a quadratic amount of copying, so that for example " { $link push-all } " can run efficiently when used in a loop." }
+ }
+} ;
-ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
-"Adding elements:"
-{ $subsection prefix }
-{ $subsection suffix }
-"Removing elements:"
-{ $subsection remove }
-{ $subsection remove-nth } ;
+HELP: nth
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "elt" "the element at the " { $snippet "n" } "th index" } }
+{ $contract "Outputs the " { $snippet "n" } "th element of the sequence. Elements are numbered from zero, so the last element has an index one less than the length of the sequence. All sequences support this operation." }
+{ $errors "Throws a " { $link bounds-error } " if the index is negative, or greater than or equal to the length of the sequence." } ;
-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 } ;
+HELP: set-nth
+{ $values { "elt" object } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
+{ $contract "Sets the " { $snippet "n" } "th element of the sequence. Storing beyond the end of a resizable sequence such as a vector or string buffer grows the sequence." }
+{ $errors "Throws an error if the index is negative, or if the sequence is not resizable and the index is greater than or equal to the length of the sequence."
+$nl
+"Throws an error if the sequence cannot hold elements of the given type." }
+{ $side-effects "seq" } ;
-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 } ;
+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\" }"
+ }
+} ;
-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> } ;
+HELP: immutable
+{ $values { "seq" sequence } }
+{ $description "Throws an " { $link immutable } " error." }
+{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-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" } ;
+HELP: new-sequence
+{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
+{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
-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? } ;
+HELP: new-resizable
+{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }
+{ $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" }
+ { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
+} ;
-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? } ;
+HELP: like
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $contract "Outputs a sequence with the same elements as " { $snippet "seq" } ", but " { $emphasis "like" } " the template sequence, in the sense that it either has the same class as the template sequence, or if the template sequence is a virtual sequence, the same class as the template sequence's underlying sequence."
+$nl
+"The default implementation does nothing." }
+{ $notes "Unlike " { $link clone-like } ", the output sequence might share storage with the input sequence." } ;
-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 } ;
+HELP: empty?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if the sequence has zero length." } ;
-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" }
-} ;
-
-HELP: length
-{ $values { "seq" sequence } { "n" "a non-negative integer" } }
-{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
-
-HELP: set-length
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
-{ $contract "Resizes the sequence. Not all sequences are resizable." }
-{ $errors "Throws a " { $link bounds-error } " if the new length is negative." }
-{ $side-effects "seq" } ;
-
-HELP: lengthen
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
-{ $contract "Ensures the sequence has a length of at least " { $snippet "n" } " elements. This word differs from " { $link set-length } " in two respects:"
- { $list
- { "This word does not shrink the sequence if " { $snippet "n" } " is less than its length." }
- { "The word doubles the underlying storage of " { $snippet "seq" } ", whereas " { $link set-length } " is permitted to set it to equal " { $snippet "n" } ". This ensures that repeated calls to this word with constant increments of " { $snippet "n" } " do not result in a quadratic amount of copying, so that for example " { $link push-all } " can run efficiently when used in a loop." }
- }
-} ;
-
-HELP: nth
-{ $values { "n" "a non-negative integer" } { "seq" sequence } { "elt" "the element at the " { $snippet "n" } "th index" } }
-{ $contract "Outputs the " { $snippet "n" } "th element of the sequence. Elements are numbered from zero, so the last element has an index one less than the length of the sequence. All sequences support this operation." }
-{ $errors "Throws a " { $link bounds-error } " if the index is negative, or greater than or equal to the length of the sequence." } ;
-
-HELP: set-nth
-{ $values { "elt" object } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
-{ $contract "Sets the " { $snippet "n" } "th element of the sequence. Storing beyond the end of a resizable sequence such as a vector or string buffer grows the sequence." }
-{ $errors "Throws an error if the index is negative, or if the sequence is not resizable and the index is greater than or equal to the length of the sequence."
-$nl
-"Throws an error if the sequence cannot hold elements of the given type." }
-{ $side-effects "seq" } ;
-
-HELP: immutable
-{ $values { "seq" sequence } }
-{ $description "Throws an " { $link immutable } " error." }
-{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-
-HELP: new-sequence
-{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
-{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
-
-HELP: new-resizable
-{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }
-{ $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" }
- { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
-} ;
-
-HELP: like
-{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }
-{ $contract "Outputs a sequence with the same elements as " { $snippet "seq" } ", but " { $emphasis "like" } " the template sequence, in the sense that it either has the same class as the template sequence, or if the template sequence is a virtual sequence, the same class as the template sequence's underlying sequence."
-$nl
-"The default implementation does nothing." }
-{ $notes "Unlike " { $link clone-like } ", the output sequence might share storage with the input sequence." } ;
-
-HELP: empty?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests if the sequence has zero length." } ;
-
-HELP: if-empty
-{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
-{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
-{ $example
- "USING: kernel prettyprint sequences ;"
- "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
- "6"
-} ;
+HELP: if-empty
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel prettyprint sequences ;"
+ "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
+ "6"
+} ;
HELP: when-empty
{ $values
{ $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."
"{ 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"
-USING: kernel help.markup help.syntax sequences ;
+USING: kernel help.markup help.syntax sequences quotations ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
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." } ;
--- /dev/null
+Eduardo Cavazos
+Slava Pestov
--- /dev/null
+USING: mason.build tools.test sequences ;
+IN: mason.build.tests
+
+{ create-build-dir enter-build-dir clone-builds-factor record-id }
+[ must-infer ] each
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+USING: tools.test mason.cleanup ;
+IN: mason.cleanup.tests
+
+\ cleanup must-infer
--- /dev/null
+! 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 ;
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+IN: mason.release.tidy.tests
+USING: mason.release.tidy tools.test ;
--- /dev/null
+! 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 ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+IN: mason.report.tests
+USING: mason.report tools.test ;
--- /dev/null
+! 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 ;
\ No newline at end of file
--- /dev/null
+Continuous build system for Factor
--- /dev/null
+! 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
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.backend.alien
-
-! #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 ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
- dup reg-class-variable inc
- fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
- dup call-next-method
- fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-GENERIC: reg-class-full? ( class -- ? )
-
-M: stack-params reg-class-full? drop t ;
-
-M: object reg-class-full?
- [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
- stack-params get
- >r reg-size stack-params +@ r>
- stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
- [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
- c-type-reg-class dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if
- [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- )
- cell /i "void*" c-type <repetition> % ;
-
-GENERIC: flatten-value-type ( type -- )
-
-M: object flatten-value-type , ;
-
-M: struct-type flatten-value-type ( type -- )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- )
- stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- 0 [
- c-type
- [ parameter-align (flatten-int-type) ] keep
- [ stack-size cell align + ] keep
- flatten-value-type
- ] reduce drop
- ] { } make ;
-
-: each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
- { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
- #! In quot you can call alloc-parameter
- [ reset-freg-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
- #! Moves values from C stack to registers (if word is
- #! %load-param-reg) and registers to C stack (if word is
- #! %save-param-reg).
- >r
- alien-parameters
- flatten-value-types
- r> [ >r alloc-parameter r> execute ] curry each-parameter ;
- inline
-
-: unbox-parameters ( offset node -- )
- parameters>> [
- %prepare-unbox >r over + r> unbox-parameter
- ] reverse-each-parameter drop ;
-
-: prepare-box-struct ( node -- offset )
- #! Return offset on C stack where to store unboxed
- #! parameters. If the C function is returning a structure,
- #! the first parameter is an implicit target area pointer,
- #! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
-
-: objects>registers ( params -- )
- #! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to register on
- #! architectures where parameters are passed in registers.
- [
- [ prepare-box-struct ] keep
- [ unbox-parameters ] keep
- \ %load-param-reg move-parameters
- ] with-param-regs ;
-
-: box-return* ( node -- )
- return>> [ ] [ box-return ] if-void ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
- drop "Library not found" ;
-
-M: no-such-library compiler-error-type
- drop +linkage+ ;
-
-: no-such-library ( name -- )
- \ no-such-library boa
- compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
- drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
-
-: no-such-symbol ( name -- )
- \ no-such-symbol boa
- compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
- dup dll-valid? [
- dupd [ dlsym ] curry contains?
- [ drop ] [ no-such-symbol ] if
- ] [
- dll-path no-such-library drop
- ] if ;
-
-: stdcall-mangle ( symbol node -- symbol )
- "@"
- swap parameters>> parameter-sizes drop
- number>string 3append ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
- dup function>> dup pick stdcall-mangle 2array
- swap library>> library dup [ dll>> ] when
- 2dup check-dlsym ;
-
-M: #alien-invoke generate-node
- 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 ;
-
-! #alien-indirect
-M: #alien-indirect generate-node
- 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 ;
-
-! #alien-callback
-: box-parameters ( params -- )
- alien-parameters [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
- [
- dup \ %save-param-reg move-parameters
- "nest_stacks" f %alien-invoke
- box-parameters
- ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
- dup current-callback eq? [
- drop
- ] [
- yield wait-to-return
- ] if ;
-
-: do-callback ( quot token -- )
- init-catchstack
- dup 2 setenv
- slip
- wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
- return>> {
- { [ dup "void" = ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- [ c-type c-type-unboxer-quot ]
- } cond ;
-
-: callback-prep-quot ( params -- quot )
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
- [
- [ callback-prep-quot ]
- [ quot>> ]
- [ callback-return-quot ] tri 3append ,
- [ callback-context new do-callback ] %
- ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( params -- n )
- {
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
- { [ dup return>> large-struct? ] [ drop 4 ] }
- [ drop 0 ]
- } cond ;
-
-: %callback-return ( params -- )
- #! All the extra book-keeping for %unwind is only for x86.
- #! On other platforms its an alias for %return.
- dup alien-return
- [ %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 ;
-! 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
-! 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
-! 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
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
--- /dev/null
+! 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
--- /dev/null
+! 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
: 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
#! 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 ;
[ 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
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
] [
! #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@ {
} 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 ] [
! #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 ;
! 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
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 ;
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 ;
! 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: %gc ;
+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 ;
! 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 ;
-! Instructions used by CFG IR only.
-INSN: %prologue ;
-INSN: %epilogue ;
-INSN: %frame-required n ;
+: intrinsic-defs-vregs ( insn -- seq )
+ defs-vregs>> intrinsic-vregs ;
+
+: intrinsic-uses-vregs ( insn -- seq )
+ uses-vregs>> intrinsic-vregs ;
-INSN: %branch ;
-INSN: %branch-f < %cond-branch ;
-INSN: %branch-t < %cond-branch ;
-INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs dst ;
+M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
-M: %cond-branch uses-vregs src>> 1array ;
+! Instructions used by CFG IR only.
+INSN: ##prologue ;
+INSN: ##epilogue ;
+INSN: ##frame-required n ;
-! M: %if-intrinsic uses-vregs vregs>> values ;
+INSN: ##branch ;
+INSN: ##branch-f < ##cond-branch ;
+INSN: ##branch-t < ##cond-branch ;
+INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
-M: %boolean-intrinsic defs-vregs dst>> 1array ;
+M: ##cond-branch uses-vregs src>> >vreg 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 ;
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 ;
[ ] [ 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
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
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 -- )
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 ;
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 -- ? )
: 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*
- _if-intrinsic emit-branch ;
+: >intrinsic< ( insn -- quot defs uses )
+ [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
-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 ;
+M: ##if-intrinsic linearize-insn
+ [ conditional ] [ >intrinsic< ] bi*
+ _if-intrinsic emit-branch ;
: linearize-basic-block ( bb -- )
- [ label>> _label ] [ linearize-insns ] bi ;
+ [ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
! 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
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
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
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
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
: post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [
t >>visited
- <label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;
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 )
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?
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) ;
[ "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
: %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 ;
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 ;
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.
} 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)
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
: 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
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 ;
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 ;
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>
[ 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? [
[
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 -- ? )
: 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 )
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+GENERIC: reg-class-full? ( class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: object reg-class-full?
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- seq )
+ cell /i "void*" c-type <repetition> ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+
+M: struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) % ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type %
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> dup large-struct?
+ [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+ params>>
+ ! 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-insn
+ params>>
+ ! 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
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri ;
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 ;
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 ;
[ 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 )
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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
--- /dev/null
+unportable
--- /dev/null
+! 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 ;
projects / factor.git / commitdiff