Merge branch 'master' of git://factorcode.org/git/factor
commit
32fe0d978b
|
@ -42,7 +42,7 @@ $nl
|
||||||
|
|
||||||
HELP: nths
|
HELP: nths
|
||||||
{ $values
|
{ $values
|
||||||
{ "indices" null } { "seq" sequence }
|
{ "indices" sequence } { "seq" sequence }
|
||||||
{ "seq'" sequence } }
|
{ "seq'" sequence } }
|
||||||
{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
|
{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -264,7 +264,7 @@ HELP: reduce
|
||||||
HELP: reduce-index
|
HELP: reduce-index
|
||||||
{ $values
|
{ $values
|
||||||
{ "seq" sequence } { "identity" object } { "quot" quotation } }
|
{ "seq" sequence } { "identity" object } { "quot" quotation } }
|
||||||
{ $description "Combines successive elements of the sequence and their indices using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
|
{ $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 ;"
|
{ $examples { $example "USING: sequences prettyprint math ;"
|
||||||
"{ 10 50 90 } 0 [ + + ] reduce-index ."
|
"{ 10 50 90 } 0 [ + + ] reduce-index ."
|
||||||
"153"
|
"153"
|
||||||
|
@ -596,7 +596,8 @@ HELP: reverse
|
||||||
|
|
||||||
HELP: <reversed> ( seq -- reversed )
|
HELP: <reversed> ( seq -- reversed )
|
||||||
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
|
{ $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
|
HELP: slice-error
|
||||||
{ $values { "str" "a reason" } }
|
{ $values { "str" "a reason" } }
|
||||||
|
@ -786,7 +787,7 @@ HELP: tail?
|
||||||
{ delete-nth remove delete } related-words
|
{ delete-nth remove delete } related-words
|
||||||
|
|
||||||
HELP: cut-slice
|
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." }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
||||||
|
@ -823,7 +824,7 @@ HELP: unclip
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: unclip-slice
|
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." } ;
|
{ $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
|
HELP: unclip-last
|
||||||
|
@ -834,7 +835,7 @@ HELP: unclip-last
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: unclip-last-slice
|
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." } ;
|
{ $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
|
HELP: sum
|
||||||
|
@ -1078,6 +1079,165 @@ HELP: virtual@
|
||||||
{ "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 } "." } ;
|
{ $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"
|
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
|
||||||
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
|
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
|
||||||
$nl
|
$nl
|
||||||
|
@ -1113,7 +1273,7 @@ ARTICLE: "sequence-protocol" "Sequence protocol"
|
||||||
{ $subsection new-resizable }
|
{ $subsection new-resizable }
|
||||||
{ $see-also "sequences-unsafe" } ;
|
{ $see-also "sequences-unsafe" } ;
|
||||||
|
|
||||||
ARTICLE: "sequences-virtual-protocol" "Virtual sequence protocol"
|
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
|
||||||
"Virtual sequences must know their length:"
|
"Virtual sequences must know their length:"
|
||||||
{ $subsection length }
|
{ $subsection length }
|
||||||
"The underlying sequence to look up a value in:"
|
"The underlying sequence to look up a value in:"
|
||||||
|
@ -1122,7 +1282,9 @@ ARTICLE: "sequences-virtual-protocol" "Virtual sequence protocol"
|
||||||
{ $subsection virtual@ } ;
|
{ $subsection virtual@ } ;
|
||||||
|
|
||||||
ARTICLE: "virtual-sequences" "Virtual sequences"
|
ARTICLE: "virtual-sequences" "Virtual sequences"
|
||||||
"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "sequences-virtual-protocol" } "." ;
|
"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"
|
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."
|
"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."
|
||||||
|
|
|
@ -289,6 +289,8 @@ M: immutable-sequence clone-like like ;
|
||||||
|
|
||||||
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
|
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: ((append)) ( seq1 seq2 accum -- accum )
|
: ((append)) ( seq1 seq2 accum -- accum )
|
||||||
[ >r over length r> copy ]
|
[ >r over length r> copy ]
|
||||||
[ 0 swap copy ]
|
[ 0 swap copy ]
|
||||||
|
@ -304,6 +306,8 @@ M: immutable-sequence clone-like like ;
|
||||||
[ ((append)) ] bi
|
[ ((append)) ] bi
|
||||||
] new-like ; inline
|
] new-like ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: append ( seq1 seq2 -- newseq ) over (append) ;
|
: append ( seq1 seq2 -- newseq ) over (append) ;
|
||||||
|
|
||||||
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
|
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
|
||||||
|
@ -402,7 +406,7 @@ PRIVATE>
|
||||||
: 2map ( seq1 seq2 quot -- newseq )
|
: 2map ( seq1 seq2 quot -- newseq )
|
||||||
pick 2map-as ; inline
|
pick 2map-as ; inline
|
||||||
|
|
||||||
: 2change-each ( seq1 seq2 quot -- newseq )
|
: 2change-each ( seq1 seq2 quot -- )
|
||||||
pick 2map-into ; inline
|
pick 2map-into ; inline
|
||||||
|
|
||||||
: 2all? ( seq1 seq2 quot -- ? )
|
: 2all? ( seq1 seq2 quot -- ? )
|
||||||
|
@ -543,6 +547,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
2over number=
|
2over number=
|
||||||
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
|
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: (delete) ( elt store scan seq -- elt store scan seq )
|
: (delete) ( elt store scan seq -- elt store scan seq )
|
||||||
2dup length < [
|
2dup length < [
|
||||||
3dup move
|
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)
|
[ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
|
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
|
||||||
|
|
||||||
: prefix ( seq elt -- newseq )
|
: prefix ( seq elt -- newseq )
|
||||||
|
@ -568,6 +576,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
|
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: move-backward ( shift from to seq -- )
|
: move-backward ( shift from to seq -- )
|
||||||
2over number= [
|
2over number= [
|
||||||
2drop 2drop
|
2drop 2drop
|
||||||
|
@ -591,6 +601,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
>r >r over - r> r> move-backward
|
>r >r over - r> r> move-backward
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: open-slice ( shift from seq -- )
|
: open-slice ( shift from seq -- )
|
||||||
pick zero? [
|
pick zero? [
|
||||||
3drop
|
3drop
|
||||||
|
@ -650,9 +662,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
first like
|
first like
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: joined-length ( seq glue -- n )
|
: joined-length ( seq glue -- n )
|
||||||
>r dup sum-lengths swap length 1 [-] r> length * + ;
|
>r dup sum-lengths swap length 1 [-] r> length * + ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: join ( seq glue -- newseq )
|
: join ( seq glue -- newseq )
|
||||||
[
|
[
|
||||||
2dup joined-length over new-resizable spin
|
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 )
|
: pad-right ( seq n elt -- padded )
|
||||||
[ append ] padding ;
|
[ append ] padding ;
|
||||||
|
|
||||||
: shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
|
: shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
|
||||||
|
|
||||||
: head? ( seq begin -- ? )
|
: head? ( seq begin -- ? )
|
||||||
2dup shorter? [
|
2dup shorter? [
|
||||||
|
@ -687,7 +703,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
||||||
tuck length tail-slice* sequence=
|
tuck length tail-slice* sequence=
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: cut-slice ( seq n -- before after )
|
: cut-slice ( seq n -- before-slice after-slice )
|
||||||
[ head-slice ] [ tail-slice ] 2bi ;
|
[ head-slice ] [ tail-slice ] 2bi ;
|
||||||
|
|
||||||
: insert-nth ( elt n seq -- seq' )
|
: 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
|
: midpoint@ ( seq -- n ) length 2/ ; inline
|
||||||
|
|
||||||
: halves ( seq -- first second )
|
: halves ( seq -- first-slice second-slice )
|
||||||
dup midpoint@ cut-slice ;
|
dup midpoint@ cut-slice ;
|
||||||
|
|
||||||
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
|
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
|
||||||
|
@ -749,10 +765,10 @@ PRIVATE>
|
||||||
: unclip-last ( seq -- butlast last )
|
: unclip-last ( seq -- butlast last )
|
||||||
[ but-last ] [ peek ] bi ;
|
[ but-last ] [ peek ] bi ;
|
||||||
|
|
||||||
: unclip-slice ( seq -- rest first )
|
: unclip-slice ( seq -- rest-slice first )
|
||||||
[ rest-slice ] [ first ] bi ; inline
|
[ 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
|
[ unclip-slice ] bi@ swapd ; inline
|
||||||
|
|
||||||
: map-reduce ( seq map-quot reduce-quot -- result )
|
: map-reduce ( seq map-quot reduce-quot -- result )
|
||||||
|
@ -763,7 +779,7 @@ PRIVATE>
|
||||||
[ [ 2unclip-slice ] dip [ call ] keep ] dip
|
[ [ 2unclip-slice ] dip [ call ] keep ] dip
|
||||||
compose 2reduce ; inline
|
compose 2reduce ; inline
|
||||||
|
|
||||||
: unclip-last-slice ( seq -- butlast last )
|
: unclip-last-slice ( seq -- butlast-slice last )
|
||||||
[ but-last-slice ] [ peek ] bi ; inline
|
[ but-last-slice ] [ peek ] bi ; inline
|
||||||
|
|
||||||
: <flat-slice> ( seq -- slice )
|
: <flat-slice> ( seq -- slice )
|
||||||
|
|
|
@ -2,8 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs arrays generic kernel kernel.private
|
USING: accessors assocs arrays generic kernel kernel.private
|
||||||
math memory namespaces make sequences layouts system hashtables
|
math memory namespaces make sequences layouts system hashtables
|
||||||
classes alien byte-arrays combinators words sets classes.algebra
|
classes alien byte-arrays combinators words ;
|
||||||
compiler.cfg.registers compiler.cfg.instructions ;
|
|
||||||
IN: compiler.backend
|
IN: compiler.backend
|
||||||
|
|
||||||
! Labels
|
! Labels
|
||||||
|
@ -30,7 +29,7 @@ GENERIC: param-reg ( n register-class -- reg )
|
||||||
M: object param-reg param-regs nth ;
|
M: object param-reg param-regs nth ;
|
||||||
|
|
||||||
! Load a literal (immediate or indirect)
|
! Load a literal (immediate or indirect)
|
||||||
GENERIC# load-literal 1 ( obj vreg -- )
|
GENERIC# load-literal 1 ( obj reg -- )
|
||||||
|
|
||||||
HOOK: load-indirect cpu ( obj reg -- )
|
HOOK: load-indirect cpu ( obj reg -- )
|
||||||
|
|
||||||
|
@ -52,10 +51,10 @@ HOOK: %call cpu ( word -- )
|
||||||
HOOK: %jump-label cpu ( label -- )
|
HOOK: %jump-label cpu ( label -- )
|
||||||
|
|
||||||
! Test if vreg is 'f' or not
|
! 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
|
! Test if vreg is 't' or not
|
||||||
HOOK: %jump-t cpu ( label vreg -- )
|
HOOK: %jump-t cpu ( label reg -- )
|
||||||
|
|
||||||
HOOK: %dispatch cpu ( -- )
|
HOOK: %dispatch cpu ( -- )
|
||||||
|
|
||||||
|
@ -71,10 +70,10 @@ HOOK: %inc-d cpu ( n -- )
|
||||||
HOOK: %inc-r cpu ( n -- )
|
HOOK: %inc-r cpu ( n -- )
|
||||||
|
|
||||||
! Load stack into vreg
|
! Load stack into vreg
|
||||||
HOOK: %peek cpu ( vreg loc -- )
|
HOOK: %peek cpu ( reg loc -- )
|
||||||
|
|
||||||
! Store vreg to stack
|
! Store vreg to stack
|
||||||
HOOK: %replace cpu ( vreg loc -- )
|
HOOK: %replace cpu ( reg loc -- )
|
||||||
|
|
||||||
! Copy values between vregs
|
! Copy values between vregs
|
||||||
HOOK: %copy cpu ( dst src -- )
|
HOOK: %copy cpu ( dst src -- )
|
||||||
|
@ -148,21 +147,11 @@ M: stack-params param-reg drop ;
|
||||||
|
|
||||||
M: stack-params param-regs drop f ;
|
M: stack-params param-regs drop f ;
|
||||||
|
|
||||||
GENERIC: v>operand ( obj -- operand )
|
M: object load-literal load-indirect ;
|
||||||
|
|
||||||
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-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 -- ? )
|
: if-small-struct ( n size true false -- ? )
|
||||||
[ over not over struct-small-enough? and ] 2dip
|
[ 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 -- )
|
HOOK: %box-alien cpu ( dst src -- )
|
||||||
|
|
||||||
|
! Allocation
|
||||||
|
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||||
|
|
||||||
|
HOOK: %write-barrier cpu ( src temp -- )
|
||||||
|
|
||||||
! GC check
|
! GC check
|
||||||
HOOK: %gc cpu ( -- )
|
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
|
|
||||||
|
|
|
@ -2,27 +2,24 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.accessors arrays generic kernel system
|
USING: alien alien.accessors arrays generic kernel system
|
||||||
kernel.private math math.private memory namespaces sequences
|
kernel.private math math.private memory namespaces sequences
|
||||||
words math.floats.private layouts quotations cpu.x86
|
words math.floats.private layouts quotations locals cpu.x86
|
||||||
compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
|
compiler.codegen compiler.cfg.templates compiler.cfg.builder
|
||||||
compiler.constants compiler.backend compiler.backend.x86 ;
|
compiler.cfg.registers compiler.constants compiler.backend
|
||||||
|
compiler.backend.x86 ;
|
||||||
IN: compiler.backend.x86.sse2
|
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
|
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||||
#! dest is a loc or a vreg
|
dst 16 float float temp %allot
|
||||||
float 16 [
|
dst 8 float tag-number - [+] src MOVSD ;
|
||||||
8 (object@) swap v>operand MOVSD
|
|
||||||
float %store-tagged
|
|
||||||
] %allot ;
|
|
||||||
|
|
||||||
M: x86 %unbox-float ( dst src -- )
|
M: x86 %unbox-float ( dst src -- )
|
||||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
float-offset [+] MOVSD ;
|
||||||
|
|
||||||
: define-float-op ( word op -- )
|
: define-float-op ( word op -- )
|
||||||
[ "x" operand "y" operand ] swap suffix T{ template
|
[ "x" operand "y" operand ] swap suffix T{ template
|
||||||
{ input { { float "x" } { float "y" } } }
|
{ input { { float "x" } { float "y" } } }
|
||||||
{ output { "x" } }
|
{ output { "x" } }
|
||||||
{ gc t }
|
|
||||||
} define-intrinsic ;
|
} define-intrinsic ;
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -65,7 +62,6 @@ M: x86 %unbox-float ( dst src -- )
|
||||||
{ scratch { { float "out" } } }
|
{ scratch { { float "out" } } }
|
||||||
{ output { "out" } }
|
{ output { "out" } }
|
||||||
{ clobber { "in" } }
|
{ clobber { "in" } }
|
||||||
{ gc t }
|
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
: alien-float-get-template
|
: alien-float-get-template
|
||||||
|
|
|
@ -4,20 +4,12 @@ USING: accessors arrays byte-arrays alien.accessors
|
||||||
compiler.backend kernel kernel.private math memory namespaces
|
compiler.backend kernel kernel.private math memory namespaces
|
||||||
make sequences words system layouts combinators math.order
|
make sequences words system layouts combinators math.order
|
||||||
math.private alien alien.c-types slots.private cpu.x86
|
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.constants compiler.intrinsics compiler.cfg.builder
|
||||||
compiler.cfg.registers compiler.cfg.stacks
|
compiler.cfg.registers compiler.cfg.stacks
|
||||||
compiler.cfg.templates ;
|
compiler.cfg.templates compiler.codegen ;
|
||||||
IN: compiler.backend.x86
|
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: ds-reg cpu ( -- reg )
|
||||||
HOOK: rs-reg cpu ( -- reg )
|
HOOK: rs-reg cpu ( -- reg )
|
||||||
HOOK: stack-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 [+] ;
|
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||||
|
|
||||||
M: ds-loc v>operand n>> ds-reg reg-stack ;
|
GENERIC: loc>operand ( loc -- operand )
|
||||||
M: rs-loc v>operand n>> rs-reg reg-stack ;
|
|
||||||
|
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 %save-param-reg drop >r stack@ r> MOV ;
|
||||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||||
|
@ -54,10 +48,10 @@ HOOK: fixnum>slot@ cpu ( op -- )
|
||||||
HOOK: prepare-division cpu ( -- )
|
HOOK: prepare-division cpu ( -- )
|
||||||
|
|
||||||
M: f load-literal
|
M: f load-literal
|
||||||
v>operand \ f tag-number MOV drop ;
|
\ f tag-number MOV drop ;
|
||||||
|
|
||||||
M: fixnum load-literal
|
M: fixnum load-literal
|
||||||
v>operand swap tag-fixnum MOV ;
|
swap tag-fixnum MOV ;
|
||||||
|
|
||||||
M: x86 stack-frame ( n -- i )
|
M: x86 stack-frame ( n -- i )
|
||||||
3 cells + 16 align cell - ;
|
3 cells + 16 align cell - ;
|
||||||
|
@ -99,16 +93,16 @@ M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
|
||||||
: align-code ( n -- )
|
: align-code ( n -- )
|
||||||
0 <repetition> % ;
|
0 <repetition> % ;
|
||||||
|
|
||||||
M: x86 %dispatch ( -- )
|
M:: x86 %dispatch ( src temp -- )
|
||||||
! Load jump table base. We use a temporary register
|
! Load jump table base. We use a temporary register
|
||||||
! since on AMD64 we have to load a 64-bit immediate. On
|
! since on AMD64 we have to load a 64-bit immediate. On
|
||||||
! x86, this is redundant.
|
! x86, this is redundant.
|
||||||
! Untag and multiply to get a jump table offset
|
! Untag and multiply to get a jump table offset
|
||||||
temp-reg-1 fixnum>slot@
|
src fixnum>slot@
|
||||||
! Add jump table base
|
! Add jump table base
|
||||||
temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
|
temp HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||||
temp-reg-1 temp-reg-2 ADD
|
src temp ADD
|
||||||
temp-reg-1 HEX: 7f [+] JMP
|
src HEX: 7f [+] JMP
|
||||||
! Fix up the displacement above
|
! Fix up the displacement above
|
||||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||||
building get dup pop* push
|
building get dup pop* push
|
||||||
|
@ -117,9 +111,9 @@ M: x86 %dispatch ( -- )
|
||||||
M: x86 %dispatch-label ( word -- )
|
M: x86 %dispatch-label ( word -- )
|
||||||
0 cell, rc-absolute-cell rel-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 ;
|
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||||
|
|
||||||
|
@ -146,13 +140,13 @@ M: x86 %return ( -- ) 0 %unwind ;
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
M: x86 %unbox-byte-array ( dst src -- )
|
M: x86 %unbox-byte-array ( dst src -- )
|
||||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
byte-array-offset [+] LEA ;
|
||||||
|
|
||||||
M: x86 %unbox-alien ( dst src -- )
|
M: x86 %unbox-alien ( dst src -- )
|
||||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
alien-offset [+] MOV ;
|
||||||
|
|
||||||
M: x86 %unbox-f ( dst src -- )
|
M: x86 %unbox-f ( dst src -- )
|
||||||
drop v>operand 0 MOV ;
|
drop 0 MOV ;
|
||||||
|
|
||||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||||
|
@ -161,7 +155,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||||
ds-reg 0 MOV
|
ds-reg 0 MOV
|
||||||
! Object is stored in ds-reg
|
! Object is stored in ds-reg
|
||||||
rs-reg PUSH
|
rs-reg PUSH
|
||||||
rs-reg swap v>operand MOV
|
rs-reg swap MOV
|
||||||
! We come back here with displaced aliens
|
! We come back here with displaced aliens
|
||||||
"start" resolve-label
|
"start" resolve-label
|
||||||
! Is the object f?
|
! Is the object f?
|
||||||
|
@ -182,34 +176,45 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||||
ds-reg byte-array-offset ADD
|
ds-reg byte-array-offset ADD
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
! Done, store address in destination register
|
! Done, store address in destination register
|
||||||
v>operand ds-reg MOV
|
ds-reg MOV
|
||||||
! Restore rs-reg
|
! Restore rs-reg
|
||||||
rs-reg POP
|
rs-reg POP
|
||||||
! Restore ds-reg
|
! Restore ds-reg
|
||||||
ds-reg POP ;
|
ds-reg POP ;
|
||||||
|
|
||||||
: allot-reg ( -- reg )
|
M:: x86 %write-barrier ( src temp -- )
|
||||||
#! We temporarily use the datastack register, since it won't
|
#! Mark the card pointed to by vreg.
|
||||||
#! be accessed inside the quotation given to %allot in any
|
! Mark the card
|
||||||
#! case.
|
src card-bits SHR
|
||||||
ds-reg ;
|
"cards_offset" f temp %alien-global
|
||||||
|
temp temp [+] card-mark <byte> MOV
|
||||||
|
|
||||||
: (object@) ( n -- operand ) allot-reg swap [+] ;
|
! Mark the card deck
|
||||||
|
temp deck-bits card-bits - SHR
|
||||||
: object@ ( n -- operand ) cells (object@) ;
|
"decks_offset" f temp %alien-global
|
||||||
|
temp temp [+] card-mark <byte> MOV ;
|
||||||
|
|
||||||
: load-zone-ptr ( reg -- )
|
: load-zone-ptr ( reg -- )
|
||||||
#! Load pointer to start of zone array
|
#! Load pointer to start of zone array
|
||||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||||
|
|
||||||
: load-allot-ptr ( -- )
|
: load-allot-ptr ( temp -- )
|
||||||
allot-reg load-zone-ptr
|
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
|
||||||
allot-reg PUSH
|
|
||||||
allot-reg dup cell [+] MOV ;
|
|
||||||
|
|
||||||
: inc-allot-ptr ( n -- )
|
: inc-allot-ptr ( n temp -- )
|
||||||
allot-reg POP
|
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
|
||||||
allot-reg cell [+] swap 8 align ADD ;
|
|
||||||
|
: 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 ( -- )
|
M: x86 %gc ( -- )
|
||||||
"end" define-label
|
"end" define-label
|
||||||
|
@ -223,73 +228,53 @@ M: x86 %gc ( -- )
|
||||||
"minor_gc" f %alien-invoke
|
"minor_gc" f %alien-invoke
|
||||||
"end" resolve-label ;
|
"end" resolve-label ;
|
||||||
|
|
||||||
: store-header ( header -- )
|
: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
|
||||||
0 object@ swap type-number tag-fixnum MOV ;
|
|
||||||
|
|
||||||
: %allot ( header size quot -- )
|
:: %allot-bignum-signed-1 ( dst src temp -- )
|
||||||
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
|
#! on entry, inreg is a signed 32-bit quantity
|
||||||
#! exits with tagged ptr to bignum in outreg
|
#! exits with tagged ptr to bignum in outreg
|
||||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||||
#! length is the # of digits + sign
|
#! length is the # of digits + sign
|
||||||
[
|
[
|
||||||
{ "end" "nonzero" "positive" "store" }
|
{ "end" "nonzero" "positive" "store" } [ define-label ] each
|
||||||
[ define-label ] each
|
src 0 CMP ! is it zero?
|
||||||
dup v>operand 0 CMP ! is it zero?
|
|
||||||
"nonzero" get JNE
|
"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
|
"end" get JMP
|
||||||
"nonzero" resolve-label
|
"nonzero" resolve-label
|
||||||
bignum 4 cells [
|
! Allocate a bignum
|
||||||
! Write length
|
dst 4 cells bignum bignum temp %allot
|
||||||
1 object@ 2 v>operand MOV
|
! Write length
|
||||||
! Test sign
|
dst 1 bignum@ 2 MOV
|
||||||
dup v>operand 0 CMP
|
! Test sign
|
||||||
"positive" get JGE
|
src 0 CMP
|
||||||
2 object@ 1 MOV ! negative sign
|
"positive" get JGE
|
||||||
dup v>operand NEG
|
dst 2 bignum@ 1 MOV ! negative sign
|
||||||
"store" get JMP
|
src NEG
|
||||||
"positive" resolve-label
|
"store" get JMP
|
||||||
2 object@ 0 MOV ! positive sign
|
"positive" resolve-label
|
||||||
"store" resolve-label
|
dst 2 bignum@ 0 MOV ! positive sign
|
||||||
3 object@ swap v>operand MOV
|
"store" resolve-label
|
||||||
! Store tagged ptr in reg
|
dst 3 bignum@ src MOV
|
||||||
bignum %store-tagged
|
|
||||||
] %allot
|
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] 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
|
{ "end" "f" } [ define-label ] each
|
||||||
dup v>operand 0 CMP
|
src 0 CMP
|
||||||
"f" get JE
|
"f" get JE
|
||||||
alien 4 cells [
|
dst 4 cells alien object temp %allot
|
||||||
1 object@ \ f tag-number MOV
|
dst 1 alien@ \ f tag-number MOV
|
||||||
2 object@ \ f tag-number MOV
|
dst 2 alien@ \ f tag-number MOV
|
||||||
! Store src in alien-offset slot
|
! Store src in alien-offset slot
|
||||||
3 object@ swap v>operand MOV
|
dst 3 alien@ src MOV
|
||||||
! Store tagged ptr in dst
|
|
||||||
dup object %store-tagged
|
|
||||||
] %allot
|
|
||||||
"end" get JMP
|
"end" get JMP
|
||||||
"f" resolve-label
|
"f" resolve-label
|
||||||
f [ v>operand ] bi@ MOV
|
\ f tag-number MOV
|
||||||
"end" resolve-label
|
"end" resolve-label
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
@ -321,7 +306,7 @@ M: x86 %box-alien ( dst src -- )
|
||||||
! Slot number is literal and the tag is known
|
! Slot number is literal and the tag is known
|
||||||
{
|
{
|
||||||
[ "val" operand %slot-literal-known-tag MOV ] T{ template
|
[ "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" } } }
|
{ scratch { { f "val" } } }
|
||||||
{ output { "val" } }
|
{ output { "val" } }
|
||||||
}
|
}
|
||||||
|
@ -329,7 +314,7 @@ M: x86 %box-alien ( dst src -- )
|
||||||
! Slot number is literal
|
! Slot number is literal
|
||||||
{
|
{
|
||||||
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
||||||
{ input { { f "obj" } { [ small-slot? ] "n" } } }
|
{ input { { f "obj" } { small-slot "n" } } }
|
||||||
{ output { "obj" } }
|
{ output { "obj" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -343,40 +328,26 @@ M: x86 %box-alien ( dst src -- )
|
||||||
}
|
}
|
||||||
} define-intrinsics
|
} define-intrinsics
|
||||||
|
|
||||||
: generate-write-barrier ( -- )
|
\ (set-slot) {
|
||||||
#! 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 number is literal and the tag is known
|
||||||
{
|
{
|
||||||
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
|
[ %slot-literal-known-tag "val" operand MOV ] T{ template
|
||||||
{ input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
{ input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
|
||||||
{ scratch { { f "scratch" } } }
|
{ scratch { { f "scratch" } } }
|
||||||
{ clobber { "obj" } }
|
{ clobber { "obj" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
! Slot number is literal
|
! Slot number is literal
|
||||||
{
|
{
|
||||||
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
|
[ %slot-literal-any-tag "val" operand MOV ] T{ template
|
||||||
{ input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
{ input { { f "val" } { f "obj" } { small-slot "n" } } }
|
||||||
{ scratch { { f "scratch" } } }
|
{ scratch { { f "scratch" } } }
|
||||||
{ clobber { "obj" } }
|
{ clobber { "obj" } }
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
! Slot number in a register
|
! 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" } } }
|
{ input { { f "val" } { f "obj" } { f "n" } } }
|
||||||
{ scratch { { f "scratch" } } }
|
{ scratch { { f "scratch" } } }
|
||||||
{ clobber { "obj" "n" } }
|
{ clobber { "obj" "n" } }
|
||||||
|
@ -400,7 +371,7 @@ M: x86 %box-alien ( dst src -- )
|
||||||
|
|
||||||
: fixnum-value-op ( op -- pair )
|
: fixnum-value-op ( op -- pair )
|
||||||
T{ template
|
T{ template
|
||||||
{ input { { f "x" } { [ small-tagged? ] "y" } } }
|
{ input { { f "x" } { small-tagged "y" } } }
|
||||||
{ output { "x" } }
|
{ output { "x" } }
|
||||||
} fixnum-op ;
|
} fixnum-op ;
|
||||||
|
|
||||||
|
@ -476,7 +447,7 @@ M: x86 %box-alien ( dst src -- )
|
||||||
! There was an overflow. Recompute the original operand.
|
! There was an overflow. Recompute the original operand.
|
||||||
{ "y" "x" } %untag-fixnums
|
{ "y" "x" } %untag-fixnums
|
||||||
"x" operand "y" operand rot execute
|
"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
|
"end" resolve-label ; inline
|
||||||
|
|
||||||
: overflow-template ( word insn -- )
|
: overflow-template ( word insn -- )
|
||||||
|
@ -516,9 +487,10 @@ M: x86 %box-alien ( dst src -- )
|
||||||
|
|
||||||
\ fixnum>bignum [
|
\ fixnum>bignum [
|
||||||
"x" operand %untag-fixnum
|
"x" operand %untag-fixnum
|
||||||
"x" get dup %allot-bignum-signed-1
|
"x" operand dup "scratch" operand %allot-bignum-signed-1
|
||||||
] T{ template
|
] T{ template
|
||||||
{ input { { f "x" } } }
|
{ input { { f "x" } } }
|
||||||
|
{ scratch { { f "scratch" } } }
|
||||||
{ output { "x" } }
|
{ output { "x" } }
|
||||||
{ gc t }
|
{ gc t }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
@ -531,7 +503,7 @@ M: x86 %box-alien ( dst src -- )
|
||||||
"y" operand "x" operand cell [+] MOV
|
"y" operand "x" operand cell [+] MOV
|
||||||
! if the length is 1, its just the sign and nothing else,
|
! if the length is 1, its just the sign and nothing else,
|
||||||
! so output 0
|
! so output 0
|
||||||
"y" operand 1 v>operand CMP
|
"y" operand 1 tag-fixnum CMP
|
||||||
"nonzero" get JNE
|
"nonzero" get JNE
|
||||||
"y" operand 0 MOV
|
"y" operand 0 MOV
|
||||||
"end" get JMP
|
"end" get JMP
|
||||||
|
@ -577,90 +549,6 @@ M: x86 %box-alien ( dst src -- )
|
||||||
{ clobber { "n" } }
|
{ clobber { "n" } }
|
||||||
} define-intrinsic
|
} 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 intrinsics
|
||||||
: %alien-accessor ( quot -- )
|
: %alien-accessor ( quot -- )
|
||||||
"offset" operand %untag-fixnum
|
"offset" operand %untag-fixnum
|
||||||
|
|
|
@ -1,7 +1,10 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs combinators hashtables kernel
|
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
|
||||||
compiler.tree.builder
|
compiler.tree.builder
|
||||||
compiler.tree.combinators
|
compiler.tree.combinators
|
||||||
|
@ -142,8 +145,7 @@ M: #recursive emit-node
|
||||||
children>> [ emit-nodes ] emit-branches ;
|
children>> [ emit-nodes ] emit-branches ;
|
||||||
|
|
||||||
M: #if emit-node
|
M: #if emit-node
|
||||||
{ { f "flag" } } lazy-load first ##branch-t
|
phantom-pop ##branch-t emit-if iterate-next ;
|
||||||
emit-if iterate-next ;
|
|
||||||
|
|
||||||
! #dispatch
|
! #dispatch
|
||||||
: dispatch-branch ( nodes word -- label )
|
: dispatch-branch ( nodes word -- label )
|
||||||
|
@ -167,7 +169,9 @@ M: #if emit-node
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: emit-dispatch ( node -- )
|
: 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
|
M: #dispatch emit-node
|
||||||
tail-call? [
|
tail-call? [
|
||||||
|
@ -225,12 +229,45 @@ M: #dispatch emit-node
|
||||||
: setup-value-classes ( #call -- )
|
: setup-value-classes ( #call -- )
|
||||||
node-input-infos [ class>> ] map set-value-classes ;
|
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
|
M: #call emit-node
|
||||||
dup setup-value-classes
|
dup setup-value-classes
|
||||||
dup find-if-intrinsic [ do-if-intrinsic ] [
|
dup find-if-intrinsic [ do-if-intrinsic ] [
|
||||||
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
|
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
|
||||||
dup find-intrinsic [ do-intrinsic ] [
|
dup find-intrinsic [ do-intrinsic ] [
|
||||||
word>> emit-call
|
word>> dup "intrinsic" word-prop
|
||||||
|
[ emit-intrinsic ] [ emit-call ] if
|
||||||
] ?if
|
] ?if
|
||||||
] ?if
|
] ?if
|
||||||
] ?if ;
|
] ?if ;
|
||||||
|
|
|
@ -19,6 +19,10 @@ successors ;
|
||||||
V{ } clone >>instructions
|
V{ } clone >>instructions
|
||||||
V{ } clone >>successors ;
|
V{ } clone >>successors ;
|
||||||
|
|
||||||
TUPLE: mr instructions word label ;
|
TUPLE: mr instructions word label frame-size spill-counts ;
|
||||||
|
|
||||||
C: <mr> mr
|
: <mr> ( instructions word label -- mr )
|
||||||
|
mr new
|
||||||
|
swap >>label
|
||||||
|
swap >>word
|
||||||
|
swap >>instructions ;
|
||||||
|
|
|
@ -27,7 +27,7 @@ INSN: ##intrinsic quot defs-vregs uses-vregs ;
|
||||||
|
|
||||||
! Jump tables
|
! Jump tables
|
||||||
INSN: ##dispatch-label label ;
|
INSN: ##dispatch-label label ;
|
||||||
INSN: ##dispatch ;
|
INSN: ##dispatch src temp ;
|
||||||
|
|
||||||
! Boxing and unboxing
|
! Boxing and unboxing
|
||||||
INSN: ##copy < ##unary ;
|
INSN: ##copy < ##unary ;
|
||||||
|
@ -37,9 +37,12 @@ INSN: ##unbox-f < ##unary ;
|
||||||
INSN: ##unbox-alien < ##unary ;
|
INSN: ##unbox-alien < ##unary ;
|
||||||
INSN: ##unbox-byte-array < ##unary ;
|
INSN: ##unbox-byte-array < ##unary ;
|
||||||
INSN: ##unbox-any-c-ptr < ##unary ;
|
INSN: ##unbox-any-c-ptr < ##unary ;
|
||||||
INSN: ##box-float < ##unary ;
|
INSN: ##box-float < ##unary temp ;
|
||||||
INSN: ##box-alien < ##unary ;
|
INSN: ##box-alien < ##unary temp ;
|
||||||
|
|
||||||
|
! Memory allocation
|
||||||
|
INSN: ##allot < ##nullary size type tag temp ;
|
||||||
|
INSN: ##write-barrier src temp ;
|
||||||
INSN: ##gc ;
|
INSN: ##gc ;
|
||||||
|
|
||||||
! FFI
|
! FFI
|
||||||
|
@ -52,10 +55,21 @@ GENERIC: uses-vregs ( insn -- seq )
|
||||||
|
|
||||||
M: ##nullary defs-vregs dst>> >vreg 1array ;
|
M: ##nullary defs-vregs dst>> >vreg 1array ;
|
||||||
M: ##unary 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: insn defs-vregs drop f ;
|
||||||
|
|
||||||
M: ##replace uses-vregs src>> >vreg 1array ;
|
M: ##replace uses-vregs src>> >vreg 1array ;
|
||||||
M: ##unary 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 ;
|
M: insn uses-vregs drop f ;
|
||||||
|
|
||||||
: intrinsic-vregs ( assoc -- seq' )
|
: intrinsic-vregs ( assoc -- seq' )
|
||||||
|
@ -86,8 +100,8 @@ M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||||
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||||
|
|
||||||
! Instructions used by machine IR only.
|
! Instructions used by machine IR only.
|
||||||
INSN: _prologue n ;
|
INSN: _prologue ;
|
||||||
INSN: _epilogue n ;
|
INSN: _epilogue ;
|
||||||
|
|
||||||
INSN: _label id ;
|
INSN: _label id ;
|
||||||
|
|
||||||
|
@ -103,5 +117,8 @@ M: _cond-branch uses-vregs src>> >vreg 1array ;
|
||||||
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
|
||||||
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
|
||||||
|
|
||||||
INSN: _spill src n ;
|
INSN: _spill-integer src n ;
|
||||||
INSN: _reload dst n ;
|
INSN: _reload-integer dst n ;
|
||||||
|
|
||||||
|
INSN: _spill-float src n ;
|
||||||
|
INSN: _reload-float dst n ;
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces sequences math math.order kernel assocs
|
USING: namespaces sequences math math.order kernel assocs
|
||||||
accessors vectors fry heaps
|
accessors vectors fry heaps
|
||||||
|
compiler.cfg.registers
|
||||||
compiler.cfg.linear-scan.live-intervals
|
compiler.cfg.linear-scan.live-intervals
|
||||||
compiler.backend ;
|
compiler.backend ;
|
||||||
IN: compiler.cfg.linear-scan.allocation
|
IN: compiler.cfg.linear-scan.allocation
|
||||||
|
@ -68,10 +69,10 @@ SYMBOL: progress
|
||||||
[ peek >>reg drop ] [ pop >>reg add-active ] if ;
|
[ peek >>reg drop ] [ pop >>reg add-active ] if ;
|
||||||
|
|
||||||
! Spilling
|
! Spilling
|
||||||
SYMBOL: spill-counter
|
SYMBOL: spill-counts
|
||||||
|
|
||||||
: next-spill-location ( -- n )
|
: next-spill-location ( reg-class -- n )
|
||||||
spill-counter [ dup 1+ ] change ;
|
spill-counts get [ dup 1+ ] change-at ;
|
||||||
|
|
||||||
: interval-to-spill ( -- live-interval )
|
: interval-to-spill ( -- live-interval )
|
||||||
#! We spill the interval with the most distant use location.
|
#! We spill the interval with the most distant use location.
|
||||||
|
@ -141,7 +142,7 @@ SYMBOL: spill-counter
|
||||||
V{ } clone active-intervals set
|
V{ } clone active-intervals set
|
||||||
<min-heap> unhandled-intervals set
|
<min-heap> unhandled-intervals set
|
||||||
[ reverse >vector ] assoc-map free-registers set
|
[ reverse >vector ] assoc-map free-registers set
|
||||||
0 spill-counter set
|
H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
|
||||||
-1 progress set ;
|
-1 progress set ;
|
||||||
|
|
||||||
: handle-interval ( live-interval -- )
|
: handle-interval ( live-interval -- )
|
||||||
|
@ -152,8 +153,6 @@ SYMBOL: spill-counter
|
||||||
|
|
||||||
: allocate-registers ( live-intervals machine-registers -- live-intervals )
|
: allocate-registers ( live-intervals machine-registers -- live-intervals )
|
||||||
#! This modifies the input live-intervals.
|
#! This modifies the input live-intervals.
|
||||||
[
|
init-allocator
|
||||||
init-allocator
|
dup init-unhandled
|
||||||
dup init-unhandled
|
(allocate-registers) ;
|
||||||
(allocate-registers)
|
|
||||||
] with-scope ;
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel math assocs namespaces sequences heaps
|
USING: accessors kernel math assocs namespaces sequences heaps
|
||||||
fry make
|
fry make combinators
|
||||||
compiler.cfg.registers
|
compiler.cfg.registers
|
||||||
compiler.cfg.instructions
|
compiler.cfg.instructions
|
||||||
compiler.cfg.linear-scan.live-intervals ;
|
compiler.cfg.linear-scan.live-intervals ;
|
||||||
|
@ -34,7 +34,13 @@ SYMBOL: unhandled-intervals
|
||||||
[ add-unhandled ] each ;
|
[ add-unhandled ] each ;
|
||||||
|
|
||||||
: insert-spill ( live-interval -- )
|
: insert-spill ( live-interval -- )
|
||||||
[ reg>> ] [ spill-to>> ] bi dup [ _spill ] [ 2drop ] if ;
|
[ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
|
||||||
|
over [
|
||||||
|
{
|
||||||
|
{ int-regs [ _spill-integer ] }
|
||||||
|
{ double-float-regs [ _spill-float ] }
|
||||||
|
} case
|
||||||
|
] [ 3drop ] if ;
|
||||||
|
|
||||||
: expire-old-intervals ( n -- )
|
: expire-old-intervals ( n -- )
|
||||||
active-intervals get
|
active-intervals get
|
||||||
|
@ -43,7 +49,13 @@ SYMBOL: unhandled-intervals
|
||||||
[ insert-spill ] each ;
|
[ insert-spill ] each ;
|
||||||
|
|
||||||
: insert-reload ( live-interval -- )
|
: insert-reload ( live-interval -- )
|
||||||
[ reg>> ] [ reload-from>> ] bi dup [ _reload ] [ 2drop ] if ;
|
[ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
|
||||||
|
over [
|
||||||
|
{
|
||||||
|
{ int-regs [ _reload-integer ] }
|
||||||
|
{ double-float-regs [ _reload-float ] }
|
||||||
|
} case
|
||||||
|
] [ 3drop ] if ;
|
||||||
|
|
||||||
: activate-new-intervals ( n -- )
|
: activate-new-intervals ( n -- )
|
||||||
#! Any live intervals which start on the current instruction
|
#! Any live intervals which start on the current instruction
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors
|
USING: kernel accessors namespaces
|
||||||
compiler.backend
|
compiler.backend
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
compiler.cfg.linear-scan.live-intervals
|
compiler.cfg.linear-scan.live-intervals
|
||||||
|
@ -24,7 +24,10 @@ IN: compiler.cfg.linear-scan
|
||||||
|
|
||||||
: linear-scan ( mr -- mr' )
|
: linear-scan ( mr -- mr' )
|
||||||
[
|
[
|
||||||
dup compute-live-intervals
|
[
|
||||||
machine-registers allocate-registers
|
dup compute-live-intervals
|
||||||
assign-registers
|
machine-registers allocate-registers
|
||||||
] change-instructions ;
|
assign-registers
|
||||||
|
] change-instructions
|
||||||
|
spill-counts get >>spill-counts
|
||||||
|
] with-scope ;
|
||||||
|
|
|
@ -28,6 +28,7 @@ SYMBOL: live-intervals
|
||||||
at [ (>>end) ] [ uses>> push ] 2bi ;
|
at [ (>>end) ] [ uses>> push ] 2bi ;
|
||||||
|
|
||||||
: new-live-interval ( n vreg live-intervals -- )
|
: new-live-interval ( n vreg live-intervals -- )
|
||||||
|
2dup key? [ "Multiple defs" throw ] when
|
||||||
[ [ <live-interval> ] keep ] dip set-at ;
|
[ [ <live-interval> ] keep ] dip set-at ;
|
||||||
|
|
||||||
: compute-live-intervals* ( insn n -- )
|
: compute-live-intervals* ( insn n -- )
|
||||||
|
@ -42,7 +43,6 @@ SYMBOL: live-intervals
|
||||||
|
|
||||||
: compute-live-intervals ( instructions -- live-intervals )
|
: compute-live-intervals ( instructions -- live-intervals )
|
||||||
H{ } clone [
|
H{ } clone [
|
||||||
live-intervals [
|
live-intervals set
|
||||||
[ compute-live-intervals* ] each-index
|
[ compute-live-intervals* ] each-index
|
||||||
] with-variable
|
|
||||||
] keep finalize-live-intervals ;
|
] keep finalize-live-intervals ;
|
||||||
|
|
|
@ -9,13 +9,6 @@ compiler.cfg.instructions.syntax ;
|
||||||
IN: compiler.cfg.linearization
|
IN: compiler.cfg.linearization
|
||||||
|
|
||||||
! Convert CFG IR to machine IR.
|
! Convert CFG IR to machine IR.
|
||||||
SYMBOL: frame-size
|
|
||||||
|
|
||||||
: compute-frame-size ( rpo -- )
|
|
||||||
[ instructions>> [ ##frame-required? ] filter ] map concat
|
|
||||||
[ f ] [ [ n>> ] map supremum ] if-empty
|
|
||||||
frame-size set ;
|
|
||||||
|
|
||||||
GENERIC: linearize-insn ( basic-block insn -- )
|
GENERIC: linearize-insn ( basic-block insn -- )
|
||||||
|
|
||||||
: linearize-insns ( basic-block -- )
|
: linearize-insns ( basic-block -- )
|
||||||
|
@ -23,14 +16,6 @@ GENERIC: linearize-insn ( basic-block insn -- )
|
||||||
|
|
||||||
M: insn linearize-insn , drop ;
|
M: insn linearize-insn , drop ;
|
||||||
|
|
||||||
M: ##frame-required linearize-insn 2drop ;
|
|
||||||
|
|
||||||
M: ##prologue linearize-insn
|
|
||||||
2drop frame-size get [ _prologue ] when* ;
|
|
||||||
|
|
||||||
M: ##epilogue linearize-insn
|
|
||||||
2drop frame-size get [ _epilogue ] when* ;
|
|
||||||
|
|
||||||
: useless-branch? ( basic-block successor -- ? )
|
: useless-branch? ( basic-block successor -- ? )
|
||||||
#! If our successor immediately follows us in RPO, then we
|
#! If our successor immediately follows us in RPO, then we
|
||||||
#! don't need to branch.
|
#! don't need to branch.
|
||||||
|
@ -78,9 +63,6 @@ M: ##if-intrinsic linearize-insn
|
||||||
[ [ linearize-basic-block ] each ] { } make ;
|
[ [ linearize-basic-block ] each ] { } make ;
|
||||||
|
|
||||||
: build-mr ( cfg -- mr )
|
: build-mr ( cfg -- mr )
|
||||||
[
|
[ entry>> reverse-post-order linearize-basic-blocks ]
|
||||||
entry>> reverse-post-order [
|
[ word>> ] [ label>> ]
|
||||||
[ compute-frame-size ]
|
tri <mr> ;
|
||||||
[ linearize-basic-blocks ] bi
|
|
||||||
] with-scope
|
|
||||||
] [ word>> ] [ label>> ] tri <mr> ;
|
|
||||||
|
|
|
@ -0,0 +1,59 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces accessors math.order assocs kernel sequences
|
||||||
|
make compiler.cfg.instructions compiler.cfg.instructions.syntax
|
||||||
|
compiler.cfg.registers ;
|
||||||
|
IN: compiler.cfg.stack-frame
|
||||||
|
|
||||||
|
SYMBOL: frame-required?
|
||||||
|
|
||||||
|
SYMBOL: frame-size
|
||||||
|
|
||||||
|
SYMBOL: spill-counts
|
||||||
|
|
||||||
|
: init-stack-frame-builder ( -- )
|
||||||
|
frame-required? off
|
||||||
|
0 frame-size set ;
|
||||||
|
|
||||||
|
GENERIC: compute-frame-size* ( insn -- )
|
||||||
|
|
||||||
|
M: ##frame-required compute-frame-size*
|
||||||
|
frame-required? on
|
||||||
|
n>> frame-size [ max ] change ;
|
||||||
|
|
||||||
|
M: _spill-integer compute-frame-size*
|
||||||
|
drop frame-required? on ;
|
||||||
|
|
||||||
|
M: _spill-float compute-frame-size*
|
||||||
|
drop frame-required? on ;
|
||||||
|
|
||||||
|
M: insn compute-frame-size* drop ;
|
||||||
|
|
||||||
|
: compute-frame-size ( insns -- )
|
||||||
|
[ compute-frame-size* ] each ;
|
||||||
|
|
||||||
|
GENERIC: insert-pro/epilogues* ( insn -- )
|
||||||
|
|
||||||
|
M: ##frame-required insert-pro/epilogues* drop ;
|
||||||
|
|
||||||
|
M: ##prologue insert-pro/epilogues*
|
||||||
|
drop frame-required? get [ _prologue ] when ;
|
||||||
|
|
||||||
|
M: ##epilogue insert-pro/epilogues*
|
||||||
|
drop frame-required? get [ _epilogue ] when ;
|
||||||
|
|
||||||
|
M: insn insert-pro/epilogues* , ;
|
||||||
|
|
||||||
|
: insert-pro/epilogues ( insns -- insns )
|
||||||
|
[ [ insert-pro/epilogues* ] each ] { } make ;
|
||||||
|
|
||||||
|
: build-stack-frame ( mr -- mr )
|
||||||
|
[
|
||||||
|
init-stack-frame-builder
|
||||||
|
[
|
||||||
|
[ compute-frame-size ]
|
||||||
|
[ insert-pro/epilogues ]
|
||||||
|
bi
|
||||||
|
] change-instructions
|
||||||
|
frame-size get >>frame-size
|
||||||
|
] with-scope ;
|
|
@ -3,18 +3,12 @@
|
||||||
USING: arrays assocs classes classes.private classes.algebra
|
USING: arrays assocs classes classes.private classes.algebra
|
||||||
combinators hashtables kernel layouts math fry namespaces
|
combinators hashtables kernel layouts math fry namespaces
|
||||||
quotations sequences system vectors words effects alien
|
quotations sequences system vectors words effects alien
|
||||||
byte-arrays accessors sets math.order compiler.cfg.instructions
|
byte-arrays accessors sets math.order compiler.backend
|
||||||
compiler.cfg.registers ;
|
compiler.cfg.instructions compiler.cfg.registers ;
|
||||||
IN: compiler.cfg.stacks
|
IN: compiler.cfg.stacks
|
||||||
|
|
||||||
! Converting stack operations into register operations, while
|
! Converting stack operations into register operations, while
|
||||||
! doing a bit of optimization along the way.
|
! 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
|
SYMBOL: known-tag
|
||||||
|
|
||||||
! Value protocol
|
! Value protocol
|
||||||
|
@ -100,6 +94,14 @@ M: constant move-spec class ;
|
||||||
swap >>class
|
swap >>class
|
||||||
%move ;
|
%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 -- )
|
: %move ( dst src -- )
|
||||||
2dup [ move-spec ] bi@ 2array {
|
2dup [ move-spec ] bi@ 2array {
|
||||||
{ { f f } [ ##copy ] }
|
{ { f f } [ ##copy ] }
|
||||||
|
@ -114,8 +116,8 @@ M: constant move-spec class ;
|
||||||
|
|
||||||
{ { f constant } [ value>> ##load-literal ] }
|
{ { f constant } [ value>> ##load-literal ] }
|
||||||
|
|
||||||
{ { f float } [ ##box-float ] }
|
{ { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
|
||||||
{ { f unboxed-alien } [ ##box-alien ] }
|
{ { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
|
||||||
{ { f loc } [ ##peek ] }
|
{ { f loc } [ ##peek ] }
|
||||||
|
|
||||||
{ { float f } [ ##unbox-float ] }
|
{ { float f } [ ##unbox-float ] }
|
||||||
|
@ -223,10 +225,6 @@ M: phantom-retainstack finalize-height
|
||||||
: live-locs ( -- seq )
|
: live-locs ( -- seq )
|
||||||
[ (live-locs) ] each-phantom append prune ;
|
[ (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 )
|
: reg-spec>class ( spec -- class )
|
||||||
float eq? double-float-regs int-regs ? ;
|
float eq? double-float-regs int-regs ? ;
|
||||||
|
|
||||||
|
@ -255,7 +253,7 @@ SYMBOL: fresh-objects
|
||||||
|
|
||||||
M: value (lazy-load)
|
M: value (lazy-load)
|
||||||
{
|
{
|
||||||
{ [ dup quotation? ] [ drop ] }
|
{ [ dup { small-slot small-tagged } memq? ] [ drop ] }
|
||||||
{ [ 2dup compatible? ] [ drop ] }
|
{ [ 2dup compatible? ] [ drop ] }
|
||||||
[ (eager-load) ]
|
[ (eager-load) ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
@ -280,23 +278,11 @@ M: loc lazy-store
|
||||||
dup loc? over cached? or [ 2drop ] [ %move ] if
|
dup loc? over cached? or [ 2drop ] [ %move ] if
|
||||||
] each-loc ;
|
] each-loc ;
|
||||||
|
|
||||||
: reset-phantom ( phantom -- )
|
: clear-phantoms ( -- )
|
||||||
#! Kill register assignments but preserve constants and
|
[ stack>> delete-all ] each-phantom ;
|
||||||
#! 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 ;
|
|
||||||
|
|
||||||
: finalize-contents ( -- )
|
: finalize-contents ( -- )
|
||||||
finalize-locs finalize-vregs reset-phantoms ;
|
finalize-locs finalize-vregs clear-phantoms ;
|
||||||
|
|
||||||
! Loading stacks to vregs
|
! Loading stacks to vregs
|
||||||
: vreg-substitution ( value vreg -- pair )
|
: vreg-substitution ( value vreg -- pair )
|
||||||
|
@ -312,26 +298,22 @@ M: loc lazy-store
|
||||||
[ substitute-vreg? ] assoc-filter >hashtable
|
[ substitute-vreg? ] assoc-filter >hashtable
|
||||||
'[ stack>> _ substitute-here ] each-phantom ;
|
'[ stack>> _ substitute-here ] each-phantom ;
|
||||||
|
|
||||||
: clear-phantoms ( -- )
|
|
||||||
[ stack>> delete-all ] each-phantom ;
|
|
||||||
|
|
||||||
: set-value-classes ( classes -- )
|
: set-value-classes ( classes -- )
|
||||||
phantom-datastack get
|
phantom-datastack get
|
||||||
over length over add-locs
|
over length over add-locs
|
||||||
stack>> [ set-value-class ] 2reverse-each ;
|
stack>> [
|
||||||
|
[ value-class class-and ] keep set-value-class
|
||||||
|
] 2reverse-each ;
|
||||||
|
|
||||||
: finalize-phantoms ( -- )
|
: finalize-phantoms ( -- )
|
||||||
#! Commit all deferred stacking shuffling, and ensure the
|
#! Commit all deferred stacking shuffling, and ensure the
|
||||||
#! in-memory data and retain stacks are up to date with
|
#! in-memory data and retain stacks are up to date with
|
||||||
#! respect to the compiler's current picture.
|
#! respect to the compiler's current picture.
|
||||||
finalize-contents
|
finalize-contents
|
||||||
clear-phantoms
|
|
||||||
finalize-heights
|
finalize-heights
|
||||||
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
|
fresh-objects get [
|
||||||
|
empty? [ 0 ##frame-required ##gc ] unless
|
||||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
] [ delete-all ] bi ;
|
||||||
|
|
||||||
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
|
|
||||||
|
|
||||||
: init-phantoms ( -- )
|
: init-phantoms ( -- )
|
||||||
V{ } clone fresh-objects set
|
V{ } clone fresh-objects set
|
||||||
|
@ -364,3 +346,7 @@ M: loc lazy-store
|
||||||
|
|
||||||
: phantom-rdrop ( n -- )
|
: phantom-rdrop ( n -- )
|
||||||
phantom-retainstack get phantom-input drop ;
|
phantom-retainstack get phantom-input drop ;
|
||||||
|
|
||||||
|
: phantom-pop ( -- vreg )
|
||||||
|
1 phantom-datastack get phantom-input dup first f (lazy-load)
|
||||||
|
[ 1array substitute-vregs ] keep ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs accessors sequences kernel fry namespaces
|
USING: assocs accessors sequences kernel fry namespaces
|
||||||
quotations combinators classes.algebra compiler.cfg.instructions
|
quotations combinators classes.algebra compiler.backend
|
||||||
compiler.cfg.registers compiler.cfg.stacks ;
|
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
|
||||||
IN: compiler.cfg.templates
|
IN: compiler.cfg.templates
|
||||||
|
|
||||||
TUPLE: template input output scratch clobber gc ;
|
TUPLE: template input output scratch clobber gc ;
|
||||||
|
@ -57,7 +57,9 @@ TUPLE: template input output scratch clobber gc ;
|
||||||
|
|
||||||
: apply-template ( pair quot -- vregs )
|
: 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
|
[ do-template-outputs ] 2keep
|
||||||
] dip call ; inline
|
] 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
|
#! to the fixnum. Otherwise, the values don't match. If the
|
||||||
#! spec is not a quotation, its a reg-class, in which case
|
#! spec is not a quotation, its a reg-class, in which case
|
||||||
#! the value is always good.
|
#! the value is always good.
|
||||||
dup quotation? [
|
{
|
||||||
over constant?
|
{ [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
|
||||||
[ >r value>> r> 2drop f ] [ 2drop f ] if
|
{ [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
|
||||||
] [
|
[ 2drop t ]
|
||||||
2drop t
|
} cond ;
|
||||||
] if ;
|
|
||||||
|
|
||||||
: class-matches? ( actual expected -- ? )
|
: class-matches? ( actual expected -- ? )
|
||||||
{
|
{
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces make math math.parser sequences accessors
|
USING: namespaces make math math.parser sequences accessors
|
||||||
kernel kernel.private layouts assocs words summary arrays
|
kernel kernel.private layouts assocs words summary arrays
|
||||||
threads continuations.private libc combinators
|
combinators classes.algebra alien alien.c-types alien.structs
|
||||||
alien alien.c-types alien.structs alien.strings
|
alien.strings sets threads libc continuations.private
|
||||||
compiler.errors
|
compiler.errors
|
||||||
compiler.alien
|
compiler.alien
|
||||||
compiler.backend
|
compiler.backend
|
||||||
|
@ -15,6 +15,16 @@ IN: compiler.codegen
|
||||||
|
|
||||||
GENERIC: generate-insn ( insn -- )
|
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 )
|
: generate-insns ( insns -- code )
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
|
@ -61,16 +71,19 @@ M: _label generate-insn
|
||||||
id>> lookup-label , ;
|
id>> lookup-label , ;
|
||||||
|
|
||||||
M: _prologue generate-insn
|
M: _prologue generate-insn
|
||||||
n>> %prologue ;
|
drop %prologue ;
|
||||||
|
|
||||||
M: _epilogue generate-insn
|
M: _epilogue generate-insn
|
||||||
n>> %epilogue ;
|
drop %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 ;
|
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 ;
|
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
|
M: ##intrinsic generate-insn
|
||||||
[ init-intrinsic ] [ quot>> call ] bi ;
|
[ 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
|
M: _if-intrinsic generate-insn
|
||||||
[ init-intrinsic ]
|
[ init-intrinsic ]
|
||||||
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
|
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
|
||||||
|
@ -93,32 +129,48 @@ M: _branch generate-insn
|
||||||
label>> lookup-label %jump-label ;
|
label>> lookup-label %jump-label ;
|
||||||
|
|
||||||
M: _branch-f generate-insn
|
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
|
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-label generate-insn label>> %dispatch-label ;
|
||||||
|
|
||||||
M: ##dispatch generate-insn drop %dispatch ;
|
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 ;
|
M: ##gc generate-insn drop %gc ;
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ stack-checker stack-checker.state stack-checker.inlining
|
||||||
compiler.errors compiler.units compiler.tree.builder
|
compiler.errors compiler.units compiler.tree.builder
|
||||||
compiler.tree.optimizer compiler.cfg.builder
|
compiler.tree.optimizer compiler.cfg.builder
|
||||||
compiler.cfg.linearization compiler.cfg.linear-scan
|
compiler.cfg.linearization compiler.cfg.linear-scan
|
||||||
compiler.codegen ;
|
compiler.cfg.stack-frame compiler.codegen ;
|
||||||
IN: compiler.new
|
IN: compiler.new
|
||||||
|
|
||||||
SYMBOL: compile-queue
|
SYMBOL: compile-queue
|
||||||
|
@ -79,7 +79,13 @@ SYMBOL: +failed+
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: backend ( nodes word -- )
|
: backend ( nodes word -- )
|
||||||
build-cfg [ build-mr linear-scan generate save-asm ] each ;
|
build-cfg [
|
||||||
|
build-mr
|
||||||
|
linear-scan
|
||||||
|
build-stack-frame
|
||||||
|
generate
|
||||||
|
save-asm
|
||||||
|
] each ;
|
||||||
|
|
||||||
: (compile) ( word -- )
|
: (compile) ( word -- )
|
||||||
'[
|
'[
|
||||||
|
|
Loading…
Reference in New Issue