Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
65f6eb1d95
|
|
@ -23,3 +23,30 @@ IN: compiler.constants
|
|||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
! Relocation classes
|
||||
: rc-absolute-cell 0 ;
|
||||
: rc-absolute 1 ;
|
||||
: rc-relative 2 ;
|
||||
: rc-absolute-ppc-2/2 3 ;
|
||||
: rc-relative-ppc-2 4 ;
|
||||
: rc-relative-ppc-3 5 ;
|
||||
: rc-relative-arm-3 6 ;
|
||||
: rc-indirect-arm 7 ;
|
||||
: rc-indirect-arm-pc 8 ;
|
||||
|
||||
! Relocation types
|
||||
: rt-primitive 0 ;
|
||||
: rt-dlsym 1 ;
|
||||
: rt-literal 2 ;
|
||||
: rt-dispatch 3 ;
|
||||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
[ rc-absolute-cell = ]
|
||||
[ rc-absolute = ]
|
||||
tri or or ;
|
||||
|
|
|
|||
|
|
@ -113,12 +113,6 @@ ERROR: no-sql-type ;
|
|||
(lookup-type) second
|
||||
] if ;
|
||||
|
||||
: paren ( string -- new-string )
|
||||
"(" swap ")" 3append ;
|
||||
|
||||
: join-space ( string1 string2 -- new-string )
|
||||
" " swap 3append ;
|
||||
|
||||
: modifiers ( spec -- string )
|
||||
modifiers>> [ lookup-modifier ] map " " join
|
||||
[ "" ] [ " " prepend ] if-empty ;
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ ERROR: no-vocab vocab ;
|
|||
"{ $description \"\" } ;" print ;
|
||||
|
||||
: help-header. ( word -- )
|
||||
"HELP: " write name>> print ;
|
||||
"HELP: " write . ;
|
||||
|
||||
: (help.) ( word -- )
|
||||
[ help-header. ] [ $values. ] [ $description. ] tri ;
|
||||
|
|
|
|||
|
|
@ -175,7 +175,7 @@ find_os() {
|
|||
*FreeBSD*) OS=freebsd;;
|
||||
*OpenBSD*) OS=openbsd;;
|
||||
*DragonFly*) OS=dragonflybsd;;
|
||||
SunOS) OS=solaris;;
|
||||
SunOS) OS=solaris;;
|
||||
esac
|
||||
}
|
||||
|
||||
|
|
@ -263,7 +263,8 @@ check_os_arch_word() {
|
|||
$ECHO "ARCH: $ARCH"
|
||||
$ECHO "WORD: $WORD"
|
||||
$ECHO "OS, ARCH, or WORD is empty. Please report this."
|
||||
echo $MAKE_TARGET
|
||||
|
||||
echo $MAKE_TARGET
|
||||
exit 5
|
||||
fi
|
||||
}
|
||||
|
|
|
|||
|
|
@ -77,6 +77,9 @@ $nl
|
|||
"Another two words resume continuations:"
|
||||
{ $subsection continue }
|
||||
{ $subsection continue-with }
|
||||
"Continuations as control-flow:"
|
||||
{ $subsection attempt-all }
|
||||
{ $subsection with-return }
|
||||
"Reflecting the datastack:"
|
||||
{ $subsection with-datastack }
|
||||
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
|
||||
|
|
@ -211,3 +214,42 @@ HELP: with-datastack
|
|||
{ $examples
|
||||
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
|
||||
} ;
|
||||
|
||||
HELP: <continuation>
|
||||
{ $description "Constructs a new continuation." }
|
||||
{ $notes "User code should call " { $link continuation } " instead." } ;
|
||||
|
||||
HELP: attempt-all
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
{ "obj" object } }
|
||||
{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
|
||||
{ $examples "The first two numbers throw, the last one doesn't:"
|
||||
{ $example
|
||||
"USING: prettyprint continuations kernel math ;"
|
||||
"{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
|
||||
"6" }
|
||||
"All quotations throw, the last exception is rethrown:"
|
||||
{ $example
|
||||
"USING: prettyprint continuations kernel math ;"
|
||||
"[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
|
||||
"5"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: return
|
||||
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
|
||||
|
||||
HELP: with-return
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
|
||||
{ $examples
|
||||
"Only \"Hi\" will print:"
|
||||
{ $example
|
||||
"USING: prettyprint continuations io ;"
|
||||
"[ \"Hi\" print return \"Bye\" print ] with-return"
|
||||
"Hi"
|
||||
} } ;
|
||||
|
||||
{ return with-return } related-words
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.markup help.syntax libc kernel continuations io ;
|
||||
USING: help.markup help.syntax libc kernel continuations io
|
||||
sequences ;
|
||||
IN: destructors
|
||||
|
||||
HELP: dispose
|
||||
|
|
@ -45,6 +46,11 @@ HELP: |dispose
|
|||
{ $values { "disposable" "a disposable object" } }
|
||||
{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
|
||||
|
||||
HELP: dispose-each
|
||||
{ $values
|
||||
{ "seq" sequence } }
|
||||
{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ;
|
||||
|
||||
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
|
||||
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
|
||||
{ $code
|
||||
|
|
|
|||
|
|
@ -111,6 +111,12 @@ HELP: associate
|
|||
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
|
||||
{ $description "Create a new hashtable holding one key/value pair." } ;
|
||||
|
||||
HELP: ?set-at
|
||||
{ $values
|
||||
{ "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } }
|
||||
{ "assoc" assoc } }
|
||||
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
|
||||
|
||||
HELP: >hashtable
|
||||
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
|
||||
{ $description "Constructs a hashtable from any assoc." } ;
|
||||
|
|
|
|||
|
|
@ -1,128 +1,7 @@
|
|||
USING: help.markup help.syntax quotations hashtables kernel
|
||||
classes strings continuations destructors ;
|
||||
classes strings continuations destructors math ;
|
||||
IN: io
|
||||
|
||||
ARTICLE: "stream-protocol" "Stream protocol"
|
||||
"The stream protocol consists of a large number of generic words, many of which are optional."
|
||||
$nl
|
||||
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
|
||||
$nl
|
||||
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
|
||||
$nl
|
||||
"Three words are required for input streams:"
|
||||
{ $subsection stream-read1 }
|
||||
{ $subsection stream-read }
|
||||
{ $subsection stream-read-until }
|
||||
{ $subsection stream-readln }
|
||||
"Seven words are required for output streams:"
|
||||
{ $subsection stream-flush }
|
||||
{ $subsection stream-write1 }
|
||||
{ $subsection stream-write }
|
||||
{ $subsection stream-format }
|
||||
{ $subsection stream-nl }
|
||||
{ $subsection make-span-stream }
|
||||
{ $subsection make-block-stream }
|
||||
{ $subsection make-cell-stream }
|
||||
{ $subsection stream-write-table }
|
||||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "stdio" "Default input and output streams"
|
||||
"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
|
||||
{ $list
|
||||
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
|
||||
{ "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
|
||||
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
|
||||
}
|
||||
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader>"
|
||||
"dup stream-readln number>string over stream-read 16 group"
|
||||
"swap dispose"
|
||||
}
|
||||
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader> ["
|
||||
" dup stream-readln number>string over stream-read"
|
||||
" 16 group"
|
||||
"] with-disposal"
|
||||
}
|
||||
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader> ["
|
||||
" readln number>string read 16 group"
|
||||
"] with-input-stream"
|
||||
}
|
||||
"An even better implementation that takes advantage of a utility word:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 ["
|
||||
" readln number>string read 16 group"
|
||||
"] with-file-reader"
|
||||
}
|
||||
"The default input stream is stored in a dynamically-scoped variable:"
|
||||
{ $subsection input-stream }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
|
||||
$nl
|
||||
"Words reading from the default input stream:"
|
||||
{ $subsection read1 }
|
||||
{ $subsection read }
|
||||
{ $subsection read-until }
|
||||
{ $subsection readln }
|
||||
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
|
||||
{ $subsection with-input-stream }
|
||||
{ $subsection with-input-stream* }
|
||||
"The default output stream is stored in a dynamically-scoped variable:"
|
||||
{ $subsection output-stream }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
|
||||
$nl
|
||||
"Words writing to the default input stream:"
|
||||
{ $subsection flush }
|
||||
{ $subsection write1 }
|
||||
{ $subsection write }
|
||||
{ $subsection print }
|
||||
{ $subsection nl }
|
||||
{ $subsection bl }
|
||||
"Formatted output:"
|
||||
{ $subsection format }
|
||||
{ $subsection with-style }
|
||||
{ $subsection with-nesting }
|
||||
"Tabular output:"
|
||||
{ $subsection tabular-output }
|
||||
{ $subsection with-row }
|
||||
{ $subsection with-cell }
|
||||
{ $subsection write-cell }
|
||||
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
|
||||
{ $subsection with-output-stream }
|
||||
{ $subsection with-output-stream* }
|
||||
"A pair of combinators for rebinding both default streams at once:"
|
||||
{ $subsection with-streams }
|
||||
{ $subsection with-streams* } ;
|
||||
|
||||
ARTICLE: "stream-utils" "Stream utilities"
|
||||
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
|
||||
$nl
|
||||
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
|
||||
{ $subsection stream-print }
|
||||
"Sluring an entire stream into memory all at once:"
|
||||
{ $subsection lines }
|
||||
{ $subsection contents }
|
||||
"Copying the contents of one stream to another:"
|
||||
{ $subsection stream-copy } ;
|
||||
|
||||
ARTICLE: "streams" "Streams"
|
||||
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
|
||||
$nl
|
||||
"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
|
||||
{ $subsection "stream-protocol" }
|
||||
{ $subsection "stdio" }
|
||||
{ $subsection "stream-utils" }
|
||||
{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
|
||||
|
||||
ABOUT: "streams"
|
||||
|
||||
HELP: stream-readln
|
||||
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
|
||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||
|
|
@ -147,6 +26,12 @@ HELP: stream-read-until
|
|||
{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: stream-read-partial
|
||||
{ $values
|
||||
{ "n" integer } { "stream" "an input stream" }
|
||||
{ "str/f" "a string or " { $link f } } }
|
||||
{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
|
||||
|
||||
HELP: stream-write1
|
||||
{ $values { "ch" "a character" } { "stream" "an output stream" } }
|
||||
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
|
||||
|
|
@ -249,6 +134,12 @@ HELP: read-until
|
|||
{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: read-partial
|
||||
{ $values
|
||||
{ "n" null }
|
||||
{ "str/f" null } }
|
||||
{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
|
||||
|
||||
HELP: write1
|
||||
{ $values { "ch" "a character" } }
|
||||
{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
|
||||
|
|
@ -363,3 +254,126 @@ HELP: contents
|
|||
{ $values { "stream" "an input stream" } { "str" string } }
|
||||
{ $description "Reads the entire contents of a stream into a string." }
|
||||
$io-error ;
|
||||
|
||||
ARTICLE: "stream-protocol" "Stream protocol"
|
||||
"The stream protocol consists of a large number of generic words, many of which are optional."
|
||||
$nl
|
||||
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
|
||||
$nl
|
||||
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
|
||||
$nl
|
||||
"These words are required for input streams:"
|
||||
{ $subsection stream-read1 }
|
||||
{ $subsection stream-read }
|
||||
{ $subsection stream-read-until }
|
||||
{ $subsection stream-readln }
|
||||
{ $subsection stream-read-partial }
|
||||
"These words are required for output streams:"
|
||||
{ $subsection stream-flush }
|
||||
{ $subsection stream-write1 }
|
||||
{ $subsection stream-write }
|
||||
{ $subsection stream-format }
|
||||
{ $subsection stream-nl }
|
||||
{ $subsection make-span-stream }
|
||||
{ $subsection make-block-stream }
|
||||
{ $subsection make-cell-stream }
|
||||
{ $subsection stream-write-table }
|
||||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "stdio" "Default input and output streams"
|
||||
"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
|
||||
{ $list
|
||||
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
|
||||
{ "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
|
||||
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
|
||||
}
|
||||
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader>"
|
||||
"dup stream-readln number>string over stream-read 16 group"
|
||||
"swap dispose"
|
||||
}
|
||||
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader> ["
|
||||
" dup stream-readln number>string over stream-read"
|
||||
" 16 group"
|
||||
"] with-disposal"
|
||||
}
|
||||
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 <file-reader> ["
|
||||
" readln number>string read 16 group"
|
||||
"] with-input-stream"
|
||||
}
|
||||
"An even better implementation that takes advantage of a utility word:"
|
||||
{ $code
|
||||
"USING: continuations kernel io io.files math.parser splitting ;"
|
||||
"\"data.txt\" utf8 ["
|
||||
" readln number>string read 16 group"
|
||||
"] with-file-reader"
|
||||
}
|
||||
"The default input stream is stored in a dynamically-scoped variable:"
|
||||
{ $subsection input-stream }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
|
||||
$nl
|
||||
"Words reading from the default input stream:"
|
||||
{ $subsection read1 }
|
||||
{ $subsection read }
|
||||
{ $subsection read-until }
|
||||
{ $subsection readln }
|
||||
{ $subsection read-partial }
|
||||
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
|
||||
{ $subsection with-input-stream }
|
||||
{ $subsection with-input-stream* }
|
||||
"The default output stream is stored in a dynamically-scoped variable:"
|
||||
{ $subsection output-stream }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
|
||||
$nl
|
||||
"Words writing to the default input stream:"
|
||||
{ $subsection flush }
|
||||
{ $subsection write1 }
|
||||
{ $subsection write }
|
||||
{ $subsection print }
|
||||
{ $subsection nl }
|
||||
{ $subsection bl }
|
||||
"Formatted output:"
|
||||
{ $subsection format }
|
||||
{ $subsection with-style }
|
||||
{ $subsection with-nesting }
|
||||
"Tabular output:"
|
||||
{ $subsection tabular-output }
|
||||
{ $subsection with-row }
|
||||
{ $subsection with-cell }
|
||||
{ $subsection write-cell }
|
||||
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
|
||||
{ $subsection with-output-stream }
|
||||
{ $subsection with-output-stream* }
|
||||
"A pair of combinators for rebinding both default streams at once:"
|
||||
{ $subsection with-streams }
|
||||
{ $subsection with-streams* } ;
|
||||
|
||||
ARTICLE: "stream-utils" "Stream utilities"
|
||||
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
|
||||
$nl
|
||||
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
|
||||
{ $subsection stream-print }
|
||||
"Sluring an entire stream into memory all at once:"
|
||||
{ $subsection lines }
|
||||
{ $subsection contents }
|
||||
"Copying the contents of one stream to another:"
|
||||
{ $subsection stream-copy } ;
|
||||
|
||||
ARTICLE: "streams" "Streams"
|
||||
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
|
||||
$nl
|
||||
"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
|
||||
{ $subsection "stream-protocol" }
|
||||
{ $subsection "stdio" }
|
||||
{ $subsection "stream-utils" }
|
||||
{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
|
||||
|
||||
ABOUT: "streams"
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ GENERIC: stream-readln ( stream -- str/f )
|
|||
GENERIC: stream-read1 ( stream -- ch/f )
|
||||
GENERIC: stream-read ( n stream -- str/f )
|
||||
GENERIC: stream-read-until ( seps stream -- str/f sep/f )
|
||||
GENERIC: stream-read-partial ( max stream -- str/f )
|
||||
GENERIC: stream-read-partial ( n stream -- str/f )
|
||||
GENERIC: stream-write1 ( ch stream -- )
|
||||
GENERIC: stream-write ( str stream -- )
|
||||
GENERIC: stream-flush ( stream -- )
|
||||
|
|
|
|||
|
|
@ -4,289 +4,6 @@ kernel.private vectors combinators quotations strings words
|
|||
assocs arrays math.order ;
|
||||
IN: kernel
|
||||
|
||||
ARTICLE: "shuffle-words" "Shuffle words"
|
||||
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
|
||||
$nl
|
||||
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
|
||||
$nl
|
||||
"Removing stack elements:"
|
||||
{ $subsection drop }
|
||||
{ $subsection 2drop }
|
||||
{ $subsection 3drop }
|
||||
{ $subsection nip }
|
||||
{ $subsection 2nip }
|
||||
"Duplicating stack elements:"
|
||||
{ $subsection dup }
|
||||
{ $subsection 2dup }
|
||||
{ $subsection 3dup }
|
||||
{ $subsection dupd }
|
||||
{ $subsection over }
|
||||
{ $subsection 2over }
|
||||
{ $subsection pick }
|
||||
{ $subsection tuck }
|
||||
"Permuting stack elements:"
|
||||
{ $subsection swap }
|
||||
{ $subsection swapd }
|
||||
{ $subsection rot }
|
||||
{ $subsection -rot }
|
||||
{ $subsection spin }
|
||||
{ $subsection roll }
|
||||
{ $subsection -roll }
|
||||
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
|
||||
{ $subsection >r }
|
||||
{ $subsection r> }
|
||||
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
|
||||
{ $example "1 2 3 >r .s r>" "1\n2" }
|
||||
"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
|
||||
$nl
|
||||
"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
|
||||
|
||||
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
|
||||
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
|
||||
{ $code
|
||||
": keep [ ] bi ;"
|
||||
": 2keep [ ] 2bi ;"
|
||||
": 3keep [ ] 3bi ;"
|
||||
""
|
||||
": dup [ ] [ ] bi ;"
|
||||
": 2dup [ ] [ ] 2bi ;"
|
||||
": 3dup [ ] [ ] 3bi ;"
|
||||
""
|
||||
": tuck [ nip ] [ ] 2bi ;"
|
||||
": swap [ nip ] [ drop ] 2bi ;"
|
||||
""
|
||||
": over [ ] [ drop ] 2bi ;"
|
||||
": pick [ ] [ 2drop ] 3bi ;"
|
||||
": 2over [ ] [ drop ] 3bi ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "cleave-combinators" "Cleave combinators"
|
||||
"The cleave combinators apply multiple quotations to a single value."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi }
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 3bi }
|
||||
"Three quotations:"
|
||||
{ $subsection tri }
|
||||
{ $subsection 2tri }
|
||||
{ $subsection 3tri }
|
||||
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses keep"
|
||||
"[ 1 + ] keep"
|
||||
"[ 1 - ] keep"
|
||||
"2 *"
|
||||
"! Second alternative: uses tri"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri"
|
||||
}
|
||||
"The latter is more aesthetically pleasing than the former."
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "cleave-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
|
||||
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
|
||||
{ $code
|
||||
": dip [ ] bi* ;"
|
||||
": 2dip [ ] [ ] tri* ;"
|
||||
""
|
||||
": slip [ call ] [ ] bi* ;"
|
||||
": 2slip [ call ] [ ] [ ] tri* ;"
|
||||
""
|
||||
": nip [ drop ] [ ] bi* ;"
|
||||
": 2nip [ drop ] [ drop ] [ ] tri* ;"
|
||||
""
|
||||
": rot"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": -rot"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": spin"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread combinators"
|
||||
"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi* }
|
||||
{ $subsection 2bi* }
|
||||
"Three quotations:"
|
||||
{ $subsection tri* }
|
||||
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses retain stack explicitly"
|
||||
">r >r 1 +"
|
||||
"r> 1 -"
|
||||
"r> 2 *"
|
||||
"! Second alternative: uses tri*"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri*"
|
||||
}
|
||||
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "spread-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "apply-combinators" "Apply combinators"
|
||||
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi@ }
|
||||
{ $subsection 2bi@ }
|
||||
"Three quotations:"
|
||||
{ $subsection tri@ }
|
||||
"A pair of utility words built from " { $link bi@ } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? } ;
|
||||
|
||||
ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
|
||||
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
|
||||
{ $subsection dip }
|
||||
{ $subsection 2dip }
|
||||
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
|
||||
{ $subsection slip }
|
||||
{ $subsection 2slip }
|
||||
{ $subsection 3slip }
|
||||
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
|
||||
{ $subsection keep }
|
||||
{ $subsection 2keep }
|
||||
{ $subsection 3keep } ;
|
||||
|
||||
ARTICLE: "compositional-combinators" "Compositional combinators"
|
||||
"Quotations can be composed using efficient quotation-specific operations:"
|
||||
{ $subsection curry }
|
||||
{ $subsection 2curry }
|
||||
{ $subsection 3curry }
|
||||
{ $subsection with }
|
||||
{ $subsection compose }
|
||||
{ $subsection 3compose }
|
||||
{ $subsection prepose }
|
||||
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
|
||||
|
||||
ARTICLE: "implementing-combinators" "Implementing combinators"
|
||||
"The following pair of words invoke words and quotations reflectively:"
|
||||
{ $subsection call }
|
||||
{ $subsection execute }
|
||||
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
|
||||
{ $code
|
||||
": keep ( x quot -- x )"
|
||||
" over >r call r> ; inline"
|
||||
}
|
||||
"Word inlining is documented in " { $link "declarations" } "." ;
|
||||
|
||||
ARTICLE: "booleans" "Booleans"
|
||||
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
|
||||
{ $subsection f }
|
||||
{ $subsection t }
|
||||
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
|
||||
$nl
|
||||
"Here is the " { $link f } " object:"
|
||||
{ $example "f ." "f" }
|
||||
"Here is the " { $link f } " class:"
|
||||
{ $example "\\ f ." "POSTPONE: f" }
|
||||
"They are not equal:"
|
||||
{ $example "f \\ f = ." "f" }
|
||||
"Here is an array containing the " { $link f } " object:"
|
||||
{ $example "{ f } ." "{ f }" }
|
||||
"Here is an array containing the " { $link f } " class:"
|
||||
{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
|
||||
"The " { $link f } " object is an instance of the " { $link f } " class:"
|
||||
{ $example "f class ." "POSTPONE: f" }
|
||||
"The " { $link f } " class is an instance of " { $link word } ":"
|
||||
{ $example "\\ f class ." "word" }
|
||||
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
|
||||
{ $example "t \\ t eq? ." "t" }
|
||||
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
|
||||
|
||||
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
|
||||
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ drop f ] unless" "swap and" }
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ ] [ ] ?if" "swap or" }
|
||||
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
|
||||
{ $code "[ L ] unless*" "L or" } ;
|
||||
|
||||
ARTICLE: "conditionals" "Conditionals and logic"
|
||||
"The basic conditionals:"
|
||||
{ $subsection if }
|
||||
{ $subsection when }
|
||||
{ $subsection unless }
|
||||
"Forms abstracting a common stack shuffle pattern:"
|
||||
{ $subsection if* }
|
||||
{ $subsection when* }
|
||||
{ $subsection unless* }
|
||||
"Another form abstracting a common stack shuffle pattern:"
|
||||
{ $subsection ?if }
|
||||
"Sometimes instead of branching, you just need to pick one of two values:"
|
||||
{ $subsection ? }
|
||||
"There are some logical operations on booleans:"
|
||||
{ $subsection >boolean }
|
||||
{ $subsection not }
|
||||
{ $subsection and }
|
||||
{ $subsection or }
|
||||
{ $subsection xor }
|
||||
{ $subsection "conditionals-boolean-equivalence" }
|
||||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
ARTICLE: "equality" "Equality"
|
||||
"There are two distinct notions of ``sameness'' when it comes to objects."
|
||||
$nl
|
||||
"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
|
||||
{ $subsection eq? }
|
||||
"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
|
||||
{ $subsection = }
|
||||
"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
|
||||
$nl
|
||||
"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
|
||||
{ $subsection equal? }
|
||||
"Utility class:"
|
||||
{ $subsection identity-tuple }
|
||||
"An object can be cloned; the clone has distinct identity but equal value:"
|
||||
{ $subsection clone } ;
|
||||
|
||||
ARTICLE: "dataflow" "Data and control flow"
|
||||
{ $subsection "evaluator" }
|
||||
{ $subsection "words" }
|
||||
{ $subsection "effects" }
|
||||
{ $subsection "booleans" }
|
||||
{ $subsection "shuffle-words" }
|
||||
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
|
||||
{ $subsection "cleave-combinators" }
|
||||
{ $subsection "spread-combinators" }
|
||||
{ $subsection "apply-combinators" }
|
||||
{ $subsection "slip-keep-combinators" }
|
||||
{ $subsection "conditionals" }
|
||||
{ $subsection "compositional-combinators" }
|
||||
{ $subsection "combinators" }
|
||||
"Advanced topics:"
|
||||
{ $subsection "implementing-combinators" }
|
||||
{ $subsection "errors" }
|
||||
{ $subsection "continuations" } ;
|
||||
|
||||
ABOUT: "dataflow"
|
||||
|
||||
HELP: eq? ( obj1 obj2 -- ? )
|
||||
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
|
||||
{ $description "Tests if two references point at the same object." } ;
|
||||
|
|
@ -916,6 +633,20 @@ $nl
|
|||
}
|
||||
"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
|
||||
|
||||
HELP: loop
|
||||
{ $values
|
||||
{ "pred" quotation } }
|
||||
{ $description "Calls the quotation repeatedly until the output is true." }
|
||||
{ $examples "Loop until we hit a zero:"
|
||||
{ $unchecked-example "USING: kernel random math io ; "
|
||||
" [ \"hi\" write bl 10 random zero? not ] loop"
|
||||
"hi hi hi" }
|
||||
"A fun loop:"
|
||||
{ $example "USING: kernel prettyprint math ; "
|
||||
"3 [ dup . 7 + 11 mod dup 3 = not ] loop"
|
||||
"3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" }
|
||||
} ;
|
||||
|
||||
HELP: assert
|
||||
{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
|
||||
{ $description "Throws an " { $link assert } " error." }
|
||||
|
|
@ -924,3 +655,288 @@ HELP: assert
|
|||
HELP: assert=
|
||||
{ $values { "a" object } { "b" object } }
|
||||
{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
|
||||
|
||||
|
||||
ARTICLE: "shuffle-words" "Shuffle words"
|
||||
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
|
||||
$nl
|
||||
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
|
||||
$nl
|
||||
"Removing stack elements:"
|
||||
{ $subsection drop }
|
||||
{ $subsection 2drop }
|
||||
{ $subsection 3drop }
|
||||
{ $subsection nip }
|
||||
{ $subsection 2nip }
|
||||
"Duplicating stack elements:"
|
||||
{ $subsection dup }
|
||||
{ $subsection 2dup }
|
||||
{ $subsection 3dup }
|
||||
{ $subsection dupd }
|
||||
{ $subsection over }
|
||||
{ $subsection 2over }
|
||||
{ $subsection pick }
|
||||
{ $subsection tuck }
|
||||
"Permuting stack elements:"
|
||||
{ $subsection swap }
|
||||
{ $subsection swapd }
|
||||
{ $subsection rot }
|
||||
{ $subsection -rot }
|
||||
{ $subsection spin }
|
||||
{ $subsection roll }
|
||||
{ $subsection -roll }
|
||||
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
|
||||
{ $subsection >r }
|
||||
{ $subsection r> }
|
||||
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
|
||||
{ $example "1 2 3 >r .s r>" "1\n2" }
|
||||
"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
|
||||
$nl
|
||||
"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
|
||||
|
||||
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
|
||||
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
|
||||
{ $code
|
||||
": keep [ ] bi ;"
|
||||
": 2keep [ ] 2bi ;"
|
||||
": 3keep [ ] 3bi ;"
|
||||
""
|
||||
": dup [ ] [ ] bi ;"
|
||||
": 2dup [ ] [ ] 2bi ;"
|
||||
": 3dup [ ] [ ] 3bi ;"
|
||||
""
|
||||
": tuck [ nip ] [ ] 2bi ;"
|
||||
": swap [ nip ] [ drop ] 2bi ;"
|
||||
""
|
||||
": over [ ] [ drop ] 2bi ;"
|
||||
": pick [ ] [ 2drop ] 3bi ;"
|
||||
": 2over [ ] [ drop ] 3bi ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "cleave-combinators" "Cleave combinators"
|
||||
"The cleave combinators apply multiple quotations to a single value."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi }
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 3bi }
|
||||
"Three quotations:"
|
||||
{ $subsection tri }
|
||||
{ $subsection 2tri }
|
||||
{ $subsection 3tri }
|
||||
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses keep"
|
||||
"[ 1 + ] keep"
|
||||
"[ 1 - ] keep"
|
||||
"2 *"
|
||||
"! Second alternative: uses tri"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri"
|
||||
}
|
||||
"The latter is more aesthetically pleasing than the former."
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "cleave-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
|
||||
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
|
||||
$nl
|
||||
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
|
||||
{ $code
|
||||
": dip [ ] bi* ;"
|
||||
": 2dip [ ] [ ] tri* ;"
|
||||
""
|
||||
": slip [ call ] [ ] bi* ;"
|
||||
": 2slip [ call ] [ ] [ ] tri* ;"
|
||||
""
|
||||
": nip [ drop ] [ ] bi* ;"
|
||||
": 2nip [ drop ] [ drop ] [ ] tri* ;"
|
||||
""
|
||||
": rot"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": -rot"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
""
|
||||
": spin"
|
||||
" [ [ drop ] [ drop ] [ ] tri* ]"
|
||||
" [ [ drop ] [ ] [ drop ] tri* ]"
|
||||
" [ [ ] [ drop ] [ drop ] tri* ]"
|
||||
" 3tri ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread combinators"
|
||||
"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi* }
|
||||
{ $subsection 2bi* }
|
||||
"Three quotations:"
|
||||
{ $subsection tri* }
|
||||
"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
|
||||
{ $code
|
||||
"! First alternative; uses retain stack explicitly"
|
||||
">r >r 1 +"
|
||||
"r> 1 -"
|
||||
"r> 2 *"
|
||||
"! Second alternative: uses tri*"
|
||||
"[ 1 + ]"
|
||||
"[ 1 - ]"
|
||||
"[ 2 * ] tri*"
|
||||
}
|
||||
|
||||
$nl
|
||||
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
|
||||
{ $subsection "spread-shuffle-equivalence" } ;
|
||||
|
||||
ARTICLE: "apply-combinators" "Apply combinators"
|
||||
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
|
||||
$nl
|
||||
"Two quotations:"
|
||||
{ $subsection bi@ }
|
||||
{ $subsection 2bi@ }
|
||||
"Three quotations:"
|
||||
{ $subsection tri@ }
|
||||
"A pair of utility words built from " { $link bi@ } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? } ;
|
||||
|
||||
ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
|
||||
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
|
||||
{ $subsection dip }
|
||||
{ $subsection 2dip }
|
||||
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
|
||||
{ $subsection slip }
|
||||
{ $subsection 2slip }
|
||||
{ $subsection 3slip }
|
||||
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
|
||||
{ $subsection keep }
|
||||
{ $subsection 2keep }
|
||||
{ $subsection 3keep } ;
|
||||
|
||||
ARTICLE: "compositional-combinators" "Compositional combinators"
|
||||
"Quotations can be composed using efficient quotation-specific operations:"
|
||||
{ $subsection curry }
|
||||
{ $subsection 2curry }
|
||||
{ $subsection 3curry }
|
||||
{ $subsection with }
|
||||
{ $subsection compose }
|
||||
{ $subsection 3compose }
|
||||
{ $subsection prepose }
|
||||
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
|
||||
|
||||
ARTICLE: "implementing-combinators" "Implementing combinators"
|
||||
"The following pair of words invoke words and quotations reflectively:"
|
||||
{ $subsection call }
|
||||
{ $subsection execute }
|
||||
"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
|
||||
{ $code
|
||||
": keep ( x quot -- x )"
|
||||
" over >r call r> ; inline"
|
||||
}
|
||||
"Word inlining is documented in " { $link "declarations" } "." ;
|
||||
|
||||
ARTICLE: "booleans" "Booleans"
|
||||
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
|
||||
{ $subsection f }
|
||||
{ $subsection t }
|
||||
"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
|
||||
$nl
|
||||
"Here is the " { $link f } " object:"
|
||||
{ $example "f ." "f" }
|
||||
"Here is the " { $link f } " class:"
|
||||
{ $example "\\ f ." "POSTPONE: f" }
|
||||
"They are not equal:"
|
||||
{ $example "f \\ f = ." "f" }
|
||||
"Here is an array containing the " { $link f } " object:"
|
||||
{ $example "{ f } ." "{ f }" }
|
||||
"Here is an array containing the " { $link f } " class:"
|
||||
{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
|
||||
"The " { $link f } " object is an instance of the " { $link f } " class:"
|
||||
{ $example "f class ." "POSTPONE: f" }
|
||||
"The " { $link f } " class is an instance of " { $link word } ":"
|
||||
{ $example "\\ f class ." "word" }
|
||||
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
|
||||
{ $example "t \\ t eq? ." "t" }
|
||||
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
|
||||
|
||||
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
|
||||
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ drop f ] unless" "swap and" }
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ ] [ ] ?if" "swap or" }
|
||||
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
|
||||
{ $code "[ L ] unless*" "L or" } ;
|
||||
|
||||
ARTICLE: "conditionals" "Conditionals and logic"
|
||||
"The basic conditionals:"
|
||||
{ $subsection if }
|
||||
{ $subsection when }
|
||||
{ $subsection unless }
|
||||
"Forms abstracting a common stack shuffle pattern:"
|
||||
{ $subsection if* }
|
||||
{ $subsection when* }
|
||||
{ $subsection unless* }
|
||||
"Another form abstracting a common stack shuffle pattern:"
|
||||
{ $subsection ?if }
|
||||
"Sometimes instead of branching, you just need to pick one of two values:"
|
||||
{ $subsection ? }
|
||||
"There are some logical operations on booleans:"
|
||||
{ $subsection >boolean }
|
||||
{ $subsection not }
|
||||
{ $subsection and }
|
||||
{ $subsection or }
|
||||
{ $subsection xor }
|
||||
{ $subsection "conditionals-boolean-equivalence" }
|
||||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
ARTICLE: "equality" "Equality"
|
||||
"There are two distinct notions of ``sameness'' when it comes to objects."
|
||||
$nl
|
||||
"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
|
||||
{ $subsection eq? }
|
||||
"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
|
||||
{ $subsection = }
|
||||
"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
|
||||
$nl
|
||||
"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
|
||||
{ $subsection equal? }
|
||||
"Utility class:"
|
||||
{ $subsection identity-tuple }
|
||||
"An object can be cloned; the clone has distinct identity but equal value:"
|
||||
{ $subsection clone } ;
|
||||
|
||||
ARTICLE: "dataflow" "Data and control flow"
|
||||
{ $subsection "evaluator" }
|
||||
{ $subsection "words" }
|
||||
{ $subsection "effects" }
|
||||
{ $subsection "booleans" }
|
||||
{ $subsection "shuffle-words" }
|
||||
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
|
||||
{ $subsection "cleave-combinators" }
|
||||
{ $subsection "spread-combinators" }
|
||||
{ $subsection "apply-combinators" }
|
||||
{ $subsection "slip-keep-combinators" }
|
||||
{ $subsection "conditionals" }
|
||||
{ $subsection "compositional-combinators" }
|
||||
{ $subsection "combinators" }
|
||||
"Advanced topics:"
|
||||
{ $subsection "implementing-combinators" }
|
||||
{ $subsection "errors" }
|
||||
{ $subsection "continuations" } ;
|
||||
|
||||
ABOUT: "dataflow"
|
||||
|
||||
|
|
|
|||
|
|
@ -2,64 +2,6 @@ USING: help.markup help.syntax kernel sequences quotations
|
|||
math.private ;
|
||||
IN: math
|
||||
|
||||
ARTICLE: "division-by-zero" "Division by zero"
|
||||
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
|
||||
$nl
|
||||
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
|
||||
$nl
|
||||
"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
|
||||
|
||||
ARTICLE: "number-protocol" "Number protocol"
|
||||
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
|
||||
$nl
|
||||
"Two examples where you should note the types of the inputs and outputs:"
|
||||
{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
|
||||
{ $example "1/2 2.0 + ." "4.5" }
|
||||
"The following usual operations are supported by all numbers."
|
||||
{ $subsection + }
|
||||
{ $subsection - }
|
||||
{ $subsection * }
|
||||
{ $subsection / }
|
||||
"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
|
||||
{ $subsection "division-by-zero" }
|
||||
"Real numbers (but not complex numbers) can be ordered:"
|
||||
{ $subsection < }
|
||||
{ $subsection <= }
|
||||
{ $subsection > }
|
||||
{ $subsection >= }
|
||||
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
|
||||
{ $subsection number= } ;
|
||||
|
||||
ARTICLE: "modular-arithmetic" "Modular arithmetic"
|
||||
{ $subsection mod }
|
||||
{ $subsection rem }
|
||||
{ $subsection /mod }
|
||||
{ $subsection /i }
|
||||
{ $see-also "integer-functions" } ;
|
||||
|
||||
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
|
||||
"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
|
||||
{ $subsection bitand }
|
||||
{ $subsection bitor }
|
||||
{ $subsection bitxor }
|
||||
{ $subsection bitnot }
|
||||
{ $subsection shift }
|
||||
{ $subsection 2/ }
|
||||
{ $subsection 2^ }
|
||||
{ $subsection bit? }
|
||||
{ $see-also "conditionals" } ;
|
||||
|
||||
ARTICLE: "arithmetic" "Arithmetic"
|
||||
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
|
||||
$nl
|
||||
"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
|
||||
{ $subsection "number-protocol" }
|
||||
{ $subsection "modular-arithmetic" }
|
||||
{ $subsection "bitwise-arithmetic" }
|
||||
{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
|
||||
|
||||
ABOUT: "arithmetic"
|
||||
|
||||
HELP: number=
|
||||
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
|
||||
{ $description "Tests if two numbers have the same numeric value." }
|
||||
|
|
@ -235,6 +177,9 @@ HELP: 1-
|
|||
{ $code "1-" "1 -" }
|
||||
} ;
|
||||
|
||||
HELP: ?1+
|
||||
{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
|
||||
|
||||
HELP: sq
|
||||
{ $values { "x" number } { "y" number } }
|
||||
{ $description "Multiplies a number by itself." } ;
|
||||
|
|
@ -357,3 +302,62 @@ HELP: find-last-integer
|
|||
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
|
||||
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
|
||||
{ $notes "This word is used to implement " { $link find-last } "." } ;
|
||||
|
||||
ARTICLE: "division-by-zero" "Division by zero"
|
||||
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
|
||||
$nl
|
||||
"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
|
||||
$nl
|
||||
"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
|
||||
|
||||
ARTICLE: "number-protocol" "Number protocol"
|
||||
"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
|
||||
$nl
|
||||
"Two examples where you should note the types of the inputs and outputs:"
|
||||
{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
|
||||
{ $example "1/2 2.0 + ." "4.5" }
|
||||
"The following usual operations are supported by all numbers."
|
||||
{ $subsection + }
|
||||
{ $subsection - }
|
||||
{ $subsection * }
|
||||
{ $subsection / }
|
||||
"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
|
||||
{ $subsection "division-by-zero" }
|
||||
"Real numbers (but not complex numbers) can be ordered:"
|
||||
{ $subsection < }
|
||||
{ $subsection <= }
|
||||
{ $subsection > }
|
||||
{ $subsection >= }
|
||||
"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
|
||||
{ $subsection number= } ;
|
||||
|
||||
ARTICLE: "modular-arithmetic" "Modular arithmetic"
|
||||
{ $subsection mod }
|
||||
{ $subsection rem }
|
||||
{ $subsection /mod }
|
||||
{ $subsection /i }
|
||||
{ $see-also "integer-functions" } ;
|
||||
|
||||
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
|
||||
"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
|
||||
{ $subsection bitand }
|
||||
{ $subsection bitor }
|
||||
{ $subsection bitxor }
|
||||
{ $subsection bitnot }
|
||||
{ $subsection shift }
|
||||
{ $subsection 2/ }
|
||||
{ $subsection 2^ }
|
||||
{ $subsection bit? }
|
||||
{ $see-also "conditionals" } ;
|
||||
|
||||
ARTICLE: "arithmetic" "Arithmetic"
|
||||
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
|
||||
$nl
|
||||
"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
|
||||
{ $subsection "number-protocol" }
|
||||
{ $subsection "modular-arithmetic" }
|
||||
{ $subsection "bitwise-arithmetic" }
|
||||
{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
|
||||
|
||||
ABOUT: "arithmetic"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,19 +1,7 @@
|
|||
USING: help.markup help.syntax debugger sequences kernel ;
|
||||
USING: help.markup help.syntax debugger sequences kernel
|
||||
quotations math ;
|
||||
IN: memory
|
||||
|
||||
ARTICLE: "images" "Images"
|
||||
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
|
||||
{ $subsection save }
|
||||
{ $subsection save-image }
|
||||
{ $subsection save-image-and-exit }
|
||||
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
|
||||
$nl
|
||||
"New images can be created from scratch:"
|
||||
{ $subsection "bootstrap.image" }
|
||||
{ $see-also "tools.memory" "tools.deploy" } ;
|
||||
|
||||
ABOUT: "images"
|
||||
|
||||
HELP: begin-scan ( -- )
|
||||
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
|
||||
$nl
|
||||
|
|
@ -67,3 +55,27 @@ HELP: save-image-and-exit ( path -- )
|
|||
|
||||
HELP: save
|
||||
{ $description "Saves a snapshot of the heap to the current image file." } ;
|
||||
|
||||
HELP: count-instances
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "n" integer } }
|
||||
{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
|
||||
{ $examples { $unchecked-example
|
||||
"USING: memory words prettyprint ;"
|
||||
"[ word? ] count-instances ."
|
||||
"24210"
|
||||
} } ;
|
||||
|
||||
ARTICLE: "images" "Images"
|
||||
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
|
||||
{ $subsection save }
|
||||
{ $subsection save-image }
|
||||
{ $subsection save-image-and-exit }
|
||||
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
|
||||
$nl
|
||||
"New images can be created from scratch:"
|
||||
{ $subsection "bootstrap.image" }
|
||||
{ $see-also "tools.memory" "tools.deploy" } ;
|
||||
|
||||
ABOUT: "images"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel help.markup help.syntax sequences ;
|
||||
USING: kernel help.markup help.syntax sequences quotations ;
|
||||
IN: sets
|
||||
|
||||
ARTICLE: "sets" "Set-theoretic operations on sequences"
|
||||
|
|
@ -111,3 +111,9 @@ HELP: subset?
|
|||
HELP: set=
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
|
||||
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
|
||||
|
||||
HELP: gather
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
{ "newseq" sequence } }
|
||||
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,223 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system ;
|
||||
USING: accessors assocs arrays generic kernel kernel.private
|
||||
math memory namespaces make sequences layouts system hashtables
|
||||
classes alien byte-arrays combinators words sets classes.algebra
|
||||
compiler.cfg.registers compiler.cfg.instructions ;
|
||||
IN: compiler.backend
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( size -- ? )
|
||||
! Labels
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
! Mapping from register class to machine registers
|
||||
HOOK: machine-registers cpu ( -- assoc )
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
SINGLETON: stack-params
|
||||
|
||||
! Return values of this class go here
|
||||
GENERIC: return-reg ( register-class -- reg )
|
||||
|
||||
! Sequence of registers used for parameter passing in class
|
||||
GENERIC: param-regs ( register-class -- regs )
|
||||
|
||||
GENERIC: param-reg ( n register-class -- reg )
|
||||
|
||||
M: object param-reg param-regs nth ;
|
||||
|
||||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj vreg -- )
|
||||
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
HOOK: stack-frame cpu ( frame-size -- n )
|
||||
|
||||
: stack-frame* ( -- n )
|
||||
\ stack-frame get stack-frame ;
|
||||
|
||||
! Set up caller stack frame
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
|
||||
! Tear down stack frame
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
! Call another word
|
||||
HOOK: %call cpu ( word -- )
|
||||
|
||||
! Local jump for branches
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-f cpu ( label vreg -- )
|
||||
|
||||
! Test if vreg is 't' or not
|
||||
HOOK: %jump-t cpu ( label vreg -- )
|
||||
|
||||
HOOK: %dispatch cpu ( -- )
|
||||
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
|
||||
! Return to caller
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
! Change datastack height
|
||||
HOOK: %inc-d cpu ( n -- )
|
||||
|
||||
! Change callstack height
|
||||
HOOK: %inc-r cpu ( n -- )
|
||||
|
||||
! Load stack into vreg
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
|
||||
! Store vreg to stack
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
|
||||
! Copy values between vregs
|
||||
HOOK: %copy cpu ( dst src -- )
|
||||
HOOK: %copy-float cpu ( dst src -- )
|
||||
|
||||
! Box and unbox floats
|
||||
HOOK: %unbox-float cpu ( dst src -- )
|
||||
HOOK: %box-float cpu ( dst src -- )
|
||||
|
||||
! FFI stuff
|
||||
|
||||
! Is this integer small enough to appear in value template
|
||||
! slots?
|
||||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
||||
|
||||
! Do we pass explode value structs?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
||||
! If t, fp parameters are shadowed by dummy int parameters
|
||||
HOOK: fp-shadows-int? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
|
||||
HOOK: %unbox cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %unbox-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %unbox-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %unbox-large-struct cpu ( n c-type -- )
|
||||
|
||||
HOOK: %box cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %box-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %prepare-box-struct cpu ( size -- )
|
||||
|
||||
HOOK: %box-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %box-large-struct cpu ( n c-type -- )
|
||||
|
||||
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
||||
|
||||
GENERIC: %load-param-reg ( stack reg reg-class -- )
|
||||
|
||||
HOOK: %prepare-alien-invoke cpu ( -- )
|
||||
|
||||
HOOK: %prepare-var-args cpu ( -- )
|
||||
|
||||
M: object %prepare-var-args ;
|
||||
|
||||
HOOK: %alien-invoke cpu ( function library -- )
|
||||
|
||||
HOOK: %cleanup cpu ( alien-node -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-value cpu ( ctype -- )
|
||||
|
||||
! Return to caller with stdcall unwinding (only for x86)
|
||||
HOOK: %unwind cpu ( n -- )
|
||||
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
M: stack-params param-reg drop ;
|
||||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
GENERIC: v>operand ( obj -- operand )
|
||||
|
||||
SYMBOL: registers
|
||||
|
||||
M: constant v>operand
|
||||
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
|
||||
M: value v>operand
|
||||
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
|
||||
|
||||
M: object load-literal v>operand load-indirect ;
|
||||
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
||||
PREDICATE: small-tagged < integer v>operand small-enough? ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
[ over not over struct-small-enough? and ] 2dip
|
||||
[ [ nip ] prepose ] dip if ;
|
||||
inline
|
||||
|
||||
: %unbox-struct ( n c-type -- )
|
||||
[
|
||||
%unbox-small-struct
|
||||
] [
|
||||
%unbox-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
: %box-struct ( n c-type -- )
|
||||
[
|
||||
%box-small-struct
|
||||
] [
|
||||
%box-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
! Alien accessors
|
||||
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-f cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
|
||||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
SYMBOL: operands
|
||||
|
||||
: init-intrinsic ( insn -- )
|
||||
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
|
||||
|
||||
: (operand) ( name -- operand )
|
||||
operands get at* [ "Bad operand name" throw ] unless ;
|
||||
|
||||
: operand ( name -- operand )
|
||||
(operand) v>operand ;
|
||||
|
||||
: operand-class ( var -- class )
|
||||
(operand) value-class ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
>r [ operand ] map prune r> each ; inline
|
||||
|
|
|
|||
|
|
@ -1,11 +1,318 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system cpu.x86.assembler compiler.cfg.registers
|
||||
compiler.backend ;
|
||||
USING: alien.c-types arrays kernel kernel.private math
|
||||
namespaces sequences stack-checker.known-words system layouts
|
||||
combinators command-line io vocabs.loader accessors init
|
||||
compiler compiler.units compiler.constants compiler.codegen
|
||||
compiler.cfg.builder compiler.alien compiler.codegen.fixup
|
||||
cpu.x86 compiler.backend compiler.backend.x86 ;
|
||||
IN: compiler.backend.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
! OS X requires that the stack be 16-byte aligned, and we do
|
||||
! this on all platforms, sacrificing some stack space for
|
||||
! code simplicity.
|
||||
|
||||
M: x86.32 machine-registers
|
||||
{
|
||||
{ int-regs { EAX ECX EDX EBP EBX } }
|
||||
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
|
||||
} ;
|
||||
|
||||
M: x86.32 ds-reg ESI ;
|
||||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 stack-save-reg EDX ;
|
||||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: int-regs push-return-reg return-reg PUSH ;
|
||||
: load/store-int-return ( n reg-class -- src dst )
|
||||
return-reg stack-reg rot [+] ;
|
||||
M: int-regs load-return-reg load/store-int-return MOV ;
|
||||
M: int-regs store-return-reg load/store-int-return swap MOV ;
|
||||
|
||||
M: float-regs param-regs drop { } ;
|
||||
|
||||
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
|
||||
|
||||
M: float-regs push-return-reg
|
||||
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
|
||||
|
||||
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
|
||||
|
||||
: load/store-float-return ( n reg-class -- op size )
|
||||
[ stack@ ] [ reg-size ] bi* ;
|
||||
M: float-regs load-return-reg load/store-float-return FLD ;
|
||||
M: float-regs store-return-reg load/store-float-return FSTP ;
|
||||
|
||||
: align-sub ( n -- )
|
||||
dup 16 align swap - ESP swap SUB ;
|
||||
|
||||
: align-add ( n -- )
|
||||
16 align ESP swap ADD ;
|
||||
|
||||
: with-aligned-stack ( n quot -- )
|
||||
swap dup align-sub slip align-add ; inline
|
||||
|
||||
M: x86.32 fixnum>slot@ 1 SHR ;
|
||||
|
||||
M: x86.32 prepare-division CDQ ;
|
||||
|
||||
M: x86.32 load-indirect
|
||||
0 [] MOV rc-absolute-cell rel-literal ;
|
||||
|
||||
M: object %load-param-reg 3drop ;
|
||||
|
||||
M: object %save-param-reg 3drop ;
|
||||
|
||||
: box@ ( n reg-class -- stack@ )
|
||||
#! Used for callbacks; we want to box the values given to
|
||||
#! us by the C function caller. Computes stack location of
|
||||
#! nth parameter; note that we must go back one more stack
|
||||
#! frame, since %box sets one up to call the one-arg boxer
|
||||
#! function. The size of this stack frame so far depends on
|
||||
#! the reg-class of the boxer's arg.
|
||||
reg-size neg + stack-frame* + 20 + ;
|
||||
|
||||
: (%box) ( n reg-class -- )
|
||||
#! If n is f, push the return register onto the stack; we
|
||||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
|
||||
push-return-reg ;
|
||||
|
||||
M: x86.32 %box ( n reg-class func -- )
|
||||
over reg-size [
|
||||
>r (%box) r> f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
#! If n is f, push the return registers onto the stack; we
|
||||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
|
||||
#! boxing a parameter being passed to a callback from C.
|
||||
[
|
||||
int-regs box@
|
||||
EDX over stack@ MOV
|
||||
EAX swap cell - stack@ MOV
|
||||
] when*
|
||||
EDX PUSH
|
||||
EAX PUSH ;
|
||||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
8 [
|
||||
[ (%box-long-long) ] [ f %alien-invoke ] bi*
|
||||
] with-aligned-stack ;
|
||||
|
||||
: struct-return@ ( size n -- n )
|
||||
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
heap-size
|
||||
[ swap struct-return@ ] keep
|
||||
ECX ESP roll [+] LEA
|
||||
8 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
EAX ESP rot f struct-return@ [+] LEA
|
||||
! Store it as the first parameter
|
||||
ESP [] EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
12 [
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
|
||||
: (%unbox) ( func -- )
|
||||
4 [
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %unbox ( n reg-class func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
#! If n is f, we're unboxing a return value about to be
|
||||
#! returned by the callback. Otherwise, we're unboxing
|
||||
#! a parameter to a C function about to be called.
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
||||
M: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size
|
||||
! Compute destination address
|
||||
ECX ESP roll [+] LEA
|
||||
12 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX load-indirect
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
EAX PUSH
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Place top of data stack in EAX
|
||||
EAX POP
|
||||
! Restore C stack
|
||||
ESP 12 ADD
|
||||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
M: x86.32 %cleanup ( alien-node -- )
|
||||
#! a) If we just called an stdcall function in Windows, it
|
||||
#! cleaned up the stack frame for us. But we don't want that
|
||||
#! so we 'undo' the cleanup since we do that in %epilogue.
|
||||
#! b) If we just called a function returning a struct, we
|
||||
#! have to fix ESP.
|
||||
{
|
||||
{
|
||||
[ dup abi>> "stdcall" = ]
|
||||
[ alien-stack-frame ESP swap SUB ]
|
||||
} {
|
||||
[ dup return>> large-struct? ]
|
||||
[ drop EAX PUSH ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %unwind ( n -- ) RET ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
] unless
|
||||
|
||||
: (sse2?) ( -- ? ) "Intrinsic" throw ;
|
||||
|
||||
<<
|
||||
|
||||
\ (sse2?) [
|
||||
{ EAX EBX ECX EDX } [ PUSH ] each
|
||||
EAX 1 MOV
|
||||
CPUID
|
||||
EDX 26 SHR
|
||||
EDX 1 AND
|
||||
{ EAX EBX ECX EDX } [ POP ] each
|
||||
JE
|
||||
] { } define-if-intrinsic
|
||||
|
||||
\ (sse2?) { } { object } define-primitive
|
||||
|
||||
>>
|
||||
|
||||
: sse2? ( -- ? ) (sse2?) ;
|
||||
|
||||
"-no-sse2" cli-args member? [
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
[ optimized-recompile-hook ] recompile-hook [
|
||||
[ sse2? ] compile-call
|
||||
] with-variable
|
||||
[
|
||||
" - yes" print
|
||||
"compiler.backend.x86.sse2" require
|
||||
[
|
||||
sse2? [
|
||||
"This image was built to use SSE2, which your CPU does not support." print
|
||||
"You will need to bootstrap Factor again." print
|
||||
flush
|
||||
1 exit
|
||||
] unless
|
||||
] "compiler.backend.x86" add-init-hook
|
||||
] [
|
||||
" - no" print
|
||||
] if
|
||||
] unless
|
||||
|
|
|
|||
|
|
@ -1,7 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system cpu.x86.assembler compiler.cfg.registers
|
||||
compiler.backend ;
|
||||
USING: accessors alien.c-types arrays kernel kernel.private math
|
||||
namespaces make sequences system layouts alien alien.accessors
|
||||
alien.structs slots splitting assocs combinators
|
||||
cpu.x86 compiler.codegen compiler.constants
|
||||
compiler.codegen.fixup compiler.cfg.registers compiler.backend
|
||||
compiler.backend.x86 compiler.backend.x86.sse2 ;
|
||||
IN: compiler.backend.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
|
|
@ -12,3 +16,211 @@ M: x86.64 machine-registers
|
|||
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
|
||||
} }
|
||||
} ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
M: x86.64 stack-save-reg RSI ;
|
||||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
|
||||
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 fixnum>slot@ drop ;
|
||||
|
||||
M: x86.64 prepare-division CQO ;
|
||||
|
||||
M: x86.64 load-indirect ( literal reg -- )
|
||||
0 [] MOV rc-relative rel-literal ;
|
||||
|
||||
M: stack-params %load-param-reg
|
||||
drop
|
||||
>r R11 swap stack@ MOV
|
||||
r> stack@ R11 MOV ;
|
||||
|
||||
M: stack-params %save-param-reg
|
||||
>r stack-frame* + cell + swap r> %load-param-reg ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
V{ RDX RAX } clone int-regs set
|
||||
V{ XMM1 XMM0 } clone float-regs set
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-small-struct ( c-type -- seq )
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member? "void*" "double" ? c-type
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
RDI R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
|
||||
M: x86.64 %unbox ( n reg-class func -- )
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
! Store the return value on the C stack
|
||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.64 %unbox-long-long ( n func -- )
|
||||
int-regs swap %unbox ;
|
||||
|
||||
: %unbox-struct-field ( c-type i -- )
|
||||
! Alien must be in RDI.
|
||||
RDI swap cells [+] swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Move alien_offset() return value to RDI so that we don't
|
||||
! clobber it.
|
||||
RDI RAX MOV
|
||||
[
|
||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in RDI
|
||||
heap-size
|
||||
! Load destination address
|
||||
RSI RSP roll [+] LEA
|
||||
! Load structure size
|
||||
RDX swap MOV
|
||||
! Copy the struct to the C stack
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
: load-return-value ( reg-class -- )
|
||||
0 over param-reg swap return-reg
|
||||
2dup eq? [ 2drop ] [ MOV ] if ;
|
||||
|
||||
M: x86.64 %box ( n reg-class func -- )
|
||||
rot [
|
||||
rot [ 0 swap param-reg ] keep %load-param-reg
|
||||
] [
|
||||
swap load-return-value
|
||||
] if*
|
||||
f %alien-invoke ;
|
||||
|
||||
M: x86.64 %box-long-long ( n func -- )
|
||||
int-regs swap %box ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
|
||||
|
||||
: %box-struct-field ( c-type i -- )
|
||||
box-struct-field@ swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop MOV ] }
|
||||
{ double-float-regs [ float-regs get pop MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
[
|
||||
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||
[ RDX swap heap-size MOV ] bi
|
||||
RDI 0 box-struct-field@ MOV
|
||||
RSI 1 box-struct-field@ MOV
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-return-regs ;
|
||||
|
||||
: struct-return@ ( size n -- n )
|
||||
[ ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
heap-size
|
||||
RSI over MOV
|
||||
! Compute destination address
|
||||
swap struct-return@ RDI RSP rot [+] LEA
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
RAX RSP rot f struct-return@ [+] LEA
|
||||
RSP 0 [+] RAX MOV ;
|
||||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-global
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ RAX MOV ;
|
||||
|
||||
M: x86.64 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
! Put former top of data stack in RDI
|
||||
cell temp@ RDI MOV
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Put former top of data stack in RDI
|
||||
RDI cell temp@ MOV
|
||||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: x86.64 %cleanup ( alien-node -- ) drop ;
|
||||
|
||||
M: x86.64 %unwind ( n -- ) drop 0 RET ;
|
||||
|
||||
USE: cpu.x86.intrinsics
|
||||
|
||||
! On 64-bit systems, the result of reading 4 bytes from memory
|
||||
! is a fixnum.
|
||||
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
|
||||
\ set-alien-unsigned-4 small-reg-32 define-setter
|
||||
|
||||
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||
\ set-alien-signed-4 small-reg-32 define-setter
|
||||
|
|
|
|||
|
|
@ -0,0 +1,110 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors arrays generic kernel system
|
||||
kernel.private math math.private memory namespaces sequences
|
||||
words math.floats.private layouts quotations cpu.x86
|
||||
compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
|
||||
compiler.constants compiler.backend compiler.backend.x86 ;
|
||||
IN: compiler.backend.x86.sse2
|
||||
|
||||
M: x86 %box-float ( dst src -- )
|
||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||
#! dest is a loc or a vreg
|
||||
float 16 [
|
||||
8 (object@) swap v>operand MOVSD
|
||||
float %store-tagged
|
||||
] %allot ;
|
||||
|
||||
M: x86 %unbox-float ( dst src -- )
|
||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
||||
|
||||
: define-float-op ( word op -- )
|
||||
[ "x" operand "y" operand ] swap suffix T{ template
|
||||
{ input { { float "x" } { float "y" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic ;
|
||||
|
||||
{
|
||||
{ float+ ADDSD }
|
||||
{ float- SUBSD }
|
||||
{ float* MULSD }
|
||||
{ float/f DIVSD }
|
||||
} [
|
||||
first2 define-float-op
|
||||
] each
|
||||
|
||||
: define-float-jump ( word op -- )
|
||||
[ "x" operand "y" operand UCOMISD ] swap suffix
|
||||
{ { float "x" } { float "y" } } define-if-intrinsic ;
|
||||
|
||||
{
|
||||
{ float< JAE }
|
||||
{ float<= JA }
|
||||
{ float> JBE }
|
||||
{ float>= JB }
|
||||
{ float= JNE }
|
||||
} [
|
||||
first2 define-float-jump
|
||||
] each
|
||||
|
||||
\ float>fixnum [
|
||||
"out" operand "in" operand CVTTSD2SI
|
||||
"out" operand tag-bits get SHL
|
||||
] T{ template
|
||||
{ input { { float "in" } } }
|
||||
{ scratch { { f "out" } } }
|
||||
{ output { "out" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ fixnum>float [
|
||||
"in" operand %untag-fixnum
|
||||
"out" operand "in" operand CVTSI2SD
|
||||
] T{ template
|
||||
{ input { { f "in" } } }
|
||||
{ scratch { { float "out" } } }
|
||||
{ output { "out" } }
|
||||
{ clobber { "in" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
: alien-float-get-template
|
||||
T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ scratch { { float "value" } } }
|
||||
{ output { "value" } }
|
||||
{ clobber { "offset" } }
|
||||
} ;
|
||||
|
||||
: alien-float-set-template
|
||||
T{ template
|
||||
{ input {
|
||||
{ float "value" float }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ clobber { "offset" } }
|
||||
} ;
|
||||
|
||||
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
|
||||
[ "value" operand swap %alien-accessor ] curry
|
||||
alien-float-set-template
|
||||
define-intrinsic
|
||||
[ "value" operand swap %alien-accessor ] curry
|
||||
alien-float-get-template
|
||||
define-intrinsic ;
|
||||
|
||||
\ alien-double
|
||||
[ MOVSD ]
|
||||
\ set-alien-double
|
||||
[ swap MOVSD ]
|
||||
define-alien-float-intrinsics
|
||||
|
||||
\ alien-float
|
||||
[ dupd MOVSS dup CVTSS2SD ]
|
||||
\ set-alien-float
|
||||
[ swap dup dup CVTSD2SS MOVSS ]
|
||||
define-alien-float-intrinsics
|
||||
|
|
@ -0,0 +1,755 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays alien.accessors
|
||||
compiler.backend kernel kernel.private math memory namespaces
|
||||
make sequences words system layouts combinators math.order
|
||||
math.private alien alien.c-types slots.private cpu.x86
|
||||
cpu.x86.private compiler.backend compiler.codegen.fixup
|
||||
compiler.constants compiler.intrinsics compiler.cfg.builder
|
||||
compiler.cfg.registers compiler.cfg.stacks
|
||||
compiler.cfg.templates ;
|
||||
IN: compiler.backend.x86
|
||||
|
||||
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: word JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: word CALL (CALL) rel-word ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: word JUMPcc (JUMPcc) rel-word ;
|
||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
||||
|
||||
HOOK: ds-reg cpu ( -- reg )
|
||||
HOOK: rs-reg cpu ( -- reg )
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
HOOK: stack-save-reg cpu ( -- reg )
|
||||
|
||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||
|
||||
M: ds-loc v>operand n>> ds-reg reg-stack ;
|
||||
M: rs-loc v>operand n>> rs-reg reg-stack ;
|
||||
|
||||
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||
|
||||
GENERIC: MOVSS/D ( dst src reg-class -- )
|
||||
|
||||
M: single-float-regs MOVSS/D drop MOVSS ;
|
||||
M: double-float-regs MOVSS/D drop MOVSD ;
|
||||
|
||||
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
|
||||
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
|
||||
|
||||
GENERIC: push-return-reg ( reg-class -- )
|
||||
GENERIC: load-return-reg ( stack@ reg-class -- )
|
||||
GENERIC: store-return-reg ( stack@ reg-class -- )
|
||||
|
||||
! Only used by inline allocation
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
HOOK: temp-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: fixnum>slot@ cpu ( op -- )
|
||||
|
||||
HOOK: prepare-division cpu ( -- )
|
||||
|
||||
M: f load-literal
|
||||
v>operand \ f tag-number MOV drop ;
|
||||
|
||||
M: fixnum load-literal
|
||||
v>operand swap tag-fixnum MOV ;
|
||||
|
||||
M: x86 stack-frame ( n -- i )
|
||||
3 cells + 16 align cell - ;
|
||||
|
||||
: factor-area-size ( -- n ) 4 cells ;
|
||||
|
||||
M: x86 %prologue ( n -- )
|
||||
temp-reg-1 0 MOV rc-absolute-cell rel-this
|
||||
dup cell + PUSH
|
||||
temp-reg-1 PUSH
|
||||
stack-reg swap 2 cells - SUB ;
|
||||
|
||||
M: x86 %epilogue ( n -- )
|
||||
stack-reg swap ADD ;
|
||||
|
||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||
|
||||
M: x86 %prepare-alien-invoke
|
||||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f temp-reg-1 %alien-global
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
temp-reg-1 3 cells [+] rs-reg MOV ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
|
||||
M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
|
||||
|
||||
M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
|
||||
|
||||
: code-alignment ( -- n )
|
||||
building get length dup cell align swap - ;
|
||||
|
||||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86 %dispatch ( -- )
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
temp-reg-1 fixnum>slot@
|
||||
! Add jump table base
|
||||
temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
temp-reg-1 temp-reg-2 ADD
|
||||
temp-reg-1 HEX: 7f [+] JMP
|
||||
! Fix up the displacement above
|
||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||
building get dup pop* push
|
||||
align-code ;
|
||||
|
||||
M: x86 %dispatch-label ( word -- )
|
||||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
M: x86 %peek [ v>operand ] bi@ MOV ;
|
||||
|
||||
M: x86 %replace swap %peek ;
|
||||
|
||||
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||
|
||||
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
|
||||
|
||||
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
||||
|
||||
M: x86 fp-shadows-int? ( -- ? ) f ;
|
||||
|
||||
M: x86 value-structs? t ;
|
||||
|
||||
M: x86 small-enough? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
||||
|
||||
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
|
||||
|
||||
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
|
||||
|
||||
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
|
||||
|
||||
M: x86 %return ( -- ) 0 %unwind ;
|
||||
|
||||
! Alien intrinsics
|
||||
M: x86 %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
||||
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||
|
||||
M: x86 %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
|
||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
! Address is computed in ds-reg
|
||||
ds-reg PUSH
|
||||
ds-reg 0 MOV
|
||||
! Object is stored in ds-reg
|
||||
rs-reg PUSH
|
||||
rs-reg swap v>operand MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
rs-reg \ f tag-number CMP
|
||||
"end" get JE
|
||||
! Is the object an alien?
|
||||
rs-reg header-offset [+] alien type-number tag-fixnum CMP
|
||||
"is-byte-array" get JNE
|
||||
! If so, load the offset and add it to the address
|
||||
ds-reg rs-reg alien-offset [+] ADD
|
||||
! Now recurse on the underlying alien
|
||||
rs-reg rs-reg underlying-alien-offset [+] MOV
|
||||
"start" get JMP
|
||||
"is-byte-array" resolve-label
|
||||
! Add byte array address to address being computed
|
||||
ds-reg rs-reg ADD
|
||||
! Add an offset to start of byte array's data
|
||||
ds-reg byte-array-offset ADD
|
||||
"end" resolve-label
|
||||
! Done, store address in destination register
|
||||
v>operand ds-reg MOV
|
||||
! Restore rs-reg
|
||||
rs-reg POP
|
||||
! Restore ds-reg
|
||||
ds-reg POP ;
|
||||
|
||||
: allot-reg ( -- reg )
|
||||
#! We temporarily use the datastack register, since it won't
|
||||
#! be accessed inside the quotation given to %allot in any
|
||||
#! case.
|
||||
ds-reg ;
|
||||
|
||||
: (object@) ( n -- operand ) allot-reg swap [+] ;
|
||||
|
||||
: object@ ( n -- operand ) cells (object@) ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
||||
: load-allot-ptr ( -- )
|
||||
allot-reg load-zone-ptr
|
||||
allot-reg PUSH
|
||||
allot-reg dup cell [+] MOV ;
|
||||
|
||||
: inc-allot-ptr ( n -- )
|
||||
allot-reg POP
|
||||
allot-reg cell [+] swap 8 align ADD ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
"end" define-label
|
||||
temp-reg-1 load-zone-ptr
|
||||
temp-reg-2 temp-reg-1 cell [+] MOV
|
||||
temp-reg-2 1024 ADD
|
||||
temp-reg-1 temp-reg-1 3 cells [+] MOV
|
||||
temp-reg-2 temp-reg-1 CMP
|
||||
"end" get JLE
|
||||
%prepare-alien-invoke
|
||||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
: store-header ( header -- )
|
||||
0 object@ swap type-number tag-fixnum MOV ;
|
||||
|
||||
: %allot ( header size quot -- )
|
||||
allot-reg PUSH
|
||||
swap >r >r
|
||||
load-allot-ptr
|
||||
store-header
|
||||
r> call
|
||||
r> inc-allot-ptr
|
||||
allot-reg POP ; inline
|
||||
|
||||
: fresh-object drop ;
|
||||
|
||||
: %store-tagged ( reg tag -- )
|
||||
>r dup fresh-object v>operand r>
|
||||
allot-reg swap tag-number OR
|
||||
allot-reg MOV ;
|
||||
|
||||
: %allot-bignum-signed-1 ( outreg inreg -- )
|
||||
#! on entry, inreg is a signed 32-bit quantity
|
||||
#! exits with tagged ptr to bignum in outreg
|
||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||
#! length is the # of digits + sign
|
||||
[
|
||||
{ "end" "nonzero" "positive" "store" }
|
||||
[ define-label ] each
|
||||
dup v>operand 0 CMP ! is it zero?
|
||||
"nonzero" get JNE
|
||||
0 >bignum pick v>operand load-indirect ! this is our result
|
||||
"end" get JMP
|
||||
"nonzero" resolve-label
|
||||
bignum 4 cells [
|
||||
! Write length
|
||||
1 object@ 2 v>operand MOV
|
||||
! Test sign
|
||||
dup v>operand 0 CMP
|
||||
"positive" get JGE
|
||||
2 object@ 1 MOV ! negative sign
|
||||
dup v>operand NEG
|
||||
"store" get JMP
|
||||
"positive" resolve-label
|
||||
2 object@ 0 MOV ! positive sign
|
||||
"store" resolve-label
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in reg
|
||||
bignum %store-tagged
|
||||
] %allot
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: x86 %box-alien ( dst src -- )
|
||||
[
|
||||
{ "end" "f" } [ define-label ] each
|
||||
dup v>operand 0 CMP
|
||||
"f" get JE
|
||||
alien 4 cells [
|
||||
1 object@ \ f tag-number MOV
|
||||
2 object@ \ f tag-number MOV
|
||||
! Store src in alien-offset slot
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in dst
|
||||
dup object %store-tagged
|
||||
] %allot
|
||||
"end" get JMP
|
||||
"f" resolve-label
|
||||
f [ v>operand ] bi@ MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
! Type checks
|
||||
\ tag [
|
||||
"in" operand tag-mask get AND
|
||||
"in" operand %tag-fixnum
|
||||
] T{ template
|
||||
{ input { { f "in" } } }
|
||||
{ output { "in" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Slots
|
||||
: %slot-literal-known-tag ( -- op )
|
||||
"obj" operand
|
||||
"n" get cells
|
||||
"obj" operand-tag - [+] ;
|
||||
|
||||
: %slot-literal-any-tag ( -- op )
|
||||
"obj" operand %untag
|
||||
"obj" operand "n" get cells [+] ;
|
||||
|
||||
: %slot-any ( -- op )
|
||||
"obj" operand %untag
|
||||
"n" operand fixnum>slot@
|
||||
"obj" operand "n" operand [+] ;
|
||||
|
||||
\ slot {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ "val" operand %slot-literal-known-tag MOV ] T{ template
|
||||
{ input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
{ scratch { { f "val" } } }
|
||||
{ output { "val" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
||||
{ input { { f "obj" } { [ small-slot? ] "n" } } }
|
||||
{ output { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ "obj" operand %slot-any MOV ] T{ template
|
||||
{ input { { f "obj" } { f "n" } } }
|
||||
{ output { "obj" } }
|
||||
{ clobber { "n" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
||||
: generate-write-barrier ( -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
"val" operand-immediate? "obj" fresh-object? or [
|
||||
! Mark the card
|
||||
"obj" operand card-bits SHR
|
||||
"cards_offset" f "scratch" operand %alien-global
|
||||
"scratch" operand "obj" operand [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
"obj" operand deck-bits card-bits - SHR
|
||||
"decks_offset" f "scratch" operand %alien-global
|
||||
"scratch" operand "obj" operand [+] card-mark <byte> MOV
|
||||
] unless ;
|
||||
|
||||
\ set-slot {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
|
||||
{ input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ %slot-any "val" operand MOV generate-write-barrier ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { f "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" "n" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
||||
! Sometimes, we need to do stuff with operands which are
|
||||
! less than the word size. Instead of teaching the register
|
||||
! allocator about the different sized registers, with all
|
||||
! the complexity this entails, we just push/pop a register
|
||||
! which is guaranteed to be unused (the tempreg)
|
||||
: small-reg cell 8 = RBX EBX ? ; inline
|
||||
: small-reg-8 BL ; inline
|
||||
: small-reg-16 BX ; inline
|
||||
: small-reg-32 EBX ; inline
|
||||
|
||||
! Fixnums
|
||||
: fixnum-op ( op hash -- pair )
|
||||
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
|
||||
|
||||
: fixnum-value-op ( op -- pair )
|
||||
T{ template
|
||||
{ input { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ output { "x" } }
|
||||
} fixnum-op ;
|
||||
|
||||
: fixnum-register-op ( op -- pair )
|
||||
T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ output { "x" } }
|
||||
} fixnum-op ;
|
||||
|
||||
: define-fixnum-op ( word op -- )
|
||||
[ fixnum-value-op ] keep fixnum-register-op
|
||||
2array define-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum+fast ADD }
|
||||
{ fixnum-fast SUB }
|
||||
{ fixnum-bitand AND }
|
||||
{ fixnum-bitor OR }
|
||||
{ fixnum-bitxor XOR }
|
||||
} [
|
||||
first2 define-fixnum-op
|
||||
] each
|
||||
|
||||
\ fixnum-bitnot [
|
||||
"x" operand NOT
|
||||
"x" operand tag-mask get XOR
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ output { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ fixnum*fast {
|
||||
{
|
||||
[
|
||||
"x" operand "y" get IMUL2
|
||||
] T{ template
|
||||
{ input { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ output { "x" } }
|
||||
}
|
||||
} {
|
||||
[
|
||||
"out" operand "x" operand MOV
|
||||
"out" operand %untag-fixnum
|
||||
"y" operand "out" operand IMUL2
|
||||
] T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ scratch { { f "out" } } }
|
||||
{ output { "out" } }
|
||||
}
|
||||
}
|
||||
} define-intrinsics
|
||||
|
||||
: %untag-fixnums ( seq -- )
|
||||
[ %untag-fixnum ] unique-operands ;
|
||||
|
||||
\ fixnum-shift-fast [
|
||||
"x" operand "y" get
|
||||
dup 0 < [ neg SAR ] [ SHL ] if
|
||||
! Mask off low bits
|
||||
"x" operand %untag
|
||||
] T{ template
|
||||
{ input { { f "x" } { [ ] "y" } } }
|
||||
{ output { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
: overflow-check ( word -- )
|
||||
"end" define-label
|
||||
"z" operand "x" operand MOV
|
||||
"z" operand "y" operand pick execute
|
||||
! If the previous arithmetic operation overflowed, then we
|
||||
! turn the result into a bignum and leave it in EAX.
|
||||
"end" get JNO
|
||||
! There was an overflow. Recompute the original operand.
|
||||
{ "y" "x" } %untag-fixnums
|
||||
"x" operand "y" operand rot execute
|
||||
"z" get "x" get %allot-bignum-signed-1
|
||||
"end" resolve-label ; inline
|
||||
|
||||
: overflow-template ( word insn -- )
|
||||
[ overflow-check ] curry T{ template
|
||||
{ input { { f "x" } { f "y" } } }
|
||||
{ scratch { { f "z" } } }
|
||||
{ output { "z" } }
|
||||
{ clobber { "x" "y" } }
|
||||
{ gc t }
|
||||
} define-intrinsic ;
|
||||
|
||||
\ fixnum+ \ ADD overflow-template
|
||||
\ fixnum- \ SUB overflow-template
|
||||
|
||||
: fixnum-jump ( op inputs -- pair )
|
||||
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
|
||||
|
||||
: fixnum-value-jump ( op -- pair )
|
||||
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
|
||||
|
||||
: fixnum-register-jump ( op -- pair )
|
||||
{ { f "x" } { f "y" } } fixnum-jump ;
|
||||
|
||||
: define-fixnum-jump ( word op -- )
|
||||
[ fixnum-value-jump ] keep fixnum-register-jump
|
||||
2array define-if-intrinsics ;
|
||||
|
||||
{
|
||||
{ fixnum< JL }
|
||||
{ fixnum<= JLE }
|
||||
{ fixnum> JG }
|
||||
{ fixnum>= JGE }
|
||||
{ eq? JE }
|
||||
} [
|
||||
first2 define-fixnum-jump
|
||||
] each
|
||||
|
||||
\ fixnum>bignum [
|
||||
"x" operand %untag-fixnum
|
||||
"x" get dup %allot-bignum-signed-1
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ bignum>fixnum [
|
||||
"nonzero" define-label
|
||||
"positive" define-label
|
||||
"end" define-label
|
||||
"x" operand %untag
|
||||
"y" operand "x" operand cell [+] MOV
|
||||
! if the length is 1, its just the sign and nothing else,
|
||||
! so output 0
|
||||
"y" operand 1 v>operand CMP
|
||||
"nonzero" get JNE
|
||||
"y" operand 0 MOV
|
||||
"end" get JMP
|
||||
"nonzero" resolve-label
|
||||
! load the value
|
||||
"y" operand "x" operand 3 cells [+] MOV
|
||||
! load the sign
|
||||
"x" operand "x" operand 2 cells [+] MOV
|
||||
! is the sign negative?
|
||||
"x" operand 0 CMP
|
||||
"positive" get JE
|
||||
"y" operand -1 IMUL2
|
||||
"positive" resolve-label
|
||||
"y" operand 3 SHL
|
||||
"end" resolve-label
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ scratch { { f "y" } } }
|
||||
{ clobber { "x" } }
|
||||
{ output { "y" } }
|
||||
} define-intrinsic
|
||||
|
||||
! User environment
|
||||
: %userenv ( -- )
|
||||
"x" operand 0 MOV
|
||||
"userenv" f rc-absolute-cell rel-dlsym
|
||||
"n" operand fixnum>slot@
|
||||
"n" operand "x" operand ADD ;
|
||||
|
||||
\ getenv [
|
||||
%userenv "n" operand dup [] MOV
|
||||
] T{ template
|
||||
{ input { { f "n" } } }
|
||||
{ scratch { { f "x" } } }
|
||||
{ output { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ setenv [
|
||||
%userenv "n" operand [] "val" operand MOV
|
||||
] T{ template
|
||||
{ input { { f "val" } { f "n" } } }
|
||||
{ scratch { { f "x" } } }
|
||||
{ clobber { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" operand load-indirect
|
||||
1 object@ "scratch" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "layout" } } }
|
||||
{ scratch { { f "tuple" } { f "scratch" } } }
|
||||
{ output { "tuple" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "n" } } }
|
||||
{ scratch { { f "array" } } }
|
||||
{ output { "array" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "n" } } }
|
||||
{ scratch { { f "array" } } }
|
||||
{ output { "array" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells [
|
||||
1 object@ "numerator" operand MOV
|
||||
2 object@ "denominator" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"ratio" get ratio %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "numerator" } { f "denominator" } } }
|
||||
{ scratch { { f "ratio" } } }
|
||||
{ output { "ratio" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <complex> [
|
||||
complex 3 cells [
|
||||
1 object@ "real" operand MOV
|
||||
2 object@ "imaginary" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"complex" get complex %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "real" } { f "imaginary" } } }
|
||||
{ scratch { { f "complex" } } }
|
||||
{ output { "complex" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <wrapper> [
|
||||
wrapper 2 cells [
|
||||
1 object@ "obj" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"wrapper" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "obj" } } }
|
||||
{ scratch { { f "wrapper" } } }
|
||||
{ output { "wrapper" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand %untag-fixnum
|
||||
"offset" operand "alien" operand ADD
|
||||
"offset" operand [] swap call ; inline
|
||||
|
||||
: %alien-integer-get ( quot reg -- )
|
||||
small-reg PUSH
|
||||
swap %alien-accessor
|
||||
"value" operand small-reg MOV
|
||||
"value" operand %tag-fixnum
|
||||
small-reg POP ; inline
|
||||
|
||||
: alien-integer-get-template
|
||||
T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ scratch { { f "value" } } }
|
||||
{ output { "value" } }
|
||||
{ clobber { "offset" } }
|
||||
} ;
|
||||
|
||||
: define-getter ( word quot reg -- )
|
||||
[ %alien-integer-get ] 2curry
|
||||
alien-integer-get-template
|
||||
define-intrinsic ;
|
||||
|
||||
: define-unsigned-getter ( word reg -- )
|
||||
[ small-reg dup XOR MOV ] swap define-getter ;
|
||||
|
||||
: define-signed-getter ( word reg -- )
|
||||
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
|
||||
|
||||
: %alien-integer-set ( quot reg -- )
|
||||
small-reg PUSH
|
||||
small-reg "value" operand MOV
|
||||
small-reg %untag-fixnum
|
||||
swap %alien-accessor
|
||||
small-reg POP ; inline
|
||||
|
||||
: alien-integer-set-template
|
||||
T{ template
|
||||
{ input {
|
||||
{ f "value" fixnum }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ clobber { "value" "offset" } }
|
||||
} ;
|
||||
|
||||
: define-setter ( word reg -- )
|
||||
[ swap MOV ] swap
|
||||
[ %alien-integer-set ] 2curry
|
||||
alien-integer-set-template
|
||||
define-intrinsic ;
|
||||
|
||||
\ alien-unsigned-1 small-reg-8 define-unsigned-getter
|
||||
\ set-alien-unsigned-1 small-reg-8 define-setter
|
||||
|
||||
\ alien-signed-1 small-reg-8 define-signed-getter
|
||||
\ set-alien-signed-1 small-reg-8 define-setter
|
||||
|
||||
\ alien-unsigned-2 small-reg-16 define-unsigned-getter
|
||||
\ set-alien-unsigned-2 small-reg-16 define-setter
|
||||
|
||||
\ alien-signed-2 small-reg-16 define-signed-getter
|
||||
\ set-alien-signed-2 small-reg-16 define-setter
|
||||
|
||||
\ alien-cell [
|
||||
"value" operand [ MOV ] %alien-accessor
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ scratch { { unboxed-alien "value" } } }
|
||||
{ output { "value" } }
|
||||
{ clobber { "offset" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ set-alien-cell [
|
||||
"value" operand [ swap MOV ] %alien-accessor
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ clobber { "offset" } }
|
||||
} define-intrinsic
|
||||
|
|
@ -32,18 +32,9 @@ IN: compiler.cfg.builder
|
|||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
USE: qualified
|
||||
FROM: compiler.generator.registers => +input+ ;
|
||||
FROM: compiler.generator.registers => +output+ ;
|
||||
FROM: compiler.generator.registers => +scratch+ ;
|
||||
FROM: compiler.generator.registers => +clobber+ ;
|
||||
|
||||
SYMBOL: procedures
|
||||
|
||||
SYMBOL: current-word
|
||||
|
||||
SYMBOL: current-label
|
||||
|
||||
SYMBOL: loops
|
||||
|
||||
! Basic block after prologue, makes recursion faster
|
||||
|
|
@ -81,8 +72,8 @@ GENERIC: emit-node ( node -- next )
|
|||
#! labelled by the current word, so that self-recursive
|
||||
#! calls can skip an epilogue/prologue.
|
||||
init-phantoms
|
||||
%prologue
|
||||
%branch
|
||||
##prologue
|
||||
##branch
|
||||
begin-basic-block
|
||||
current-label get remember-loop ;
|
||||
|
||||
|
|
@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
|
|||
[ emit-nodes ] with-node-iterator
|
||||
] with-cfg-builder ;
|
||||
|
||||
: build-cfg ( nodes word label -- procedures )
|
||||
: build-cfg ( nodes word -- procedures )
|
||||
V{ } clone [
|
||||
procedures [
|
||||
(build-cfg)
|
||||
dup (build-cfg)
|
||||
] with-variable
|
||||
] keep ;
|
||||
|
||||
SYMBOL: +intrinsics+
|
||||
SYMBOL: +if-intrinsics+
|
||||
|
||||
: if-intrinsics ( #call -- quot )
|
||||
word>> "if-intrinsics" word-prop ;
|
||||
word>> +if-intrinsics+ word-prop ;
|
||||
|
||||
: local-recursive-call ( basic-block -- next )
|
||||
%branch
|
||||
##branch
|
||||
basic-block get successors>> push
|
||||
stop-iterating ;
|
||||
|
||||
: emit-call ( word -- next )
|
||||
finalize-phantoms
|
||||
{
|
||||
{ [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
|
||||
{ [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
|
||||
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
|
||||
[ %epilogue %jump stop-iterating ]
|
||||
[ ##epilogue ##jump stop-iterating ]
|
||||
} cond ;
|
||||
|
||||
! #recursive
|
||||
|
|
@ -130,50 +124,52 @@ M: #recursive emit-node
|
|||
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
|
||||
|
||||
! #if
|
||||
: emit-branch ( nodes -- final-bb )
|
||||
[
|
||||
: emit-branch ( obj quot -- final-bb )
|
||||
'[
|
||||
begin-basic-block copy-phantoms
|
||||
emit-nodes
|
||||
basic-block get dup [ %branch ] when
|
||||
@
|
||||
basic-block get dup [ ##branch ] when
|
||||
] with-scope ;
|
||||
|
||||
: emit-if ( node -- next )
|
||||
children>> [ emit-branch ] map
|
||||
: emit-branches ( seq quot -- )
|
||||
'[ _ emit-branch ] map
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each
|
||||
init-phantoms
|
||||
iterate-next ;
|
||||
init-phantoms ;
|
||||
|
||||
: emit-if ( node -- next )
|
||||
children>> [ emit-nodes ] emit-branches ;
|
||||
|
||||
M: #if emit-node
|
||||
{ { f "flag" } } lazy-load first %branch-t
|
||||
emit-if ;
|
||||
{ { f "flag" } } lazy-load first ##branch-t
|
||||
emit-if iterate-next ;
|
||||
|
||||
! #dispatch
|
||||
: dispatch-branch ( nodes word -- label )
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after ##dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
gensym [
|
||||
[
|
||||
copy-phantoms
|
||||
%prologue
|
||||
##prologue
|
||||
[ emit-nodes ] with-node-iterator
|
||||
%epilogue
|
||||
%return
|
||||
##epilogue
|
||||
##return
|
||||
] with-cfg-builder
|
||||
] keep ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
children>> [
|
||||
current-word get dispatch-branch
|
||||
%dispatch-label
|
||||
##dispatch-label
|
||||
] each ;
|
||||
|
||||
: emit-dispatch ( node -- )
|
||||
%dispatch dispatch-branches init-phantoms ;
|
||||
##epilogue ##dispatch dispatch-branches init-phantoms ;
|
||||
|
||||
M: #dispatch emit-node
|
||||
#! The order here is important, dispatch-branches must
|
||||
#! run after %dispatch, so that each branch gets the
|
||||
#! correct register state
|
||||
tail-call? [
|
||||
emit-dispatch iterate-next
|
||||
] [
|
||||
|
|
@ -187,23 +183,23 @@ M: #dispatch emit-node
|
|||
|
||||
! #call
|
||||
: define-intrinsics ( word intrinsics -- )
|
||||
"intrinsics" set-word-prop ;
|
||||
+intrinsics+ set-word-prop ;
|
||||
|
||||
: define-intrinsic ( word quot assoc -- )
|
||||
2array 1array define-intrinsics ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
[ +input+ associate ] assoc-map
|
||||
"if-intrinsics" set-word-prop ;
|
||||
[ template new swap >>input ] assoc-map
|
||||
+if-intrinsics+ set-word-prop ;
|
||||
|
||||
: define-if-intrinsic ( word quot inputs -- )
|
||||
2array 1array define-if-intrinsics ;
|
||||
|
||||
: find-intrinsic ( #call -- pair/f )
|
||||
word>> "intrinsics" word-prop find-template ;
|
||||
word>> +intrinsics+ word-prop find-template ;
|
||||
|
||||
: find-boolean-intrinsic ( #call -- pair/f )
|
||||
word>> "if-intrinsics" word-prop find-template ;
|
||||
word>> +if-intrinsics+ word-prop find-template ;
|
||||
|
||||
: find-if-intrinsic ( #call -- pair/f )
|
||||
node@ {
|
||||
|
|
@ -213,21 +209,24 @@ M: #dispatch emit-node
|
|||
} cond ;
|
||||
|
||||
: do-if-intrinsic ( pair -- next )
|
||||
[ %if-intrinsic ] apply-template skip-next emit-if ;
|
||||
[ ##if-intrinsic ] apply-template skip-next emit-if
|
||||
iterate-next ;
|
||||
|
||||
: do-boolean-intrinsic ( pair -- next )
|
||||
[
|
||||
f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
|
||||
] apply-template iterate-next ;
|
||||
[ ##if-intrinsic ] apply-template
|
||||
{ t f } [
|
||||
<constant> phantom-push finalize-phantoms
|
||||
] emit-branches
|
||||
iterate-next ;
|
||||
|
||||
: do-intrinsic ( pair -- next )
|
||||
[ %intrinsic ] apply-template iterate-next ;
|
||||
[ ##intrinsic ] apply-template iterate-next ;
|
||||
|
||||
: setup-operand-classes ( #call -- )
|
||||
node-input-infos [ class>> ] map set-operand-classes ;
|
||||
: setup-value-classes ( #call -- )
|
||||
node-input-infos [ class>> ] map set-value-classes ;
|
||||
|
||||
M: #call emit-node
|
||||
dup setup-operand-classes
|
||||
dup setup-value-classes
|
||||
dup find-if-intrinsic [ do-if-intrinsic ] [
|
||||
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
|
||||
dup find-intrinsic [ do-intrinsic ] [
|
||||
|
|
@ -259,12 +258,12 @@ M: #r> emit-node
|
|||
|
||||
! #return
|
||||
M: #return emit-node
|
||||
drop finalize-phantoms %epilogue %return f ;
|
||||
drop finalize-phantoms ##epilogue ##return f ;
|
||||
|
||||
M: #return-recursive emit-node
|
||||
finalize-phantoms
|
||||
label>> id>> loops get key?
|
||||
[ %epilogue %return ] unless f ;
|
||||
[ ##epilogue ##return ] unless f ;
|
||||
|
||||
! #terminate
|
||||
M: #terminate emit-node drop stop-iterating ;
|
||||
|
|
@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
|
|||
! FFI
|
||||
M: #alien-invoke emit-node
|
||||
params>>
|
||||
[ alien-invoke-frame %frame-required ]
|
||||
[ %alien-invoke iterate-next ]
|
||||
[ alien-invoke-frame ##frame-required ]
|
||||
[ ##alien-invoke iterate-next ]
|
||||
bi ;
|
||||
|
||||
M: #alien-indirect emit-node
|
||||
params>>
|
||||
[ alien-invoke-frame %frame-required ]
|
||||
[ %alien-indirect iterate-next ]
|
||||
[ alien-invoke-frame ##frame-required ]
|
||||
[ ##alien-indirect iterate-next ]
|
||||
bi ;
|
||||
|
||||
M: #alien-callback emit-node
|
||||
params>> dup xt>> dup
|
||||
[ init-phantoms %alien-callback ] with-cfg-builder
|
||||
[ init-phantoms ##alien-callback ] with-cfg-builder
|
||||
iterate-next ;
|
||||
|
||||
! No-op nodes
|
||||
|
|
|
|||
|
|
@ -11,16 +11,13 @@ C: <cfg> cfg
|
|||
TUPLE: basic-block < identity-tuple
|
||||
visited
|
||||
number
|
||||
label
|
||||
instructions
|
||||
successors
|
||||
predecessors ;
|
||||
successors ;
|
||||
|
||||
: <basic-block> ( -- basic-block )
|
||||
basic-block new
|
||||
V{ } clone >>instructions
|
||||
V{ } clone >>successors
|
||||
V{ } clone >>predecessors ;
|
||||
V{ } clone >>successors ;
|
||||
|
||||
TUPLE: mr instructions word label ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,11 +9,10 @@ IN: compiler.cfg.debugger
|
|||
GENERIC: test-cfg ( quot -- cfgs )
|
||||
|
||||
M: callable test-cfg
|
||||
build-tree optimize-tree gensym gensym build-cfg ;
|
||||
build-tree optimize-tree gensym build-cfg ;
|
||||
|
||||
M: word test-cfg
|
||||
[ build-tree-from-word nip optimize-tree ] keep dup
|
||||
build-cfg ;
|
||||
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
|
||||
|
||||
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,103 +6,102 @@ IN: compiler.cfg.instructions
|
|||
|
||||
! Virtual CPU instructions, used by CFG and machine IRs
|
||||
|
||||
TUPLE: %cond-branch < insn src ;
|
||||
TUPLE: %unary < insn dst src ;
|
||||
TUPLE: %nullary < insn dst ;
|
||||
TUPLE: ##cond-branch < insn src ;
|
||||
TUPLE: ##unary < insn dst src ;
|
||||
TUPLE: ##nullary < insn dst ;
|
||||
|
||||
! Stack operations
|
||||
INSN: %load-literal < %nullary obj ;
|
||||
INSN: %peek < %nullary loc ;
|
||||
INSN: %replace src loc ;
|
||||
INSN: %inc-d n ;
|
||||
INSN: %inc-r n ;
|
||||
INSN: ##load-literal < ##nullary obj ;
|
||||
INSN: ##peek < ##nullary loc ;
|
||||
INSN: ##replace src loc ;
|
||||
INSN: ##inc-d n ;
|
||||
INSN: ##inc-r n ;
|
||||
|
||||
! Calling convention
|
||||
INSN: %return ;
|
||||
INSN: ##return ;
|
||||
|
||||
! Subroutine calls
|
||||
INSN: %call word ;
|
||||
INSN: %jump word ;
|
||||
INSN: %intrinsic quot regs ;
|
||||
INSN: ##call word ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##intrinsic quot defs-vregs uses-vregs ;
|
||||
|
||||
! Jump tables
|
||||
INSN: %dispatch-label label ;
|
||||
INSN: %dispatch ;
|
||||
INSN: ##dispatch-label label ;
|
||||
INSN: ##dispatch ;
|
||||
|
||||
! Boxing and unboxing
|
||||
INSN: %copy < %unary ;
|
||||
INSN: %copy-float < %unary ;
|
||||
INSN: %unbox-float < %unary ;
|
||||
INSN: %unbox-f < %unary ;
|
||||
INSN: %unbox-alien < %unary ;
|
||||
INSN: %unbox-byte-array < %unary ;
|
||||
INSN: %unbox-any-c-ptr < %unary ;
|
||||
INSN: %box-float < %unary ;
|
||||
INSN: %box-alien < %unary ;
|
||||
INSN: ##copy < ##unary ;
|
||||
INSN: ##copy-float < ##unary ;
|
||||
INSN: ##unbox-float < ##unary ;
|
||||
INSN: ##unbox-f < ##unary ;
|
||||
INSN: ##unbox-alien < ##unary ;
|
||||
INSN: ##unbox-byte-array < ##unary ;
|
||||
INSN: ##unbox-any-c-ptr < ##unary ;
|
||||
INSN: ##box-float < ##unary ;
|
||||
INSN: ##box-alien < ##unary ;
|
||||
|
||||
INSN: %gc ;
|
||||
INSN: ##gc ;
|
||||
|
||||
! FFI
|
||||
INSN: %alien-invoke params ;
|
||||
INSN: %alien-indirect params ;
|
||||
INSN: %alien-callback params ;
|
||||
INSN: ##alien-invoke params ;
|
||||
INSN: ##alien-indirect params ;
|
||||
INSN: ##alien-callback params ;
|
||||
|
||||
GENERIC: defs-vregs ( insn -- seq )
|
||||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
M: %nullary defs-vregs dst>> >vreg 1array ;
|
||||
M: %unary defs-vregs dst>> >vreg 1array ;
|
||||
M: ##nullary defs-vregs dst>> >vreg 1array ;
|
||||
M: ##unary defs-vregs dst>> >vreg 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: %replace uses-vregs src>> >vreg 1array ;
|
||||
M: %unary uses-vregs src>> >vreg 1array ;
|
||||
M: ##replace uses-vregs src>> >vreg 1array ;
|
||||
M: ##unary uses-vregs src>> >vreg 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
||||
! M: %intrinsic uses-vregs vregs>> values ;
|
||||
: intrinsic-vregs ( assoc -- seq' )
|
||||
[ nip >vreg ] { } assoc>map sift ;
|
||||
|
||||
: intrinsic-defs-vregs ( insn -- seq )
|
||||
defs-vregs>> intrinsic-vregs ;
|
||||
|
||||
: intrinsic-uses-vregs ( insn -- seq )
|
||||
uses-vregs>> intrinsic-vregs ;
|
||||
|
||||
M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
|
||||
! Instructions used by CFG IR only.
|
||||
INSN: %prologue ;
|
||||
INSN: %epilogue ;
|
||||
INSN: %frame-required n ;
|
||||
INSN: ##prologue ;
|
||||
INSN: ##epilogue ;
|
||||
INSN: ##frame-required n ;
|
||||
|
||||
INSN: %branch ;
|
||||
INSN: %branch-f < %cond-branch ;
|
||||
INSN: %branch-t < %cond-branch ;
|
||||
INSN: %if-intrinsic quot vregs ;
|
||||
INSN: %boolean-intrinsic quot vregs dst ;
|
||||
INSN: ##branch ;
|
||||
INSN: ##branch-f < ##cond-branch ;
|
||||
INSN: ##branch-t < ##cond-branch ;
|
||||
INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
|
||||
|
||||
M: %cond-branch uses-vregs src>> 1array ;
|
||||
M: ##cond-branch uses-vregs src>> >vreg 1array ;
|
||||
|
||||
! M: %if-intrinsic uses-vregs vregs>> values ;
|
||||
|
||||
M: %boolean-intrinsic defs-vregs dst>> 1array ;
|
||||
|
||||
! M: %boolean-intrinsic uses-vregs
|
||||
! [ vregs>> values ] [ out>> ] bi suffix ;
|
||||
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _prologue n ;
|
||||
INSN: _epilogue n ;
|
||||
|
||||
TUPLE: label id ;
|
||||
|
||||
INSN: _label label ;
|
||||
|
||||
: <label> ( -- label ) \ <label> counter label boa ;
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: resolve-label ( label/name -- )
|
||||
dup label? [ get ] unless _label ;
|
||||
INSN: _label id ;
|
||||
|
||||
TUPLE: _cond-branch < insn src label ;
|
||||
|
||||
INSN: _branch label ;
|
||||
INSN: _branch-f < _cond-branch ;
|
||||
INSN: _branch-t < _cond-branch ;
|
||||
INSN: _if-intrinsic label quot vregs ;
|
||||
INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
|
||||
|
||||
M: _cond-branch uses-vregs src>> >vreg 1array ;
|
||||
! M: _if-intrinsic uses-vregs vregs>> values ;
|
||||
|
||||
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||
|
||||
INSN: _spill src n ;
|
||||
INSN: _reload dst n ;
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ USING: tools.test random sorting sequences sets hashtables assocs
|
|||
kernel fry arrays splitting namespaces math accessors vectors
|
||||
math.order
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.linear-scan
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.debugger ;
|
||||
|
||||
|
|
@ -98,3 +99,7 @@ SYMBOL: max-uses
|
|||
[ ] [ 10 4 2 60 random-test ] unit-test
|
||||
[ ] [ 10 20 2 400 random-test ] unit-test
|
||||
[ ] [ 10 20 4 300 random-test ] unit-test
|
||||
|
||||
USING: math.private compiler.cfg.debugger ;
|
||||
|
||||
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -8,9 +8,20 @@ compiler.cfg.linear-scan.allocation
|
|||
compiler.cfg.linear-scan.assignment ;
|
||||
IN: compiler.cfg.linear-scan
|
||||
|
||||
! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
|
||||
! References:
|
||||
|
||||
! Linear Scan Register Allocation
|
||||
! by Massimiliano Poletto and Vivek Sarkar
|
||||
! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
|
||||
|
||||
! Linear Scan Register Allocation for the Java HotSpot Client Compiler
|
||||
! by Christian Wimmer
|
||||
! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
|
||||
|
||||
! Quality and Speed in Linear-scan Register Allocation
|
||||
! by Omri Traub, Glenn Holloway, Michael D. Smith
|
||||
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
|
||||
|
||||
: linear-scan ( mr -- mr' )
|
||||
[
|
||||
dup compute-live-intervals
|
||||
|
|
|
|||
|
|
@ -28,7 +28,6 @@ SYMBOL: live-intervals
|
|||
at [ (>>end) ] [ uses>> push ] 2bi ;
|
||||
|
||||
: new-live-interval ( n vreg live-intervals -- )
|
||||
2dup key? [ "Multiple defs" throw ] when
|
||||
[ [ <live-interval> ] keep ] dip set-at ;
|
||||
|
||||
: compute-live-intervals* ( insn n -- )
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: compiler.cfg.linearization
|
|||
SYMBOL: frame-size
|
||||
|
||||
: compute-frame-size ( rpo -- )
|
||||
[ instructions>> [ %frame-required? ] filter ] map concat
|
||||
[ instructions>> [ ##frame-required? ] filter ] map concat
|
||||
[ f ] [ [ n>> ] map supremum ] if-empty
|
||||
frame-size set ;
|
||||
|
||||
|
|
@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
|
|||
|
||||
M: insn linearize-insn , drop ;
|
||||
|
||||
M: %frame-required linearize-insn 2drop ;
|
||||
M: ##frame-required linearize-insn 2drop ;
|
||||
|
||||
M: %prologue linearize-insn
|
||||
M: ##prologue linearize-insn
|
||||
2drop frame-size get [ _prologue ] when* ;
|
||||
|
||||
M: %epilogue linearize-insn
|
||||
M: ##epilogue linearize-insn
|
||||
2drop frame-size get [ _epilogue ] when* ;
|
||||
|
||||
: useless-branch? ( basic-block successor -- ? )
|
||||
|
|
@ -39,50 +39,40 @@ M: %epilogue linearize-insn
|
|||
: branch-to-return? ( successor -- ? )
|
||||
#! A branch to a block containing just a return is cloned.
|
||||
instructions>> dup length 2 = [
|
||||
[ first %epilogue? ] [ second %return? ] bi and
|
||||
[ first ##epilogue? ] [ second ##return? ] bi and
|
||||
] [ drop f ] if ;
|
||||
|
||||
: emit-branch ( basic-block successor -- )
|
||||
{
|
||||
{ [ 2dup useless-branch? ] [ 2drop ] }
|
||||
{ [ dup branch-to-return? ] [ nip linearize-insns ] }
|
||||
[ nip label>> _branch ]
|
||||
[ nip number>> _branch ]
|
||||
} cond ;
|
||||
|
||||
M: %branch linearize-insn
|
||||
M: ##branch linearize-insn
|
||||
drop dup successors>> first emit-branch ;
|
||||
|
||||
: conditional ( basic-block -- basic-block successor1 label2 )
|
||||
dup successors>> first2 swap label>> ; inline
|
||||
dup successors>> first2 swap number>> ; inline
|
||||
|
||||
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
|
||||
[ conditional ] [ src>> ] bi* swap ; inline
|
||||
|
||||
M: %branch-f linearize-insn
|
||||
M: ##branch-f linearize-insn
|
||||
boolean-conditional _branch-f emit-branch ;
|
||||
|
||||
M: %branch-t linearize-insn
|
||||
M: ##branch-t linearize-insn
|
||||
boolean-conditional _branch-t emit-branch ;
|
||||
|
||||
M: %if-intrinsic linearize-insn
|
||||
[ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
|
||||
: >intrinsic< ( insn -- quot defs uses )
|
||||
[ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
|
||||
|
||||
M: ##if-intrinsic linearize-insn
|
||||
[ conditional ] [ >intrinsic< ] bi*
|
||||
_if-intrinsic emit-branch ;
|
||||
|
||||
M: %boolean-intrinsic linearize-insn
|
||||
[
|
||||
"false" define-label
|
||||
"end" define-label
|
||||
"false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
|
||||
dup dst>> t %load-literal
|
||||
"end" get _branch
|
||||
"false" resolve-label
|
||||
dup dst>> f %load-literal
|
||||
"end" resolve-label
|
||||
] with-scope
|
||||
2drop ;
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ label>> _label ] [ linearize-insns ] bi ;
|
||||
[ number>> _label ] [ linearize-insns ] bi ;
|
||||
|
||||
: linearize-basic-blocks ( rpo -- insns )
|
||||
[ [ linearize-basic-block ] each ] { } make ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces math kernel ;
|
||||
USING: accessors namespaces math kernel alien classes ;
|
||||
IN: compiler.cfg.registers
|
||||
|
||||
! Virtual CPU registers, used by CFG and machine IRs
|
||||
|
|
@ -8,8 +8,14 @@ IN: compiler.cfg.registers
|
|||
MIXIN: value
|
||||
|
||||
GENERIC: >vreg ( obj -- vreg )
|
||||
GENERIC: set-value-class ( class obj -- )
|
||||
GENERIC: value-class* ( operand -- class )
|
||||
|
||||
: value-class ( operand -- class ) value-class* object or ;
|
||||
|
||||
M: value >vreg drop f ;
|
||||
M: value set-value-class 2drop ;
|
||||
M: value value-class* drop f ;
|
||||
|
||||
! Register classes
|
||||
SINGLETON: int-regs
|
||||
|
|
@ -47,6 +53,8 @@ INSTANCE: loc value
|
|||
TUPLE: cached loc vreg ;
|
||||
C: <cached> cached
|
||||
|
||||
M: cached set-value-class vreg>> set-value-class ;
|
||||
M: cached value-class* vreg>> value-class* ;
|
||||
M: cached >vreg vreg>> >vreg ;
|
||||
|
||||
INSTANCE: cached value
|
||||
|
|
@ -55,6 +63,8 @@ INSTANCE: cached value
|
|||
TUPLE: tagged vreg class ;
|
||||
: <tagged> ( vreg -- tagged ) f tagged boa ;
|
||||
|
||||
M: tagged set-value-class (>>class) ;
|
||||
M: tagged value-class* class>> ;
|
||||
M: tagged >vreg vreg>> ;
|
||||
|
||||
INSTANCE: tagged value
|
||||
|
|
@ -71,20 +81,30 @@ INSTANCE: unboxed value
|
|||
TUPLE: unboxed-alien < unboxed ;
|
||||
C: <unboxed-alien> unboxed-alien
|
||||
|
||||
M: unboxed-alien value-class* drop simple-alien ;
|
||||
|
||||
! Untagged byte array pointer
|
||||
TUPLE: unboxed-byte-array < unboxed ;
|
||||
C: <unboxed-byte-array> unboxed-byte-array
|
||||
|
||||
M: unboxed-byte-array value-class* drop c-ptr ;
|
||||
|
||||
! A register set to f
|
||||
TUPLE: unboxed-f < unboxed ;
|
||||
C: <unboxed-f> unboxed-f
|
||||
|
||||
M: unboxed-f value-class* drop \ f ;
|
||||
|
||||
! An alien, byte array or f
|
||||
TUPLE: unboxed-c-ptr < unboxed ;
|
||||
C: <unboxed-c-ptr> unboxed-c-ptr
|
||||
|
||||
M: unboxed-c-ptr value-class* drop c-ptr ;
|
||||
|
||||
! A constant value
|
||||
TUPLE: constant value ;
|
||||
C: <constant> constant
|
||||
|
||||
M: constant value-class* value>> class ;
|
||||
|
||||
INSTANCE: constant value
|
||||
|
|
|
|||
|
|
@ -7,7 +7,6 @@ IN: compiler.cfg.rpo
|
|||
: post-order-traversal ( basic-block -- )
|
||||
dup visited>> [ drop ] [
|
||||
t >>visited
|
||||
<label> >>label
|
||||
[ successors>> [ post-order-traversal ] each ] [ , ] bi
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
|
|||
SYMBOL: known-tag
|
||||
|
||||
! Value protocol
|
||||
GENERIC: set-operand-class ( class obj -- )
|
||||
GENERIC: operand-class* ( operand -- class )
|
||||
GENERIC: move-spec ( obj -- spec )
|
||||
GENERIC: live-loc? ( actual current -- ? )
|
||||
GENERIC# (lazy-load) 1 ( value spec -- value )
|
||||
|
|
@ -32,23 +30,19 @@ DEFER: %move
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: operand-class ( operand -- class )
|
||||
operand-class* object or ;
|
||||
|
||||
! Default implementation
|
||||
M: value set-operand-class 2drop ;
|
||||
M: value operand-class* drop f ;
|
||||
M: value live-loc? 2drop f ;
|
||||
M: value minimal-ds-loc* drop ;
|
||||
M: value lazy-store 2drop ;
|
||||
|
||||
M: vreg move-spec reg-class>> move-spec ;
|
||||
M: vreg value-class* reg-class>> value-class* ;
|
||||
|
||||
M: int-regs move-spec drop f ;
|
||||
M: int-regs operand-class* drop object ;
|
||||
M: int-regs value-class* drop object ;
|
||||
|
||||
M: float-regs move-spec drop float ;
|
||||
M: float-regs operand-class* drop float ;
|
||||
M: float-regs value-class* drop float ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* n>> min ;
|
||||
M: ds-loc live-loc?
|
||||
|
|
@ -57,15 +51,13 @@ M: ds-loc live-loc?
|
|||
M: rs-loc live-loc?
|
||||
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
|
||||
|
||||
M: loc operand-class* class>> ;
|
||||
M: loc set-operand-class (>>class) ;
|
||||
M: loc value-class* class>> ;
|
||||
M: loc set-value-class (>>class) ;
|
||||
M: loc move-spec drop loc ;
|
||||
|
||||
M: f move-spec drop loc ;
|
||||
M: f operand-class* ;
|
||||
M: f value-class* ;
|
||||
|
||||
M: cached set-operand-class vreg>> set-operand-class ;
|
||||
M: cached operand-class* vreg>> operand-class* ;
|
||||
M: cached move-spec drop cached ;
|
||||
M: cached live-loc? loc>> live-loc? ;
|
||||
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
|
||||
|
|
@ -75,41 +67,34 @@ M: cached lazy-store
|
|||
[ "live-locs" get at %move ] [ 2drop ] if ;
|
||||
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
|
||||
|
||||
M: tagged set-operand-class (>>class) ;
|
||||
M: tagged operand-class* class>> ;
|
||||
M: tagged move-spec drop f ;
|
||||
|
||||
M: unboxed-alien operand-class* drop simple-alien ;
|
||||
M: unboxed-alien move-spec class ;
|
||||
|
||||
M: unboxed-byte-array operand-class* drop c-ptr ;
|
||||
M: unboxed-byte-array move-spec class ;
|
||||
|
||||
M: unboxed-f operand-class* drop \ f ;
|
||||
M: unboxed-f move-spec class ;
|
||||
|
||||
M: unboxed-c-ptr operand-class* drop c-ptr ;
|
||||
M: unboxed-c-ptr move-spec class ;
|
||||
|
||||
M: constant operand-class* value>> class ;
|
||||
M: constant move-spec class ;
|
||||
|
||||
! Moving values between locations and registers
|
||||
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
|
||||
|
||||
: %unbox-c-ptr ( dst src -- )
|
||||
dup operand-class {
|
||||
{ [ dup \ f class<= ] [ drop %unbox-f ] }
|
||||
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
|
||||
[ drop %unbox-any-c-ptr ]
|
||||
dup value-class {
|
||||
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
|
||||
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
|
||||
[ drop ##unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
: %move-via-temp ( dst src -- )
|
||||
#! For many transfers, such as loc to unboxed-alien, we
|
||||
#! don't have an intrinsic, so we transfer the source to
|
||||
#! temp then temp to the destination.
|
||||
int-regs next-vreg [ over %move operand-class ] keep
|
||||
int-regs next-vreg [ over %move value-class ] keep
|
||||
tagged new
|
||||
swap >>vreg
|
||||
swap >>class
|
||||
|
|
@ -117,28 +102,28 @@ M: constant move-spec class ;
|
|||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ %copy ] }
|
||||
{ { unboxed-alien unboxed-alien } [ %copy ] }
|
||||
{ { unboxed-byte-array unboxed-byte-array } [ %copy ] }
|
||||
{ { unboxed-f unboxed-f } [ %copy ] }
|
||||
{ { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
|
||||
{ { float float } [ %copy-float ] }
|
||||
{ { f f } [ ##copy ] }
|
||||
{ { unboxed-alien unboxed-alien } [ ##copy ] }
|
||||
{ { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
|
||||
{ { unboxed-f unboxed-f } [ ##copy ] }
|
||||
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
|
||||
{ { float float } [ ##copy-float ] }
|
||||
|
||||
{ { f unboxed-c-ptr } [ %move-bug ] }
|
||||
{ { f unboxed-byte-array } [ %move-bug ] }
|
||||
|
||||
{ { f constant } [ value>> %load-literal ] }
|
||||
{ { f constant } [ value>> ##load-literal ] }
|
||||
|
||||
{ { f float } [ %box-float ] }
|
||||
{ { f unboxed-alien } [ %box-alien ] }
|
||||
{ { f loc } [ %peek ] }
|
||||
{ { f float } [ ##box-float ] }
|
||||
{ { f unboxed-alien } [ ##box-alien ] }
|
||||
{ { f loc } [ ##peek ] }
|
||||
|
||||
{ { float f } [ %unbox-float ] }
|
||||
{ { unboxed-alien f } [ %unbox-alien ] }
|
||||
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
|
||||
{ { unboxed-f f } [ %unbox-f ] }
|
||||
{ { float f } [ ##unbox-float ] }
|
||||
{ { unboxed-alien f } [ ##unbox-alien ] }
|
||||
{ { unboxed-byte-array f } [ ##unbox-byte-array ] }
|
||||
{ { unboxed-f f } [ ##unbox-f ] }
|
||||
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
|
||||
{ { loc f } [ swap %replace ] }
|
||||
{ { loc f } [ swap ##replace ] }
|
||||
|
||||
[ drop %move-via-temp ]
|
||||
} case ;
|
||||
|
|
@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
|
|||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
||||
|
||||
M: phantom-datastack finalize-height
|
||||
\ %inc-d (finalize-height) ;
|
||||
\ ##inc-d (finalize-height) ;
|
||||
|
||||
TUPLE: phantom-retainstack < phantom-stack ;
|
||||
|
||||
|
|
@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
|
|||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
||||
|
||||
M: phantom-retainstack finalize-height
|
||||
\ %inc-r (finalize-height) ;
|
||||
\ ##inc-r (finalize-height) ;
|
||||
|
||||
: phantom-locs ( n phantom -- locs )
|
||||
#! A sequence of n ds-locs or rs-locs indexing the stack.
|
||||
|
|
@ -265,7 +250,7 @@ SYMBOL: fresh-objects
|
|||
} cond 2nip ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
alloc-vreg swap operand-class
|
||||
alloc-vreg swap value-class
|
||||
over tagged? [ >>class ] [ drop ] if ;
|
||||
|
||||
M: value (lazy-load)
|
||||
|
|
@ -301,7 +286,7 @@ M: loc lazy-store
|
|||
dup phantom-locs*
|
||||
over stack>> [
|
||||
dup constant? [ nip ] [
|
||||
operand-class over set-operand-class
|
||||
value-class over set-value-class
|
||||
] if
|
||||
] 2map
|
||||
over stack>> delete-all
|
||||
|
|
@ -330,10 +315,10 @@ M: loc lazy-store
|
|||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
||||
: set-operand-classes ( classes -- )
|
||||
: set-value-classes ( classes -- )
|
||||
phantom-datastack get
|
||||
over length over add-locs
|
||||
stack>> [ set-operand-class ] 2reverse-each ;
|
||||
stack>> [ set-value-class ] 2reverse-each ;
|
||||
|
||||
: finalize-phantoms ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
|
|
@ -342,7 +327,7 @@ M: loc lazy-store
|
|||
finalize-contents
|
||||
clear-phantoms
|
||||
finalize-heights
|
||||
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
|
||||
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
|
|
@ -358,14 +343,6 @@ M: loc lazy-store
|
|||
phantom-datastack [ clone ] change
|
||||
phantom-retainstack [ clone ] change ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: phantom-push ( obj -- )
|
||||
1 phantom-datastack get adjust-phantom
|
||||
phantom-datastack get stack>> push ;
|
||||
|
|
|
|||
|
|
@ -5,16 +5,7 @@ quotations combinators classes.algebra compiler.cfg.instructions
|
|||
compiler.cfg.registers compiler.cfg.stacks ;
|
||||
IN: compiler.cfg.templates
|
||||
|
||||
USE: qualified
|
||||
FROM: compiler.generator.registers => +input+ ;
|
||||
FROM: compiler.generator.registers => +output+ ;
|
||||
FROM: compiler.generator.registers => +scratch+ ;
|
||||
FROM: compiler.generator.registers => +clobber+ ;
|
||||
|
||||
: template-input +input+ swap at ; inline
|
||||
: template-output +output+ swap at ; inline
|
||||
: template-scratch +scratch+ swap at ; inline
|
||||
: template-clobber +clobber+ swap at ; inline
|
||||
TUPLE: template input output scratch clobber gc ;
|
||||
|
||||
: phantom&spec ( phantom specs -- phantom' specs' )
|
||||
>r stack>> r>
|
||||
|
|
@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
|
|||
[ stack>> [ >vreg ] map sift ] each-phantom append ;
|
||||
|
||||
: clobbered ( template -- seq )
|
||||
[ template-output ] [ template-clobber ] bi append ;
|
||||
[ output>> ] [ clobber>> ] bi append ;
|
||||
|
||||
: clobbered? ( value name -- ? )
|
||||
\ clobbered get member? [
|
||||
|
|
@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
|
|||
[
|
||||
live-vregs \ live-vregs set
|
||||
dup clobbered \ clobbered set
|
||||
template-input [ values ] [ lazy-load ] bi zip
|
||||
input>> [ values ] [ lazy-load ] bi zip
|
||||
] with-scope ;
|
||||
|
||||
: alloc-scratch ( template -- assoc )
|
||||
template-scratch [ swap alloc-vreg ] assoc-map ;
|
||||
scratch>> [ swap alloc-vreg ] assoc-map ;
|
||||
|
||||
: do-template-inputs ( template -- inputs )
|
||||
: do-template-inputs ( template -- defs uses )
|
||||
#! Load input values into registers and allocates scratch
|
||||
#! registers.
|
||||
[ load-inputs ] [ alloc-scratch ] bi assoc-union ;
|
||||
[ alloc-scratch ] [ load-inputs ] bi ;
|
||||
|
||||
: do-template-outputs ( template inputs -- )
|
||||
[ template-output ] dip '[ _ at ] map
|
||||
: do-template-outputs ( template defs uses -- )
|
||||
[ output>> ] 2dip assoc-union '[ _ at ] map
|
||||
phantom-datastack get phantom-append ;
|
||||
|
||||
: apply-template ( pair quot -- vregs )
|
||||
[
|
||||
first2 dup do-template-inputs
|
||||
[ do-template-outputs ] keep
|
||||
[ do-template-outputs ] 2keep
|
||||
] dip call ; inline
|
||||
|
||||
: value-matches? ( value spec -- ? )
|
||||
|
|
@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
|
|||
|
||||
: spec-matches? ( value spec -- ? )
|
||||
2dup first value-matches?
|
||||
>r >r operand-class 2 r> ?nth class-matches? r> and ;
|
||||
>r >r value-class 2 r> ?nth class-matches? r> and ;
|
||||
|
||||
: template-matches? ( template -- ? )
|
||||
template-input phantom-datastack get swap
|
||||
input>> phantom-datastack get swap
|
||||
[ spec-matches? ] phantom&spec-agree? ;
|
||||
|
||||
: find-template ( templates -- pair/f )
|
||||
|
|
|
|||
|
|
@ -1,16 +1,128 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.backend.alien
|
||||
USING: namespaces make math math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
threads continuations.private libc combinators
|
||||
alien alien.c-types alien.structs alien.strings
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.backend
|
||||
compiler.codegen.fixup
|
||||
compiler.cfg
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.codegen
|
||||
|
||||
GENERIC: generate-insn ( insn -- )
|
||||
|
||||
: generate-insns ( insns -- code )
|
||||
[
|
||||
[
|
||||
dup regs>> registers set
|
||||
generate-insn
|
||||
] each
|
||||
] { } make fixup ;
|
||||
|
||||
TUPLE: asm label code calls ;
|
||||
|
||||
SYMBOL: calls
|
||||
|
||||
: add-call ( word -- )
|
||||
#! Compile this word later.
|
||||
calls get push ;
|
||||
|
||||
SYMBOL: compiling-word
|
||||
|
||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
||||
|
||||
! Mapping _label IDs to label instances
|
||||
SYMBOL: labels
|
||||
|
||||
: init-generator ( word -- )
|
||||
H{ } clone labels set
|
||||
V{ } clone literal-table set
|
||||
V{ } clone calls set
|
||||
compiling-word set
|
||||
compiled-stack-traces? compiling-word get f ? add-literal drop ;
|
||||
|
||||
: generate ( mr -- asm )
|
||||
[
|
||||
[ label>> ]
|
||||
[ word>> init-generator ]
|
||||
[ instructions>> generate-insns ] tri
|
||||
calls get
|
||||
asm boa
|
||||
] with-scope ;
|
||||
|
||||
: lookup-label ( id -- label )
|
||||
labels get [ drop <label> ] cache ;
|
||||
|
||||
M: _label generate-insn
|
||||
id>> lookup-label , ;
|
||||
|
||||
M: _prologue generate-insn
|
||||
n>> %prologue ;
|
||||
|
||||
M: _epilogue generate-insn
|
||||
n>> %epilogue ;
|
||||
|
||||
M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
|
||||
|
||||
M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
|
||||
|
||||
M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
|
||||
|
||||
M: ##inc-d generate-insn n>> %inc-d ;
|
||||
|
||||
M: ##inc-r generate-insn n>> %inc-r ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
|
||||
M: ##intrinsic generate-insn
|
||||
[ init-intrinsic ] [ quot>> call ] bi ;
|
||||
|
||||
M: _if-intrinsic generate-insn
|
||||
[ init-intrinsic ]
|
||||
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
|
||||
|
||||
M: _branch generate-insn
|
||||
label>> lookup-label %jump-label ;
|
||||
|
||||
M: _branch-f generate-insn
|
||||
[ src>> ] [ label>> lookup-label ] bi %jump-f ;
|
||||
|
||||
M: _branch-t generate-insn
|
||||
[ src>> ] [ label>> lookup-label ] bi %jump-t ;
|
||||
|
||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||
|
||||
M: ##dispatch generate-insn drop %dispatch ;
|
||||
|
||||
M: ##copy generate-insn %copy ;
|
||||
|
||||
M: ##copy-float generate-insn %copy-float ;
|
||||
|
||||
M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
|
||||
|
||||
M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
|
||||
|
||||
M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
|
||||
|
||||
M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
|
||||
|
||||
M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
|
||||
|
||||
M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
|
||||
|
||||
M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
|
||||
|
||||
M: ##gc generate-insn drop %gc ;
|
||||
|
||||
! #alien-invoke
|
||||
: set-stack-frame ( n -- )
|
||||
dup [ frame-required ] when* \ stack-frame set ;
|
||||
|
||||
: with-stack-frame ( n quot -- )
|
||||
swap set-stack-frame
|
||||
call
|
||||
f set-stack-frame ; inline
|
||||
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
M: int-regs reg-size drop cell ;
|
||||
|
|
@ -55,17 +167,17 @@ M: object reg-class-full?
|
|||
[ spill-param ] [ fastcall-param ] if
|
||||
[ param-reg ] keep ;
|
||||
|
||||
: (flatten-int-type) ( size -- )
|
||||
cell /i "void*" c-type <repetition> % ;
|
||||
: (flatten-int-type) ( size -- seq )
|
||||
cell /i "void*" c-type <repetition> ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- )
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type , ;
|
||||
M: object flatten-value-type 1array ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- )
|
||||
M: struct-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- )
|
||||
M: long-long-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
|
|
@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
|
|||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) ] keep
|
||||
[ parameter-align (flatten-int-type) % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
|
|
@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
|
|||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
M: ##alien-invoke generate-insn
|
||||
params>>
|
||||
dup alien-invoke-frame [
|
||||
end-basic-block
|
||||
%prepare-alien-invoke
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
! Save registers for GC
|
||||
%prepare-alien-invoke
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call function
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
! Box return value
|
||||
dup %cleanup
|
||||
box-return* ;
|
||||
|
||||
! #alien-indirect
|
||||
M: #alien-indirect generate-node
|
||||
! ##alien-indirect
|
||||
M: ##alien-indirect generate-insn
|
||||
params>>
|
||||
dup alien-invoke-frame [
|
||||
! Flush registers
|
||||
end-basic-block
|
||||
! Save registers for GC
|
||||
%prepare-alien-invoke
|
||||
! Save alien at top of stack to temporary storage
|
||||
%prepare-alien-indirect
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call alien in temporary storage
|
||||
%alien-indirect
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
! Save registers for GC
|
||||
%prepare-alien-invoke
|
||||
! Save alien at top of stack to temporary storage
|
||||
%prepare-alien-indirect
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call alien in temporary storage
|
||||
%alien-indirect
|
||||
! Box return value
|
||||
dup %cleanup
|
||||
box-return* ;
|
||||
|
||||
! #alien-callback
|
||||
! ##alien-callback
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters [ box-parameter ] each-parameter ;
|
||||
|
||||
|
|
@ -264,18 +373,9 @@ TUPLE: callback-context ;
|
|||
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||
callback-unwind %unwind ;
|
||||
|
||||
: generate-callback ( params -- )
|
||||
dup xt>> dup [
|
||||
init-templates
|
||||
%prologue
|
||||
dup alien-stack-frame [
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ %callback-return ]
|
||||
tri
|
||||
] with-stack-frame
|
||||
] with-cfg-builder ;
|
||||
|
||||
M: #alien-callback generate-node
|
||||
end-basic-block
|
||||
params>> generate-callback iterate-next ;
|
||||
M: ##alien-callback generate-insn
|
||||
params>>
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ %callback-return ]
|
||||
tri ;
|
||||
|
|
@ -3,76 +3,20 @@
|
|||
USING: arrays byte-arrays generic assocs hashtables io.binary
|
||||
kernel kernel.private math namespaces make sequences words
|
||||
quotations strings alien.accessors alien.strings layouts system
|
||||
combinators math.bitwise words.private cpu.architecture
|
||||
math.order accessors growable ;
|
||||
IN: compiler.cfg.fixup
|
||||
combinators math.bitwise words.private math.order accessors
|
||||
growable compiler.constants compiler.backend ;
|
||||
IN: compiler.codegen.fixup
|
||||
|
||||
: no-stack-frame -1 ; inline
|
||||
|
||||
TUPLE: frame-required n ;
|
||||
|
||||
: frame-required ( n -- ) \ frame-required boa , ;
|
||||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
dup frame-required? [ n>> max ] [ drop ] if
|
||||
] reduce ;
|
||||
|
||||
GENERIC: fixup* ( frame-size obj -- frame-size )
|
||||
GENERIC: fixup* ( obj -- )
|
||||
|
||||
: code-format 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset >>offset drop ;
|
||||
|
||||
: define-label ( name -- ) <label> swap set ;
|
||||
|
||||
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
|
||||
|
||||
: if-stack-frame ( frame-size quot -- )
|
||||
swap dup no-stack-frame =
|
||||
[ 2drop ] [ stack-frame swap call ] if ; inline
|
||||
|
||||
M: word fixup*
|
||||
{
|
||||
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
||||
! Relocation classes
|
||||
: rc-absolute-cell 0 ;
|
||||
: rc-absolute 1 ;
|
||||
: rc-relative 2 ;
|
||||
: rc-absolute-ppc-2/2 3 ;
|
||||
: rc-relative-ppc-2 4 ;
|
||||
: rc-relative-ppc-3 5 ;
|
||||
: rc-relative-arm-3 6 ;
|
||||
: rc-indirect-arm 7 ;
|
||||
: rc-indirect-arm-pc 8 ;
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
dup rc-absolute-cell =
|
||||
over rc-absolute =
|
||||
rot rc-absolute-ppc-2/2 = or or ;
|
||||
|
||||
! Relocation types
|
||||
: rt-primitive 0 ;
|
||||
: rt-dlsym 1 ;
|
||||
: rt-literal 2 ;
|
||||
: rt-dispatch 3 ;
|
||||
: rt-xt 4 ;
|
||||
: rt-here 5 ;
|
||||
: rt-label 6 ;
|
||||
: rt-immediate 7 ;
|
||||
M: label fixup* compiled-offset >>offset drop ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
|
|
@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
|
|||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
dup label>> swap class>> compiled-offset 4 - rot
|
||||
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup arg class type ;
|
||||
|
|
@ -97,8 +41,6 @@ M: rel-fixup fixup*
|
|||
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
|
||||
[ relocation-table get push-4 ] bi@ ;
|
||||
|
||||
M: frame-required fixup* drop ;
|
||||
|
||||
M: integer fixup* , ;
|
||||
|
||||
: adjoin* ( obj table -- n )
|
||||
|
|
@ -143,12 +85,11 @@ SYMBOL: literal-table
|
|||
3array
|
||||
] map concat ;
|
||||
|
||||
: fixup ( code -- literals relocation labels code )
|
||||
: fixup ( fixup-directives -- code )
|
||||
[
|
||||
init-fixup
|
||||
dup stack-frame-size swap [ fixup* ] each drop
|
||||
|
||||
[ fixup* ] each
|
||||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] { } make ;
|
||||
] { } make 4array ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,116 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io debugger
|
||||
words fry continuations vocabs assocs dlists definitions math
|
||||
threads graphs generic combinators deques search-deques
|
||||
stack-checker stack-checker.state stack-checker.inlining
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder
|
||||
compiler.cfg.linearization compiler.cfg.linear-scan
|
||||
compiler.codegen ;
|
||||
IN: compiler.new
|
||||
|
||||
SYMBOL: compile-queue
|
||||
SYMBOL: compiled
|
||||
|
||||
: queue-compile ( word -- )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ ] }
|
||||
{ [ dup compiled get key? ] [ ] }
|
||||
{ [ dup inlined-block? ] [ ] }
|
||||
{ [ dup primitive? ] [ ] }
|
||||
[ dup compile-queue get push-front ]
|
||||
} cond drop ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
dup compiled>> [ drop ] [ queue-compile ] if ;
|
||||
|
||||
SYMBOL: +failed+
|
||||
|
||||
: ripple-up ( words -- )
|
||||
dup "compiled-effect" word-prop +failed+ eq?
|
||||
[ usage [ word? ] filter ] [ compiled-usage keys ] if
|
||||
[ queue-compile ] each ;
|
||||
|
||||
: ripple-up? ( word effect -- ? )
|
||||
#! If the word has previously been compiled and had a
|
||||
#! different stack effect, we have to recompile any callers.
|
||||
swap "compiled-effect" word-prop [ = not ] keep and ;
|
||||
|
||||
: save-effect ( word effect -- )
|
||||
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
|
||||
[ "compiled-effect" set-word-prop ]
|
||||
2bi ;
|
||||
|
||||
: start ( word -- )
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
f swap compiler-error ;
|
||||
|
||||
: fail ( word error -- )
|
||||
[ swap compiler-error ]
|
||||
[
|
||||
drop
|
||||
[ compiled-unxref ]
|
||||
[ f swap compiled get set-at ]
|
||||
[ +failed+ save-effect ]
|
||||
tri
|
||||
] 2bi
|
||||
return ;
|
||||
|
||||
: frontend ( word -- effect nodes )
|
||||
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
|
||||
|
||||
: finish ( effect word -- )
|
||||
[ swap save-effect ]
|
||||
[ compiled-unxref ]
|
||||
[
|
||||
dup crossref?
|
||||
[
|
||||
dependencies get >alist
|
||||
generic-dependencies get >alist
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
||||
: save-asm ( asm -- )
|
||||
[ [ code>> ] [ label>> ] bi compiled get set-at ]
|
||||
[ calls>> [ queue-compile ] each ]
|
||||
bi ;
|
||||
|
||||
: backend ( nodes word -- )
|
||||
build-cfg [ build-mr linear-scan generate save-asm ] each ;
|
||||
|
||||
: (compile) ( word -- )
|
||||
'[
|
||||
_ {
|
||||
[ start ]
|
||||
[ frontend ]
|
||||
[ backend ]
|
||||
[ finish ]
|
||||
} cleave
|
||||
] with-return ;
|
||||
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
|
||||
: optimized-recompile-hook ( words -- alist )
|
||||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
H{ } clone compiled set
|
||||
[ queue-compile ] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ optimized-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
forget-errors all-words compile ;
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel words sequences lexer parser fry ;
|
||||
IN: cpu.x86.syntax
|
||||
|
||||
: define-register ( name num size -- )
|
||||
[ "cpu.x86" create dup define-symbol ]
|
||||
[ dupd "register" set-word-prop ]
|
||||
[ "register-size" set-word-prop ]
|
||||
tri* ;
|
||||
|
||||
: define-registers ( names size -- )
|
||||
[ dup length ] dip '[ _ define-register ] 2each ;
|
||||
|
||||
: REGISTERS: ( -- )
|
||||
scan-word ";" parse-tokens swap define-registers ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,470 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays compiler.constants compiler.backend
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.syntax ;
|
||||
IN: cpu.x86
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
! Beware!
|
||||
|
||||
! Register operands -- eg, ECX
|
||||
REGISTERS: 8 AL CL DL BL ;
|
||||
|
||||
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
|
||||
|
||||
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
|
||||
|
||||
REGISTERS: 64
|
||||
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
|
||||
|
||||
REGISTERS: 128
|
||||
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
|
||||
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
|
||||
|
||||
TUPLE: byte value ;
|
||||
|
||||
C: <byte> byte
|
||||
|
||||
<PRIVATE
|
||||
|
||||
#! Extended AMD64 registers (R8-R15) return true.
|
||||
GENERIC: extended? ( op -- ? )
|
||||
|
||||
M: object extended? drop f ;
|
||||
|
||||
PREDICATE: register < word
|
||||
"register" word-prop ;
|
||||
|
||||
PREDICATE: register-8 < register
|
||||
"register-size" word-prop 8 = ;
|
||||
|
||||
PREDICATE: register-16 < register
|
||||
"register-size" word-prop 16 = ;
|
||||
|
||||
PREDICATE: register-32 < register
|
||||
"register-size" word-prop 32 = ;
|
||||
|
||||
PREDICATE: register-64 < register
|
||||
"register-size" word-prop 64 = ;
|
||||
|
||||
PREDICATE: register-128 < register
|
||||
"register-size" word-prop 128 = ;
|
||||
|
||||
M: register extended? "register" word-prop 7 > ;
|
||||
|
||||
! Addressing modes
|
||||
TUPLE: indirect base index scale displacement ;
|
||||
|
||||
M: indirect extended? base>> extended? ;
|
||||
|
||||
: canonicalize-EBP ( indirect -- indirect )
|
||||
#! { EBP } ==> { EBP 0 }
|
||||
dup base>> { EBP RBP R13 } member? [
|
||||
dup displacement>> [ 0 >>displacement ] unless
|
||||
] when ;
|
||||
|
||||
: canonicalize-ESP ( indirect -- indirect )
|
||||
#! { ESP } ==> { ESP ESP }
|
||||
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
|
||||
|
||||
: canonicalize ( indirect -- indirect )
|
||||
#! Modify the indirect to work around certain addressing mode
|
||||
#! quirks.
|
||||
canonicalize-EBP canonicalize-ESP ;
|
||||
|
||||
: <indirect> ( base index scale displacement -- indirect )
|
||||
indirect boa canonicalize ;
|
||||
|
||||
: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
|
||||
|
||||
: indirect-base* ( op -- n ) base>> EBP or reg-code ;
|
||||
|
||||
: indirect-index* ( op -- n ) index>> ESP or reg-code ;
|
||||
|
||||
: indirect-scale* ( op -- n ) scale>> 0 or ;
|
||||
|
||||
GENERIC: sib-present? ( op -- ? )
|
||||
|
||||
M: indirect sib-present?
|
||||
[ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
|
||||
|
||||
M: register sib-present? drop f ;
|
||||
|
||||
GENERIC: r/m ( operand -- n )
|
||||
|
||||
M: indirect r/m
|
||||
dup sib-present?
|
||||
[ drop ESP reg-code ] [ indirect-base* ] if ;
|
||||
|
||||
M: register r/m reg-code ;
|
||||
|
||||
! Immediate operands
|
||||
UNION: immediate byte integer ;
|
||||
|
||||
GENERIC: fits-in-byte? ( value -- ? )
|
||||
|
||||
M: byte fits-in-byte? drop t ;
|
||||
|
||||
M: integer fits-in-byte? -128 127 between? ;
|
||||
|
||||
GENERIC: modifier ( op -- n )
|
||||
|
||||
M: indirect modifier
|
||||
dup base>> [
|
||||
displacement>> {
|
||||
{ [ dup not ] [ BIN: 00 ] }
|
||||
{ [ dup fits-in-byte? ] [ BIN: 01 ] }
|
||||
{ [ dup immediate? ] [ BIN: 10 ] }
|
||||
} cond nip
|
||||
] [
|
||||
drop BIN: 00
|
||||
] if ;
|
||||
|
||||
M: register modifier drop BIN: 11 ;
|
||||
|
||||
GENERIC# n, 1 ( value n -- )
|
||||
|
||||
M: integer n, >le % ;
|
||||
M: byte n, >r value>> r> n, ;
|
||||
: 1, ( n -- ) 1 n, ; inline
|
||||
: 4, ( n -- ) 4 n, ; inline
|
||||
: 2, ( n -- ) 2 n, ; inline
|
||||
: cell, ( n -- ) bootstrap-cell n, ; inline
|
||||
|
||||
: mod-r/m, ( reg# indirect -- )
|
||||
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
|
||||
|
||||
: sib, ( indirect -- )
|
||||
dup sib-present? [
|
||||
[ indirect-base* ]
|
||||
[ indirect-index* 3 shift ]
|
||||
[ indirect-scale* 6 shift ] tri bitor bitor ,
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
GENERIC: displacement, ( op -- )
|
||||
|
||||
M: indirect displacement,
|
||||
dup displacement>> dup [
|
||||
swap base>>
|
||||
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: register displacement, drop ;
|
||||
|
||||
: addressing ( reg# indirect -- )
|
||||
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
|
||||
|
||||
! Utilities
|
||||
UNION: operand register indirect ;
|
||||
|
||||
GENERIC: operand-64? ( operand -- ? )
|
||||
|
||||
M: indirect operand-64?
|
||||
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
|
||||
|
||||
M: register-64 operand-64? drop t ;
|
||||
|
||||
M: object operand-64? drop f ;
|
||||
|
||||
: rex.w? ( rex.w reg r/m -- ? )
|
||||
{
|
||||
{ [ dup register-128? ] [ drop operand-64? ] }
|
||||
{ [ dup not ] [ drop operand-64? ] }
|
||||
[ nip operand-64? ]
|
||||
} cond and ;
|
||||
|
||||
: rex.r ( m op -- n )
|
||||
extended? [ BIN: 00000100 bitor ] when ;
|
||||
|
||||
: rex.b ( m op -- n )
|
||||
[ extended? [ BIN: 00000001 bitor ] when ] keep
|
||||
dup indirect? [
|
||||
index>> extended? [ BIN: 00000010 bitor ] when
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: rex-prefix ( reg r/m rex.w -- )
|
||||
#! Compile an AMD64 REX prefix.
|
||||
2over rex.w? BIN: 01001000 BIN: 01000000 ?
|
||||
swap rex.r swap rex.b
|
||||
dup BIN: 01000000 = [ drop ] [ , ] if ;
|
||||
|
||||
: 16-prefix ( reg r/m -- )
|
||||
[ register-16? ] either? [ HEX: 66 , ] when ;
|
||||
|
||||
: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
|
||||
|
||||
: prefix-1 ( reg rex.w -- ) f swap prefix ;
|
||||
|
||||
: short-operand ( reg rex.w n -- )
|
||||
#! Some instructions encode their single operand as part of
|
||||
#! the opcode.
|
||||
>r dupd prefix-1 reg-code r> + , ;
|
||||
|
||||
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
|
||||
|
||||
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
|
||||
|
||||
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
|
||||
|
||||
: opcode-or ( opcode mask -- opcode' )
|
||||
swap dup array?
|
||||
[ unclip-last rot bitor suffix ] [ bitor ] if ;
|
||||
|
||||
: 1-operand ( op reg,rex.w,opcode -- )
|
||||
#! The 'reg' is not really a register, but a value for the
|
||||
#! 'reg' field of the mod-r/m byte.
|
||||
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
|
||||
|
||||
: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
|
||||
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
|
||||
|
||||
: immediate-1 ( imm dst reg,rex.w,opcode -- )
|
||||
immediate-operand-size-bit 1-operand 1, ;
|
||||
|
||||
: immediate-4 ( imm dst reg,rex.w,opcode -- )
|
||||
immediate-operand-size-bit 1-operand 4, ;
|
||||
|
||||
: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
|
||||
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
|
||||
|
||||
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
|
||||
#! If imm is a byte, compile the opcode and the byte.
|
||||
#! Otherwise, set the 8-bit operand flag in the opcode, and
|
||||
#! compile the cell. The 'reg' is not really a register, but
|
||||
#! a value for the 'reg' field of the mod-r/m byte.
|
||||
pick fits-in-byte? [
|
||||
immediate-fits-in-size-bit immediate-1
|
||||
] [
|
||||
immediate-4
|
||||
] if ;
|
||||
|
||||
: (2-operand) ( dst src op -- )
|
||||
>r 2dup t rex-prefix r> opcode,
|
||||
reg-code swap addressing ;
|
||||
|
||||
: direction-bit ( dst src op -- dst' src' op' )
|
||||
pick register? [ BIN: 10 opcode-or swapd ] when ;
|
||||
|
||||
: operand-size-bit ( dst src op -- dst' src' op' )
|
||||
over register-8? [ BIN: 1 opcode-or ] unless ;
|
||||
|
||||
: 2-operand ( dst src op -- )
|
||||
#! Sets the opcode's direction bit. It is set if the
|
||||
#! destination is a direct register operand.
|
||||
2over 16-prefix
|
||||
direction-bit
|
||||
operand-size-bit
|
||||
(2-operand) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: [] ( reg/displacement -- indirect )
|
||||
dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
|
||||
|
||||
: [+] ( reg displacement -- indirect )
|
||||
dup integer?
|
||||
[ dup zero? [ drop f ] when >r f f r> ]
|
||||
[ f f ] if
|
||||
<indirect> ;
|
||||
|
||||
! Moving stuff
|
||||
GENERIC: PUSH ( op -- )
|
||||
M: register PUSH f HEX: 50 short-operand ;
|
||||
M: immediate PUSH HEX: 68 , 4, ;
|
||||
M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: POP ( op -- )
|
||||
M: register POP f HEX: 58 short-operand ;
|
||||
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
|
||||
|
||||
! MOV where the src is immediate.
|
||||
GENERIC: (MOV-I) ( src dst -- )
|
||||
M: register (MOV-I) t HEX: b8 short-operand cell, ;
|
||||
M: operand (MOV-I)
|
||||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: word JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: word CALL (CALL) rel-word ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
|
||||
M: word JUMPcc (JUMPcc) rel-word ;
|
||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
: JB ( dst -- ) HEX: 82 JUMPcc ;
|
||||
: JAE ( dst -- ) HEX: 83 JUMPcc ;
|
||||
: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
|
||||
: JNE ( dst -- ) HEX: 85 JUMPcc ;
|
||||
: JBE ( dst -- ) HEX: 86 JUMPcc ;
|
||||
: JA ( dst -- ) HEX: 87 JUMPcc ;
|
||||
: JS ( dst -- ) HEX: 88 JUMPcc ;
|
||||
: JNS ( dst -- ) HEX: 89 JUMPcc ;
|
||||
: JP ( dst -- ) HEX: 8a JUMPcc ;
|
||||
: JNP ( dst -- ) HEX: 8b JUMPcc ;
|
||||
: JL ( dst -- ) HEX: 8c JUMPcc ;
|
||||
: JGE ( dst -- ) HEX: 8d JUMPcc ;
|
||||
: JLE ( dst -- ) HEX: 8e JUMPcc ;
|
||||
: JG ( dst -- ) HEX: 8f JUMPcc ;
|
||||
|
||||
: LEAVE ( -- ) HEX: c9 , ;
|
||||
: NOP ( -- ) HEX: 90 , ;
|
||||
|
||||
: RET ( n -- )
|
||||
dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
|
||||
|
||||
! Arithmetic
|
||||
|
||||
GENERIC: ADD ( dst src -- )
|
||||
M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand ADD OCT: 000 2-operand ;
|
||||
|
||||
GENERIC: OR ( dst src -- )
|
||||
M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand OR OCT: 010 2-operand ;
|
||||
|
||||
GENERIC: ADC ( dst src -- )
|
||||
M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand ADC OCT: 020 2-operand ;
|
||||
|
||||
GENERIC: SBB ( dst src -- )
|
||||
M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand SBB OCT: 030 2-operand ;
|
||||
|
||||
GENERIC: AND ( dst src -- )
|
||||
M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand AND OCT: 040 2-operand ;
|
||||
|
||||
GENERIC: SUB ( dst src -- )
|
||||
M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand SUB OCT: 050 2-operand ;
|
||||
|
||||
GENERIC: XOR ( dst src -- )
|
||||
M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand XOR OCT: 060 2-operand ;
|
||||
|
||||
GENERIC: CMP ( dst src -- )
|
||||
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand CMP OCT: 070 2-operand ;
|
||||
|
||||
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
|
||||
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
|
||||
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
|
||||
: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
|
||||
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
|
||||
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
|
||||
|
||||
: CDQ ( -- ) HEX: 99 , ;
|
||||
: CQO ( -- ) HEX: 48 , CDQ ;
|
||||
|
||||
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
|
||||
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
|
||||
: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
|
||||
: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
|
||||
: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
|
||||
: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
|
||||
: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
|
||||
|
||||
GENERIC: IMUL2 ( dst src -- )
|
||||
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
|
||||
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
|
||||
|
||||
: MOVSX ( dst src -- )
|
||||
dup register-32? OCT: 143 OCT: 276 extended-opcode ?
|
||||
over register-16? [ BIN: 1 opcode-or ] when
|
||||
swapd
|
||||
(2-operand) ;
|
||||
|
||||
! Conditional move
|
||||
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
|
||||
|
||||
: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
|
||||
: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
|
||||
: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
|
||||
: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
|
||||
: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
|
||||
: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
|
||||
: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
|
||||
: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
|
||||
: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
|
||||
: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
|
||||
: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
|
||||
: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
|
||||
: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
|
||||
: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
|
||||
: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
|
||||
: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
|
||||
|
||||
! CPU Identification
|
||||
|
||||
: CPUID ( -- ) HEX: a2 extended-opcode, ;
|
||||
|
||||
! x87 Floating Point Unit
|
||||
|
||||
: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
|
||||
: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
|
||||
|
||||
: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
|
||||
: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
|
||||
|
||||
! SSE multimedia instructions
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: direction-bit-sse ( dst src op1 -- dst' src' op1' )
|
||||
pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
|
||||
|
||||
: 2-operand-sse ( dst src op1 op2 -- )
|
||||
, direction-bit-sse extended-opcode (2-operand) ;
|
||||
|
||||
: 2-operand-int/sse ( dst src op1 op2 -- )
|
||||
, swapd extended-opcode (2-operand) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
|
||||
: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
|
||||
: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
|
||||
: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
|
||||
: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
|
||||
: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
|
||||
: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
|
||||
: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
|
||||
: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
|
||||
|
||||
: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
|
||||
: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
|
||||
|
||||
: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
|
||||
: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
|
||||
: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;
|
||||
Loading…
Reference in New Issue