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

Merge branch 'master' into couchdb

db4
Alex Chapman 2008-09-18 10:17:01 +10:00
parent ec9004ab8a 608ba27202
commit 1b75b0d654
15 changed files with 779 additions and 615 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

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

@ -115,6 +115,7 @@ ERROR: no-vocab vocab ;
{ "seq3" sequence } { "seq4" sequence }
{ "seq1'" sequence } { "seq2'" sequence }
{ "newseq" sequence }
{ "seq'" sequence }
{ "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
{ "assoc3" assoc } { "newassoc" assoc }
{ "alist" "an array of key/value pairs" }

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

@ -3,271 +3,6 @@ sequences.private vectors strings kernel math.order layouts
quotations ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
$nl
"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
$nl
"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
$nl
"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
{ $subsection sequence }
{ $subsection sequence? }
"All sequences must know their length:"
{ $subsection length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection nth }
{ $subsection nth-unsafe }
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection set-nth }
{ $subsection set-nth-unsafe }
"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
{ $subsection immutable }
"The following two generic words are optional, as not all sequences are resizable:"
{ $subsection set-length }
{ $subsection lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "sequences-integers" "Integer sequences and counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
{ $subsection first }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
{ $see-also nth peek } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection repetition }
{ $subsection <repetition> }
"Reversing a sequence:"
{ $subsection reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection prepend }
{ $subsection 3append }
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
{ $subsection pad-left }
{ $subsection pad-right } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice }
{ $subsection slice? }
"Creating slices:"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection each }
{ $subsection each-index }
{ $subsection reduce }
{ $subsection interleave }
{ $subsection replicate }
{ $subsection replicate-as }
"Mapping:"
{ $subsection map }
{ $subsection map-as }
{ $subsection map-index }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection empty? }
"Testing indices:"
{ $subsection bounds-check? }
"Testing if a sequence contains an object:"
{ $subsection member? }
{ $subsection memq? }
"Testing if a sequence contains a subsequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
{ $subsection index-from }
{ $subsection last-index }
{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
{ $subsection find-from }
{ $subsection find-last }
{ $subsection find-last-from } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
{ $subsection trim-left }
{ $subsection trim-right }
"Potentially more efficient trim:"
{ $subsection trim-slice }
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
"In-place variant of " { $link reverse } ":"
{ $subsection reverse-here }
"In-place variant of " { $link append } ":"
{ $subsection push-all }
"In-place variant of " { $link remove } ":"
{ $subsection delete }
"In-place variant of " { $link map } ":"
{ $subsection change-each }
"Changing elements:"
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $emphasis "virtual sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
{ $subsection "sequences-add-remove" }
{ $subsection "sequences-appending" }
{ $subsection "sequences-slices" }
{ $subsection "sequences-reshape" }
{ $subsection "sequences-tests" }
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
ABOUT: "sequences"
HELP: sequence
{ $class-description "A mixin class whose instances are sequences. Custom implementations of the sequence protocol should be declared as instances of this mixin for all sequence functionality to work correctly:"
{ $code "INSTANCE: my-sequence sequence" }
@ -305,6 +40,18 @@ $nl
"Throws an error if the sequence cannot hold elements of the given type." }
{ $side-effects "seq" } ;
HELP: nths
{ $values
{ "indices" sequence } { "seq" sequence }
{ "seq'" sequence } }
{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 0 2 } { \"a\" \"b\" \"c\" } nths ."
"{ \"a\" \"c\" }"
}
} ;
HELP: immutable
{ $values { "seq" sequence } }
{ $description "Throws an " { $link immutable } " error." }
@ -514,6 +261,15 @@ HELP: reduce
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
} ;
HELP: reduce-index
{ $values
{ "seq" sequence } { "identity" object } { "quot" quotation } }
{ $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 50 90 } 0 [ + + ] reduce-index ."
"153"
} } ;
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
@ -840,7 +596,8 @@ HELP: reverse
HELP: <reversed> ( seq -- reversed )
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
{ $description "Creates an instance of the " { $link reversed } " virtual sequence." } ;
{ $description "Creates an instance of the " { $link reversed } " class." }
{ $see-also "virtual-sequences" } ;
HELP: slice-error
{ $values { "str" "a reason" } }
@ -1030,7 +787,7 @@ HELP: tail?
{ delete-nth remove delete } related-words
HELP: cut-slice
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before" sequence } { "after" "a slice" } }
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } " and has the same type, while " { $snippet "after" } " is a slice of the remaining elements." }
{ $notes "Unlike " { $link cut } ", the run time of this word is proportional to the length of " { $snippet "before" } ", not " { $snippet "after" } ", so it is suitable for use in an iterative algorithm which cuts successive pieces off a sequence." } ;
@ -1067,7 +824,7 @@ HELP: unclip
} ;
HELP: unclip-slice
{ $values { "seq" sequence } { "rest" slice } { "first" object } }
{ $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
HELP: unclip-last
@ -1078,7 +835,7 @@ HELP: unclip-last
} ;
HELP: unclip-last-slice
{ $values { "seq" sequence } { "butlast" slice } { "last" object } }
{ $values { "seq" sequence } { "butlast-slice" slice } { "last" object } }
{ $description "Outputs a head sequence and the last element of " { $snippet "seq" } "; the head sequence consists of all elements of " { $snippet "seq" } " but the last Unlike " { $link unclip-last } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
HELP: sum
@ -1309,3 +1066,452 @@ HELP: partition
"{ 2 4 }\n{ 1 3 5 }"
}
} ;
HELP: virtual-seq
{ $values
{ "seq" sequence }
{ "seq'" sequence } }
{ $description "Part of the virtual sequence protocol, this word is used to return an underlying array from which to look up a value at an index given by " { $link virtual@ } "." } ;
HELP: virtual@
{ $values
{ "n" integer } { "seq" sequence }
{ "n'" integer } { "seq'" sequence } }
{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
HELP: 2change-each
{ $values
{ "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." }
{ $examples { $example "USING: kernel math sequences prettyprint ;"
"{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ."
"{ 70 90 110 }"
} } ;
HELP: 2map-reduce
{ $values
{ "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
{ "result" object } }
{ $description "Unclips the first element of each sequence and calls " { $snippet "map-quot" } " on both objects. The result of this calculation is passed, along with the rest of both sequences, to " { $link 2reduce } ", with the computed object as the identity." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 30 50 } { 200 400 600 } [ + ] [ + ] 2map-reduce ."
"1290"
} } ;
HELP: 2pusher
{ $values
{ "quot" quotation }
{ "quot" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
HELP: 2reverse-each
{ $values
{ "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
{ $description "Reverse the sequences using the " { $link <reversed> } " word and calls " { $link 2each } " on the reversed sequences." }
{ $examples { $example "USING: sequences math prettyprint ;"
"{ 10 20 30 } { 1 2 3 } [ + . ] 2reverse-each"
"33\n22\n11"
} } ;
HELP: 2unclip-slice
{ $values
{ "seq1" sequence } { "seq2" sequence }
{ "rest-slice1" sequence } { "rest-slice2" sequence } { "first1" object } { "first2" object } }
{ $description "Unclips the first element of each sequence and leaves two slice elements and the two unclipped objects on the stack." }
{ $examples { $example "USING: sequences prettyprint kernel arrays ;"
"{ 1 2 } { 3 4 } 2unclip-slice 4array [ . ] each"
"T{ slice { from 1 } { to 2 } { seq { 1 2 } } }\nT{ slice { from 1 } { to 2 } { seq { 3 4 } } }\n1\n3"
} } ;
HELP: accumulator
{ $values
{ "quot" quotation }
{ "quot'" quotation } { "vec" vector } }
{ $description "Creates a new quotation that pushes its result to a vector and outputs that vector on the stack." }
{ $examples { $example "USING: sequences prettyprint kernel math ;"
"{ 1 2 } [ 30 + ] accumulator [ each ] dip ."
"V{ 31 32 }"
} } ;
HELP: binary-reduce
{ $values
{ "seq" sequence } { "start" integer } { "quot" quotation }
{ "value" object } }
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
{ $example "USING: prettyprint sequences math ;"
"40 rest-slice 1 [ * ] binary-reduce ."
"20397882081197443358640281739902897356800000000" }
} ;
HELP: follow
{ $values
{ "obj" object } { "quot" quotation }
{ "seq" sequence } }
{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
{ $examples "Get random numbers until zero is reached:"
{ $unchecked-example
"USING: random sequences prettyprint math ;"
"100 [ random dup zero? [ drop f ] when ] follow ."
"{ 100 86 34 32 24 11 7 2 }"
} } ;
HELP: halves
{ $values
{ "seq" sequence }
{ "first-slice" slice } { "second-slice" slice } }
{ $description "Splits a sequence into two slices at the midpoint. If the sequence has an odd number of elements, the extra element is returned in the second slice." }
{ $examples { $example "USING: arrays sequences prettyprint kernel ;"
"{ 1 2 3 4 5 } halves [ >array . ] bi@"
"{ 1 2 }\n{ 3 4 5 }"
} } ;
HELP: indices
{ $values
{ "obj" object } { "seq" sequence }
{ "indices" sequence } }
{ $description "Compares the input object to every element in the sequence and returns a vector containing the index of every position where the element was found." }
{ $examples { $example "USING: sequences prettyprint ;"
"2 { 2 4 2 6 2 8 2 10 } indices ."
"V{ 0 2 4 6 }"
} } ;
HELP: insert-nth
{ $values
{ "elt" object } { "n" integer } { "seq" sequence }
{ "seq'" sequence } }
{ $description "Creates a new sequence where the " { $snippet "n" } "th index is set to the input object." }
{ $examples { $example "USING: prettyprint sequences ;"
"40 3 { 10 20 30 50 } insert-nth ."
"{ 10 20 30 40 50 }"
} } ;
HELP: map-reduce
{ $values
{ "seq" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
{ "result" object } }
{ $description "Unclips the first element of the sequence, calls " { $snippet "map-quot" } " on that element, and proceeds like a " { $link reduce } ", where the calculated element is the identity element and the rest of the sequence is the sequence to reduce." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 1 3 5 } [ sq ] [ + ] map-reduce ."
"35"
} } ;
HELP: new-like
{ $values
{ "len" integer } { "exemplar" "an exemplar sequence" } { "quot" quotation }
{ "seq" sequence } }
{ $description "Creates a new sequence of length " { $snippet "len" } " and calls the quotation with this sequence on the stack. The output of the quotation and the original exemplar are then passed to " { $link like } " so that the output sequence is the exemplar's type." } ;
HELP: push-either
{ $values
{ "elt" object } { "quot" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Pushes the input object onto one of the accumualators; the first if the quotation yields true, the second if false." } ;
HELP: sequence-hashcode
{ $values
{ "n" integer } { "seq" sequence }
{ "x" integer } }
{ $description "Iterates over a sequence, computes a hashcode with " { $link hashcode* } " for each element, and combines them using " { $link sequence-hashcode-step } "." } ;
HELP: sequence-hashcode-step
{ $values
{ "oldhash" integer } { "newpart" integer }
{ "newhash" integer } }
{ $description "An implementation word that computes a running hashcode of a sequence using some bit-twiddling. The resulting hashcode is always a fixnum." } ;
HELP: short
{ $values
{ "seq" sequence } { "n" integer }
{ "seq" sequence } { "n'" integer } }
{ $description "Returns the input sequence and its length or " { $snippet "n" } ", whichever is less." }
{ $examples { $example "USING: sequences kernel prettyprint ;"
"\"abcd\" 3 short [ . ] bi@"
"\"abcd\"\n3"
} } ;
HELP: shorten
{ $values
{ "n" integer } { "seq" sequence } }
{ $description "Shortens a " { $link "growable" } " sequence to by " { $snippet "n" } " elements long." }
{ $examples { $example "USING: sequences prettyprint kernel ;"
"V{ 1 2 3 4 5 } 3 over shorten ."
"V{ 1 2 3 }"
} } ;
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
$nl
"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
$nl
"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
$nl
"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
ARTICLE: "sequence-protocol" "Sequence protocol"
"All sequences must be instances of a mixin class:"
{ $subsection sequence }
{ $subsection sequence? }
"All sequences must know their length:"
{ $subsection length }
"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection nth }
{ $subsection nth-unsafe }
"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
{ $subsection set-nth }
{ $subsection set-nth-unsafe }
"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
{ $subsection immutable }
"The following two generic words are optional, as not all sequences are resizable:"
{ $subsection set-length }
{ $subsection lengthen }
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
{ $subsection length }
"The underlying sequence to look up a value in:"
{ $subsection virtual-seq }
"The index of the value in the underlying sequence:"
{ $subsection virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
$nl
"One current limitation of the virtual sequence protocol is that sequences must be indexed starting at zero." ;
ARTICLE: "sequences-integers" "Integer sequences and counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Concise way of extracting one of the first four elements:"
{ $subsection first }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
{ $see-also nth peek } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection repetition }
{ $subsection <repetition> }
"Reversing a sequence:"
{ $subsection reverse }
"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection prepend }
{ $subsection 3append }
{ $subsection concat }
{ $subsection join }
"A pair of words useful for aligning strings:"
{ $subsection pad-left }
{ $subsection pad-right } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice }
{ $subsection slice? }
"Creating slices:"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection each }
{ $subsection each-index }
{ $subsection reduce }
{ $subsection interleave }
{ $subsection replicate }
{ $subsection replicate-as }
"Mapping:"
{ $subsection map }
{ $subsection map-as }
{ $subsection map-index }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection contains? }
{ $subsection all? }
"Testing how elements are related:"
{ $subsection monotonic? }
{ $subsection "sequence-2combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection empty? }
"Testing indices:"
{ $subsection bounds-check? }
"Testing if a sequence contains an object:"
{ $subsection member? }
{ $subsection memq? }
"Testing if a sequence contains a subsequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
"Testing how elements are related:"
{ $subsection all-eq? }
{ $subsection all-equal? } ;
ARTICLE: "sequences-search" "Searching sequences"
"Finding the index of an element:"
{ $subsection index }
{ $subsection index-from }
{ $subsection last-index }
{ $subsection last-index-from }
"Finding the start of a subsequence:"
{ $subsection start }
{ $subsection start* }
"Finding the index of an element satisfying a predicate:"
{ $subsection find }
{ $subsection find-from }
{ $subsection find-last }
{ $subsection find-last-from } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
{ $subsection trim-left }
{ $subsection trim-right }
"Potentially more efficient trim:"
{ $subsection trim-slice }
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
"In-place variant of " { $link reverse } ":"
{ $subsection reverse-here }
"In-place variant of " { $link append } ":"
{ $subsection push-all }
"In-place variant of " { $link remove } ":"
{ $subsection delete }
"In-place variant of " { $link map } ":"
{ $subsection change-each }
"Changing elements:"
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
"Element equality testing:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
{ $subsection "sequences-add-remove" }
{ $subsection "sequences-appending" }
{ $subsection "sequences-slices" }
{ $subsection "sequences-reshape" }
{ $subsection "sequences-tests" }
{ $subsection "sequences-search" }
{ $subsection "sequences-comparing" }
{ $subsection "sequences-split" }
{ $subsection "grouping" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
ABOUT: "sequences"

30
core/sequences/sequences.factor
View File

@ -289,6 +289,8 @@ M: immutable-sequence clone-like like ;
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
<PRIVATE
: ((append)) ( seq1 seq2 accum -- accum )
[ >r over length r> copy ]
[ 0 swap copy ]
@ -304,6 +306,8 @@ M: immutable-sequence clone-like like ;
[ ((append)) ] bi
] new-like ; inline
PRIVATE>
: append ( seq1 seq2 -- newseq ) over (append) ;
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
@ -402,7 +406,7 @@ PRIVATE>
: 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline
: 2change-each ( seq1 seq2 quot -- newseq )
: 2change-each ( seq1 seq2 quot -- )
pick 2map-into ; inline
: 2all? ( seq1 seq2 quot -- ? )
@ -543,6 +547,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
2over number=
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
<PRIVATE
: (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [
3dup move
@ -550,6 +556,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
] when ;
PRIVATE>
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
: prefix ( seq elt -- newseq )
@ -568,6 +576,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
<PRIVATE
: move-backward ( shift from to seq -- )
2over number= [
2drop 2drop
@ -591,6 +601,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
>r >r over - r> r> move-backward
] if ;
PRIVATE>
: open-slice ( shift from seq -- )
pick zero? [
3drop
@ -650,9 +662,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
first like
] if-empty ;
<PRIVATE
: joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ;
PRIVATE>
: join ( seq glue -- newseq )
[
2dup joined-length over new-resizable spin
@ -671,7 +687,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: pad-right ( seq n elt -- padded )
[ append ] padding ;
: shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
: shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
: head? ( seq begin -- ? )
2dup shorter? [
@ -687,7 +703,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
tuck length tail-slice* sequence=
] if ;
: cut-slice ( seq n -- before after )
: cut-slice ( seq n -- before-slice after-slice )
[ head-slice ] [ tail-slice ] 2bi ;
: insert-nth ( elt n seq -- seq' )
@ -695,7 +711,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: midpoint@ ( seq -- n ) length 2/ ; inline
: halves ( seq -- first second )
: halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
@ -749,10 +765,10 @@ PRIVATE>
: unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
: unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first ] bi ; inline
: 2unclip-slice ( seq1 seq2 -- seq1' seq2' elt1 elt2 )
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline
: map-reduce ( seq map-quot reduce-quot -- result )
@ -763,7 +779,7 @@ PRIVATE>
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
: unclip-last-slice ( seq -- butlast last )
: unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline
: <flat-slice> ( seq -- slice )

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

@ -684,7 +684,3 @@ HELP: call-next-method
{ POSTPONE: call-next-method (call-next-method) next-method } related-words
{ POSTPONE: << POSTPONE: >> } related-words
HELP: B
{ $syntax "B" }
{ $description "Inserts a breakpoint at parse-time. Useful for debugging." } ;

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

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
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 ;
classes alien byte-arrays combinators words ;
IN: compiler.backend
! Labels
@ -30,7 +29,7 @@ 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 -- )
GENERIC# load-literal 1 ( obj reg -- )
HOOK: load-indirect cpu ( obj reg -- )
@ -52,10 +51,10 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-f cpu ( label vreg -- )
HOOK: %jump-f cpu ( label reg -- )
! Test if vreg is 't' or not
HOOK: %jump-t cpu ( label vreg -- )
HOOK: %jump-t cpu ( label reg -- )
HOOK: %dispatch cpu ( -- )
@ -71,10 +70,10 @@ HOOK: %inc-d cpu ( n -- )
HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
HOOK: %peek cpu ( vreg loc -- )
HOOK: %peek cpu ( reg loc -- )
! Store vreg to stack
HOOK: %replace cpu ( vreg loc -- )
HOOK: %replace cpu ( reg loc -- )
! Copy values between vregs
HOOK: %copy cpu ( dst src -- )
@ -148,21 +147,11 @@ 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 ;
M: object load-literal load-indirect ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip
@ -194,30 +183,10 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! Allocation
HOOK: %allot cpu ( dst size type tag temp -- )
HOOK: %write-barrier cpu ( src temp -- )
! 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

20
unfinished/compiler/backend/x86/sse2/sse2.factor
View File

@ -2,27 +2,24 @@
! 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 ;
words math.floats.private layouts quotations locals cpu.x86
compiler.codegen 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 -- )
M:: x86 %box-float ( dst src temp -- )
#! 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 ;
dst 16 float float temp %allot
dst 8 float tag-number - [+] src MOVSD ;
M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
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 ;
{
@ -65,7 +62,6 @@ M: x86 %unbox-float ( dst src -- )
{ scratch { { float "out" } } }
{ output { "out" } }
{ clobber { "in" } }
{ gc t }
} define-intrinsic
: alien-float-get-template

290
unfinished/compiler/backend/x86/x86.factor
View File

@ -4,20 +4,12 @@ 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
cpu.x86.private locals compiler.backend compiler.codegen.fixup
compiler.constants compiler.intrinsics compiler.cfg.builder
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.templates ;
compiler.cfg.templates compiler.codegen ;
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 )
@ -27,8 +19,10 @@ HOOK: stack-save-reg cpu ( -- reg )
: 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 ;
GENERIC: loc>operand ( loc -- operand )
M: ds-loc loc>operand n>> ds-reg reg-stack ;
M: rs-loc loc>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 ;
@ -54,10 +48,10 @@ HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
M: f load-literal
v>operand \ f tag-number MOV drop ;
\ f tag-number MOV drop ;
M: fixnum load-literal
v>operand swap tag-fixnum MOV ;
swap tag-fixnum MOV ;
M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
@ -99,16 +93,16 @@ M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch ( -- )
M:: x86 %dispatch ( src temp -- )
! 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@
src 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
temp HEX: ffffffff MOV rc-absolute-cell rel-here
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
@ -117,9 +111,9 @@ M: x86 %dispatch ( -- )
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86 %peek loc>operand MOV ;
M: x86 %replace swap %peek ;
M: x86 %replace loc>operand swap MOV ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
@ -146,13 +140,13 @@ M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
byte-array-offset [+] LEA ;
M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
alien-offset [+] MOV ;
M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
drop 0 MOV ;
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
@ -161,7 +155,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
rs-reg swap v>operand MOV
rs-reg swap MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
@ -182,34 +176,45 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
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 ;
M:: x86 %write-barrier ( src temp -- )
#! Mark the card pointed to by vreg.
! Mark the card
src card-bits SHR
"cards_offset" f temp %alien-global
temp temp [+] card-mark <byte> MOV
: (object@) ( n -- operand ) allot-reg swap [+] ;
: object@ ( n -- operand ) cells (object@) ;
! Mark the card deck
temp deck-bits card-bits - SHR
"decks_offset" f temp %alien-global
temp temp [+] card-mark <byte> MOV ;
: 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 ;
: load-allot-ptr ( temp -- )
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
: inc-allot-ptr ( n -- )
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
: inc-allot-ptr ( n temp -- )
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
: store-header ( temp type -- )
[ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst temp tag -- )
dupd tag-number OR MOV ;
M:: x86 %allot ( dst size type tag temp -- )
temp load-allot-ptr
temp type store-header
temp size inc-allot-ptr
dst temp store-tagged ;
M: x86 %gc ( -- )
"end" define-label
@ -223,73 +228,53 @@ M: x86 %gc ( -- )
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;
: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
: %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 -- )
:: %allot-bignum-signed-1 ( dst src temp -- )
#! 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?
{ "end" "nonzero" "positive" "store" } [ define-label ] each
src 0 CMP ! is it zero?
"nonzero" get JNE
0 >bignum pick v>operand load-indirect ! this is our result
! Use cached zero value
0 >bignum dst load-indirect
"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
! Allocate a bignum
dst 4 cells bignum bignum temp %allot
! Write length
dst 1 bignum@ 2 MOV
! Test sign
src 0 CMP
"positive" get JGE
dst 2 bignum@ 1 MOV ! negative sign
src NEG
"store" get JMP
"positive" resolve-label
dst 2 bignum@ 0 MOV ! positive sign
"store" resolve-label
dst 3 bignum@ src MOV
"end" resolve-label
] with-scope ;
M: x86 %box-alien ( dst src -- )
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
src 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
dst 4 cells alien object temp %allot
dst 1 alien@ \ f tag-number MOV
dst 2 alien@ \ f tag-number MOV
! Store src in alien-offset slot
dst 3 alien@ src MOV
"end" get JMP
"f" resolve-label
f [ v>operand ] bi@ MOV
\ f tag-number MOV
"end" resolve-label
] with-scope ;
@ -321,7 +306,7 @@ M: x86 %box-alien ( dst src -- )
! 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" } } }
{ input { { f "obj" known-tag } { small-slot "n" } } }
{ scratch { { f "val" } } }
{ output { "val" } }
}
@ -329,7 +314,7 @@ M: x86 %box-alien ( dst src -- )
! Slot number is literal
{
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
{ input { { f "obj" } { [ small-slot? ] "n" } } }
{ input { { f "obj" } { small-slot "n" } } }
{ output { "obj" } }
}
}
@ -343,40 +328,26 @@ M: x86 %box-alien ( dst src -- )
}
} 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 {
\ (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" } } }
[ %slot-literal-known-tag "val" operand MOV ] 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" } } }
[ %slot-literal-any-tag "val" operand MOV ] 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
[ %slot-any "val" operand MOV ] T{ template
{ input { { f "val" } { f "obj" } { f "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" "n" } }
@ -400,7 +371,7 @@ M: x86 %box-alien ( dst src -- )
: fixnum-value-op ( op -- pair )
T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ input { { f "x" } { small-tagged "y" } } }
{ output { "x" } }
} fixnum-op ;
@ -476,7 +447,7 @@ M: x86 %box-alien ( dst src -- )
! 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
"z" operand "x" operand "y" operand %allot-bignum-signed-1
"end" resolve-label ; inline
: overflow-template ( word insn -- )
@ -516,9 +487,10 @@ M: x86 %box-alien ( dst src -- )
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" get dup %allot-bignum-signed-1
"x" operand dup "scratch" operand %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ scratch { { f "scratch" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic
@ -531,7 +503,7 @@ M: x86 %box-alien ( dst src -- )
"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
"y" operand 1 tag-fixnum CMP
"nonzero" get JNE
"y" operand 0 MOV
"end" get JMP
@ -577,90 +549,6 @@ M: x86 %box-alien ( dst src -- )
{ 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

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

@ -1,7 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words stack-checker.inlining
math fry namespaces make sequences words byte-arrays
locals layouts
stack-checker.inlining
compiler.intrinsics
compiler.tree
compiler.tree.builder
compiler.tree.combinators
@ -142,8 +145,7 @@ M: #recursive emit-node
children>> [ emit-nodes ] emit-branches ;
M: #if emit-node
{ { f "flag" } } lazy-load first ##branch-t
emit-if iterate-next ;
phantom-pop ##branch-t emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
@ -167,7 +169,9 @@ M: #if emit-node
] each ;
: emit-dispatch ( node -- )
##epilogue ##dispatch dispatch-branches init-phantoms ;
phantom-pop int-regs next-vreg
[ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
dispatch-branches init-phantoms ;
M: #dispatch emit-node
tail-call? [
@ -225,12 +229,45 @@ M: #dispatch emit-node
: setup-value-classes ( #call -- )
node-input-infos [ class>> ] map set-value-classes ;
{
(tuple) (array) (byte-array)
(complex) (ratio) (wrapper)
(write-barrier)
} [ t "intrinsic" set-word-prop ] each
: allot-size ( #call -- n )
1 phantom-datastack get phantom-input first value>> ;
:: emit-allot ( size type tag -- )
int-regs next-vreg
dup fresh-object
dup size type tag int-regs next-vreg ##allot
type tagged boa phantom-push ;
: emit-write-barrier ( -- )
phantom-pop dup >vreg fresh-object? [ drop ] [
int-regs next-vreg ##write-barrier
] if ;
: emit-intrinsic ( word -- next )
{
{ \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
{ \ (array) [ allot-size 2 cells + array object emit-allot ] }
{ \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
{ \ (complex) [ 3 cells complex complex emit-allot ] }
{ \ (ratio) [ 3 cells ratio ratio emit-allot ] }
{ \ (wrapper) [ 2 cells wrapper object emit-allot ] }
{ \ (write-barrier) [ emit-write-barrier ] }
} case
iterate-next ;
M: #call emit-node
dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
word>> emit-call
word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ emit-call ] if
] ?if
] ?if
] ?if ;

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

@ -27,7 +27,7 @@ INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
INSN: ##dispatch-label label ;
INSN: ##dispatch ;
INSN: ##dispatch src temp ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
@ -37,9 +37,12 @@ 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: ##box-float < ##unary temp ;
INSN: ##box-alien < ##unary temp ;
! Memory allocation
INSN: ##allot < ##nullary size type tag temp ;
INSN: ##write-barrier src temp ;
INSN: ##gc ;
! FFI
@ -52,10 +55,21 @@ GENERIC: uses-vregs ( insn -- seq )
M: ##nullary defs-vregs dst>> >vreg 1array ;
M: ##unary defs-vregs dst>> >vreg 1array ;
M: ##write-barrier defs-vregs temp>> >vreg 1array ;
: allot-defs-vregs ( insn -- seq )
[ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
M: ##box-float defs-vregs allot-defs-vregs ;
M: ##box-alien defs-vregs allot-defs-vregs ;
M: ##allot defs-vregs allot-defs-vregs ;
M: ##dispatch defs-vregs temp>> >vreg 1array ;
M: insn defs-vregs drop f ;
M: ##replace uses-vregs src>> >vreg 1array ;
M: ##unary uses-vregs src>> >vreg 1array ;
M: ##write-barrier uses-vregs src>> >vreg 1array ;
M: ##dispatch uses-vregs src>> >vreg 1array ;
M: insn uses-vregs drop f ;
: intrinsic-vregs ( assoc -- seq' )

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

@ -28,6 +28,7 @@ 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 -- )

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

@ -3,18 +3,12 @@
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math fry namespaces
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order compiler.cfg.instructions
compiler.cfg.registers ;
byte-arrays accessors sets math.order compiler.backend
compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stacks
! Converting stack operations into register operations, while
! doing a bit of optimization along the way.
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
@ -100,6 +94,14 @@ M: constant move-spec class ;
swap >>class
%move ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
: fresh-object ( vreg/t -- ) fresh-objects get push ;
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ ##copy ] }
@ -114,8 +116,8 @@ M: constant move-spec class ;
{ { f constant } [ value>> ##load-literal ] }
{ { f float } [ ##box-float ] }
{ { f unboxed-alien } [ ##box-alien ] }
{ { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
{ { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
{ { f loc } [ ##peek ] }
{ { float f } [ ##unbox-float ] }
@ -223,10 +225,6 @@ M: phantom-retainstack finalize-height
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
@ -255,7 +253,7 @@ SYMBOL: fresh-objects
M: value (lazy-load)
{
{ [ dup quotation? ] [ drop ] }
{ [ dup { small-slot small-tagged } memq? ] [ drop ] }
{ [ 2dup compatible? ] [ drop ] }
[ (eager-load) ]
} cond ;
@ -280,23 +278,11 @@ M: loc lazy-store
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: reset-phantom ( phantom -- )
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
value-class over set-value-class
] if
] 2map
over stack>> delete-all
swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
finalize-locs finalize-vregs clear-phantoms ;
! Loading stacks to vregs
: vreg-substitution ( value vreg -- pair )
@ -312,26 +298,22 @@ M: loc lazy-store
[ substitute-vreg? ] assoc-filter >hashtable
'[ stack>> _ substitute-here ] each-phantom ;
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-value-class ] 2reverse-each ;
stack>> [
[ value-class class-and ] keep set-value-class
] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
fresh-objects get [
empty? [ 0 ##frame-required ##gc ] unless
] [ delete-all ] bi ;
: init-phantoms ( -- )
V{ } clone fresh-objects set
@ -364,3 +346,7 @@ M: loc lazy-store
: phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ;
: phantom-pop ( -- vreg )
1 phantom-datastack get phantom-input dup first f (lazy-load)
[ 1array substitute-vregs ] keep ;

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

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors sequences kernel fry namespaces
quotations combinators classes.algebra compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stacks ;
quotations combinators classes.algebra compiler.backend
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
TUPLE: template input output scratch clobber gc ;
@ -57,7 +57,9 @@ TUPLE: template input output scratch clobber gc ;
: apply-template ( pair quot -- vregs )
[
first2 dup do-template-inputs
first2
dup gc>> [ t fresh-object ] when
dup do-template-inputs
[ do-template-outputs ] 2keep
] dip call ; inline
@ -67,12 +69,11 @@ TUPLE: template input output scratch clobber gc ;
#! to the fixnum. Otherwise, the values don't match. If the
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
dup quotation? [
over constant?
[ >r value>> r> 2drop f ] [ 2drop f ] if
] [
2drop t
] if ;
{
{ [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
{ [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
[ 2drop t ]
} cond ;
: class-matches? ( actual expected -- ? )
{

84
unfinished/compiler/codegen/codegen.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
threads continuations.private libc combinators
alien alien.c-types alien.structs alien.strings
combinators classes.algebra alien alien.c-types alien.structs
alien.strings sets threads libc continuations.private
compiler.errors
compiler.alien
compiler.backend
@ -15,6 +15,16 @@ IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
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* ;
: generate-insns ( insns -- code )
[
[
@ -66,11 +76,14 @@ M: _prologue generate-insn
M: _epilogue generate-insn
n>> %epilogue ;
M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
M: ##peek generate-insn
[ dst>> v>operand ] [ loc>> ] bi %peek ;
M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
M: ##replace generate-insn
[ src>> ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
@ -82,9 +95,32 @@ M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
SYMBOL: operands
: init-intrinsic ( insn -- )
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
M: ##intrinsic generate-insn
[ init-intrinsic ] [ quot>> call ] bi ;
: (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 ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
M: _if-intrinsic generate-insn
[ init-intrinsic ]
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
@ -93,32 +129,48 @@ M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-f ;
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-t ;
[ src>> v>operand ] [ 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 ;
: dst/src ( insn -- dst src )
[ dst>> v>operand ] [ src>> v>operand ] bi ;
M: ##copy-float generate-insn %copy-float ;
M: ##copy generate-insn dst/src %copy ;
M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
M: ##copy-float generate-insn dst/src %copy-float ;
M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
M: ##unbox-f generate-insn dst/src %unbox-f ;
M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
M: ##box-float generate-insn dst/src %box-float ;
M: ##box-alien generate-insn dst/src %box-alien ;
M: ##allot generate-insn
{
[ dst>> v>operand ]
[ size>> ]
[ type>> ]
[ tag>> ]
[ temp>> v>operand ]
} cleave
%allot ;
M: ##write-barrier generate-insn
[ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
M: ##gc generate-insn drop %gc ;