From 1c038b611adaa7384d8cc2c8e91426c63bf0fc87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:08:01 -0500 Subject: [PATCH 01/35] add docs for mime-types --- basis/mime-types/mime-types-docs.factor | 35 +++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 basis/mime-types/mime-types-docs.factor diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime-types/mime-types-docs.factor new file mode 100644 index 0000000000..cf44808725 --- /dev/null +++ b/basis/mime-types/mime-types-docs.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax io.streams.string sequences ; +IN: mime-types + +HELP: mime-db +{ $values + + { "seq" sequence } } +{ $description "Outputs an array where the first element is a MIME type and the rest of the array is file extensions that have that MIME type." } ; + +HELP: mime-type +{ $values + { "path" "a pathname string" } + { "mime-type" "a MIME type string" } } +{ $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ; + +HELP: mime-types +{ $values + + { "assoc" assoc } } +{ $description "Outputs an " { $snippet "assoc" } " made from the data in the " { $link mime-db } " word where the keys are file extensions and the values are the corresponding MIME types." } ; + +HELP: nonstandard-mime-types +{ $values + + { "assoc" assoc } } +{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ; + +ARTICLE: "mime-types" "mime-types" +"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl +"Looking up a MIME type:" +{ $subsection mime-type } ; + +ABOUT: "mime-types" From 7f3b0de65996d87a9d338130ca6d83531943f267 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:16:21 -0500 Subject: [PATCH 02/35] better docs --- basis/alias/alias-docs.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor index f4d4ac0361..4dcf1a7738 100644 --- a/basis/alias/alias-docs.factor +++ b/basis/alias/alias-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel words help.markup help.syntax ; IN: alias @@ -14,4 +16,11 @@ HELP: ALIAS: } } ; +ARTICLE: "alias" "Alias" +"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl +"Make a new word that aliases another word:" +{ $subsection define-alias } +"Make an alias at parse-time:" +{ $subsection POSTPONE: ALIAS: } ; +ABOUT: "alias" From 31939341e3a2ffe8f623347d58b80d654e8dd9d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:16:27 -0500 Subject: [PATCH 03/35] better article name --- basis/mime-types/mime-types-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime-types/mime-types-docs.factor index cf44808725..058a71d838 100644 --- a/basis/mime-types/mime-types-docs.factor +++ b/basis/mime-types/mime-types-docs.factor @@ -27,7 +27,7 @@ HELP: nonstandard-mime-types { "assoc" assoc } } { $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ; -ARTICLE: "mime-types" "mime-types" +ARTICLE: "mime-types" "MIME types" "The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl "Looking up a MIME type:" { $subsection mime-type } ; From 022a90c843a51b2098822b4852166a0bc360faee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:21:32 -0500 Subject: [PATCH 04/35] add vocab-link in docs --- basis/alarms/alarms-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index 49480c0fe0..dac8b72dd5 100755 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -23,7 +23,7 @@ HELP: every { $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ; ARTICLE: "alarms" "Alarms" -"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." +"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." { $subsection alarm } { $subsection add-alarm } { $subsection later } From 1384514ad91501d0d5b9c7c8c1bee5c3add0a202 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:30:42 -0500 Subject: [PATCH 05/35] better base64 docs --- basis/ascii/ascii-docs.factor | 2 +- basis/base64/base64-docs.factor | 18 +++++++++++++----- basis/base64/base64.factor | 2 +- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 1f7a56bed9..75af8a7102 100755 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -38,7 +38,7 @@ HELP: quotable? { $description "Tests for characters which may appear in a Factor string literal without escaping." } ; ARTICLE: "ascii" "ASCII character classes" -"Traditional ASCII character classes:" +"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:" { $subsection blank? } { $subsection letter? } { $subsection LETTER? } diff --git a/basis/base64/base64-docs.factor b/basis/base64/base64-docs.factor index fe948bf667..ed92a19577 100644 --- a/basis/base64/base64-docs.factor +++ b/basis/base64/base64-docs.factor @@ -1,20 +1,28 @@ -USING: help.markup help.syntax kernel math ; +USING: help.markup help.syntax kernel math sequences ; IN: base64 HELP: >base64 -{ $values { "seq" "a sequence" } { "base64" "a string of base64 characters" } } +{ $values { "seq" sequence } { "base64" "a string of base64 characters" } } { $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." } { $examples - { $unchecked-example "\"The monorail is a free service.\" >base64 ." "VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==" } + { $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" } } { $see-also base64> } ; HELP: base64> -{ $values { "base64" "a string of base64 characters" } { "str" "a string" } } +{ $values { "base64" "a string of base64 characters" } { "seq" sequence } } { $description "Converts a string in base64 encoding back into its binary representation." } { $examples - { $unchecked-example "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> ." "\"The monorail is a free service.\"" } + { $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" } } { $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." } { $see-also >base64 } ; +ARTICLE: "base64" "Base 64 conversions" +"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl +"Converting to base 64:" +{ $subsection >base64 } +"Converting back to binary:" +{ $subsection base64> } ; + +ABOUT: "base64" diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 7097de6c6e..e3033a2bde 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -43,7 +43,7 @@ PRIVATE> [ [ "" ] [ >base64-rem ] if-empty ] bi* append ; -: base64> ( base64 -- str ) +: base64> ( base64 -- seq ) #! input length must be a multiple of 4 [ 4 [ decode4 ] map concat ] [ [ CHAR: = = ] count-end ] From 624f0f552c24dfbb0dd2b7834706d28b368e5c79 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 12:32:34 -0500 Subject: [PATCH 06/35] move about to end --- basis/binary-search/binary-search-docs.factor | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index 8b85e078ce..caabbd7419 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -1,17 +1,6 @@ IN: binary-search USING: help.markup help.syntax sequences kernel math.order ; -ARTICLE: "binary-search" "Binary search" -"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." -{ $subsection search } -"Variants of sequence words optimized for sorted sequences:" -{ $subsection sorted-index } -{ $subsection sorted-member? } -{ $subsection sorted-memq? } -{ $see-also "order-specifiers" "sequences-sorting" } ; - -ABOUT: "binary-search" - HELP: search { $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } { $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." @@ -41,3 +30,14 @@ HELP: sorted-memq? { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ; { memq? sorted-memq? } related-words + +ARTICLE: "binary-search" "Binary search" +"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." +{ $subsection search } +"Variants of sequence words optimized for sorted sequences:" +{ $subsection sorted-index } +{ $subsection sorted-member? } +{ $subsection sorted-memq? } +{ $see-also "order-specifiers" "sequences-sorting" } ; + +ABOUT: "binary-search" From 82a076df7923b5ddf1b89c840562e22906a964ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 15:49:46 -0500 Subject: [PATCH 07/35] Clean up human sort, move it to basis --- basis/sorting/human/human-tests.factor | 6 ++++++ basis/sorting/human/human.factor | 10 ++++++++++ extra/sequences/lib/lib.factor | 25 ------------------------- 3 files changed, 16 insertions(+), 25 deletions(-) create mode 100644 basis/sorting/human/human-tests.factor create mode 100644 basis/sorting/human/human.factor diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor new file mode 100644 index 0000000000..0e20b54c2f --- /dev/null +++ b/basis/sorting/human/human-tests.factor @@ -0,0 +1,6 @@ +USING: sorting.human tools.test ; +IN: sorting.human.tests + +\ human-sort must-infer + +[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor new file mode 100644 index 0000000000..1c2ba419c7 --- /dev/null +++ b/basis/sorting/human/human.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: peg.ebnf math.parser kernel assocs sorting ; +IN: sorting.human + +: find-numbers ( string -- seq ) + [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; + +: human-sort ( seq -- seq' ) + [ dup find-numbers ] { } map>assoc sort-values keys ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0ce4f56f7a..690d7f4b76 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -131,23 +131,6 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ switches ] curry map ; -: cut-find ( seq pred -- before after ) - dupd find drop dup [ cut ] when ; - -: cut3 ( seq pred -- first mid last ) - [ cut-find ] keep [ not ] compose cut-find ; - -: (cut-all) ( seq pred quot -- ) - [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep - pick [ (cut-all) ] [ 3drop ] if ; - -: cut-all ( seq pred quot -- first mid last ) - [ (cut-all) ] { } make ; - -: human-sort ( seq -- newseq ) - [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc - sort-values keys ; - : ?first ( seq -- first/f ) 0 swap ?nth ; inline : ?second ( seq -- second/f ) 1 swap ?nth ; inline : ?third ( seq -- third/f ) 2 swap ?nth ; inline @@ -164,14 +147,6 @@ USE: continuations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! List the positions of obj in seq - -: indices ( seq obj -- seq ) - >r dup length swap r> - [ = [ ] [ drop f ] if ] curry - 2map - sift ; - Date: Fri, 12 Sep 2008 15:50:34 -0500 Subject: [PATCH 08/35] Add meta-data --- basis/sorting/human/authors.txt | 2 ++ basis/sorting/human/summary.txt | 1 + basis/sorting/human/tags.txt | 2 ++ 3 files changed, 5 insertions(+) create mode 100644 basis/sorting/human/authors.txt create mode 100644 basis/sorting/human/summary.txt create mode 100644 basis/sorting/human/tags.txt diff --git a/basis/sorting/human/authors.txt b/basis/sorting/human/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/basis/sorting/human/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/basis/sorting/human/summary.txt b/basis/sorting/human/summary.txt new file mode 100644 index 0000000000..a72934f9e6 --- /dev/null +++ b/basis/sorting/human/summary.txt @@ -0,0 +1 @@ +Correct sorting of sequences of strings with embedded numbers diff --git a/basis/sorting/human/tags.txt b/basis/sorting/human/tags.txt new file mode 100644 index 0000000000..3ab2d731fe --- /dev/null +++ b/basis/sorting/human/tags.txt @@ -0,0 +1,2 @@ +collections +text From d5140cf248050b3ace5a111ef8ceeb14dab3e268 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 15:52:43 -0500 Subject: [PATCH 09/35] Fix math.vectors unit tests --- basis/math/vectors/vectors-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index 498bb81f62..aef4ade877 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -6,6 +6,6 @@ USING: math.vectors tools.test ; [ { 1 2 3 } ] [ { 2 4 6 } 2 v/n ] unit-test [ { 1/1 1/2 1/3 } ] [ 1 { 1 2 3 } n/v ] unit-test -[ 4 ] [ { 1 2 } norm-sq ] unit-test -[ 36 ] [ { 2 3 } norm-sq ] unit-test +[ 5 ] [ { 1 2 } norm-sq ] unit-test +[ 13 ] [ { 2 3 } norm-sq ] unit-test From 996dd6442e0e1bb36481f3315c51377b1119a105 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 16:03:47 -0500 Subject: [PATCH 10/35] Add indices word --- core/sequences/sequences-tests.factor | 4 +++- core/sequences/sequences.factor | 5 +++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 8018fe1cdc..f8765bc946 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -265,4 +265,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test -[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test +[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] + +[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 57dba9ed4e..b08d6eb2c7 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -480,6 +480,11 @@ PRIVATE> : last-index-from ( obj i seq -- n ) rot [ = ] curry find-last-from drop ; +: indices ( obj seq -- indices ) + V{ } clone spin + [ rot = [ over push ] [ drop ] if ] + curry each-index ; + : nths ( seq indices -- seq' ) swap [ nth ] curry map ; From 162faace98ff164fece38e9e926738e63941a373 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 16:04:01 -0500 Subject: [PATCH 11/35] Fix typo in 3bi docs --- core/kernel/kernel-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8483293274..c833325c41 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -550,7 +550,7 @@ HELP: 2bi HELP: 3bi { $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } -{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." } +{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values." } { $examples "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" { $code From 8d7ebc510603772433b865ae8aa99ec0413793da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 18:08:19 -0500 Subject: [PATCH 12/35] Change stack effect of nths to match nth, rice bounds-check? --- .../strength-reduction-tests.factor | 119 ------------------ .../strength-reduction.factor | 5 - core/sequences/sequences.factor | 6 +- 3 files changed, 3 insertions(+), 127 deletions(-) delete mode 100644 basis/compiler/tree/strength-reduction/strength-reduction-tests.factor delete mode 100644 basis/compiler/tree/strength-reduction/strength-reduction.factor diff --git a/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor b/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor deleted file mode 100644 index 86fe74d939..0000000000 --- a/basis/compiler/tree/strength-reduction/strength-reduction-tests.factor +++ /dev/null @@ -1,119 +0,0 @@ -! TUPLE: declared-fixnum { x fixnum } ; -! -! [ t ] [ -! [ { declared-fixnum } declare [ 1 + ] change-x ] -! { + fixnum+ >fixnum } inlined? -! ] unit-test -! -! [ t ] [ -! [ { declared-fixnum } declare x>> drop ] -! { slot } inlined? -! ] unit-test -! -! [ t ] [ -! [ hashtable new ] \ new inlined? -! ] unit-test -! -! [ t ] [ -! [ dup hashtable eq? [ new ] when ] \ new inlined? -! ] unit-test -! -! [ f ] [ -! [ { integer } declare -63 shift 4095 bitand ] -! \ shift inlined? -! ] unit-test -! -! [ t ] [ -! [ { integer } declare 127 bitand 3 + ] -! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? -! ] unit-test -! -! [ f ] [ -! [ { integer } declare 127 bitand 3 + ] -! { >fixnum } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { integer } declare -! dup 0 >= [ -! 615949 * 797807 + 20 2^ mod dup 19 2^ - -! ] [ dup ] if -! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { fixnum } declare -! 615949 * 797807 + 20 2^ mod dup 19 2^ - -! ] { >fixnum } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { integer } declare 0 swap -! [ -! drop 615949 * 797807 + 20 2^ rem dup 19 2^ - -! ] map -! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { fixnum } declare 0 swap -! [ -! drop 615949 * 797807 + 20 2^ rem dup 19 2^ - -! ] map -! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? -! ] unit-test -! -! [ t ] [ -! [ { string sbuf } declare ] \ push-all def>> append \ + inlined? -! ] unit-test -! -! [ t ] [ -! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? -! ] unit-test -! -! [ t ] [ -! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? -! ] unit-test -! -! -! -! [ t ] [ -! [ -! { integer } declare [ 256 mod ] map -! ] { mod fixnum-mod } inlined? -! ] unit-test -! -! -! [ f ] [ -! [ -! 256 mod -! ] { mod fixnum-mod } inlined? -! ] unit-test -! -! [ f ] [ -! [ -! dup 0 >= [ 256 mod ] when -! ] { mod fixnum-mod } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { integer } declare dup 0 >= [ 256 mod ] when -! ] { mod fixnum-mod } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { integer } declare 256 rem -! ] { mod fixnum-mod } inlined? -! ] unit-test -! -! [ t ] [ -! [ -! { integer } declare [ 256 rem ] map -! ] { mod fixnum-mod rem } inlined? -! ] unit-test diff --git a/basis/compiler/tree/strength-reduction/strength-reduction.factor b/basis/compiler/tree/strength-reduction/strength-reduction.factor deleted file mode 100644 index c36395bbee..0000000000 --- a/basis/compiler/tree/strength-reduction/strength-reduction.factor +++ /dev/null @@ -1,5 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.strength-reduction - -: strength-reduce ( nodes -- nodes' ) ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index b08d6eb2c7..6cda7fc73f 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -51,7 +51,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : push ( elt seq -- ) [ length ] [ set-nth ] bi ; : bounds-check? ( n seq -- ? ) - length 1- 0 swap between? ; inline + dupd length < [ 0 >= ] [ drop f ] if ; inline ERROR: bounds-error index seq ; @@ -485,8 +485,8 @@ PRIVATE> [ rot = [ over push ] [ drop ] if ] curry each-index ; -: nths ( seq indices -- seq' ) - swap [ nth ] curry map ; +: nths ( indices seq -- seq' ) + [ nth ] curry map ; : contains? ( seq quot -- ? ) find drop >boolean ; inline From 10c68ebb21b4077210bddfc3a173908d66584e39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 18:08:38 -0500 Subject: [PATCH 13/35] New modular arithmetic optimization pass --- .../tree/cleanup/cleanup-tests.factor | 16 +-- basis/compiler/tree/cleanup/cleanup.factor | 8 -- .../tree/dead-code/branches/branches.factor | 2 +- basis/compiler/tree/debugger/debugger.factor | 45 +++++- .../simplified/simplified-tests.factor | 10 ++ .../tree/def-use/simplified/simplified.factor | 40 ++++++ .../tree/finalization/finalization.factor | 31 +---- .../late-optimizations.factor | 29 ++++ .../modular-arithmetic-tests.factor | 130 ++++++++++++++++++ .../modular-arithmetic.factor | 108 +++++++++++++++ .../compiler/tree/optimizer/optimizer.factor | 5 +- .../tree/propagation/inlining/inlining.factor | 13 +- .../known-words/known-words.factor | 26 ++++ .../tree/propagation/propagation-tests.factor | 27 ++-- .../partial-dispatch-tests.factor | 17 ++- .../partial-dispatch/partial-dispatch.factor | 54 ++++++-- 16 files changed, 482 insertions(+), 79 deletions(-) create mode 100644 basis/compiler/tree/def-use/simplified/simplified-tests.factor create mode 100644 basis/compiler/tree/def-use/simplified/simplified.factor create mode 100644 basis/compiler/tree/late-optimizations/late-optimizations.factor create mode 100644 basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor create mode 100644 basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 2e8eb15959..b3ba62b73b 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -13,10 +13,8 @@ compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation -compiler.tree.checker ; - -: cleaned-up-tree ( quot -- nodes ) - build-tree analyze-recursive normalize propagate cleanup dup check-nodes ; +compiler.tree.checker +compiler.tree.debugger ; [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test @@ -34,12 +32,6 @@ compiler.tree.checker ; [ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test -: inlined? ( quot seq/word -- ? ) - [ cleaned-up-tree ] dip - dup word? [ 1array ] when - '[ dup #call? [ word>> _ member? ] [ drop f ] if ] - contains-node? not ; - [ f ] [ [ { integer } declare >fixnum ] \ >fixnum inlined? @@ -498,3 +490,7 @@ cell-bits 32 = [ [ 2 swap >fixnum ribs ] { <-integer-fixnum +-integer-fixnum } inlined? ] unit-test + +[ t ] [ + [ hashtable new ] \ new inlined? +] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 58dc07d868..563926f233 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes ) ] [ body>> cleanup ] bi ; ! Removing overflow checks -: no-overflow-variant ( op -- fast-op ) - H{ - { fixnum+ fixnum+fast } - { fixnum- fixnum-fast } - { fixnum* fixnum*fast } - { fixnum-shift fixnum-shift-fast } - } at ; - : (remove-overflow-check?) ( #call -- ? ) node-output-infos first class>> fixnum class<= ; diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index a19e49494e..719c80f911 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -36,7 +36,7 @@ M: #branch remove-dead-code* '[ _ nth _ key? ] filter ; inline : drop-indexed-values ( values indices -- node ) - [ drop filter-live ] [ nths ] 2bi + [ drop filter-live ] [ swap nths ] 2bi [ make-values ] keep [ drop ] [ zip ] 2bi #shuffle ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 691c564661..4d2881af5a 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,13 +1,21 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs fry match accessors namespaces make effects +USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.sections math words -combinators io sorting hints +combinators io sorting hints qualified compiler.tree +compiler.tree.recursive +compiler.tree.normalization +compiler.tree.cleanup +compiler.tree.propagation +compiler.tree.propagation.info +compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer -compiler.tree.combinators ; +compiler.tree.combinators +compiler.tree.checker ; +RENAME: _ match => __ IN: compiler.tree.debugger ! A simple tool for turning tree IR into quotations and @@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ; { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } { { { ?a ?b } { ?b } } [ nip ] } { { { ?a ?b ?c } { ?c } } [ 2nip ] } - { _ f } + { __ f } } match-choose ; TUPLE: shuffle-node { effect effect } ; @@ -146,3 +154,32 @@ SYMBOL: node-count : optimizer-report. ( word -- ) make-report report. ; + +! More utilities + +: final-info ( quot -- seq ) + build-tree + analyze-recursive + normalize + propagate + compute-def-use + dup check-nodes + peek node-input-infos ; + +: final-classes ( quot -- seq ) + final-info [ class>> ] map ; + +: final-literals ( quot -- seq ) + final-info [ literal>> ] map ; + +: cleaned-up-tree ( quot -- nodes ) + [ + check-optimizer? on + build-tree optimize-tree + ] with-scope ; + +: inlined? ( quot seq/word -- ? ) + [ cleaned-up-tree ] dip + dup word? [ 1array ] when + '[ dup #call? [ word>> _ member? ] [ drop f ] if ] + contains-node? not ; diff --git a/basis/compiler/tree/def-use/simplified/simplified-tests.factor b/basis/compiler/tree/def-use/simplified/simplified-tests.factor new file mode 100644 index 0000000000..a1a768d429 --- /dev/null +++ b/basis/compiler/tree/def-use/simplified/simplified-tests.factor @@ -0,0 +1,10 @@ +USING: kernel tools.test compiler.tree compiler.tree.builder +compiler.tree.def-use compiler.tree.def-use.simplified accessors +sequences sorting classes ; +IN: compiler.tree.def-use.simplified + +[ { #call #return } ] [ + [ 1 dup reverse ] build-tree compute-def-use + first out-d>> first actually-used-by + [ node>> class ] map natural-sort +] unit-test diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor new file mode 100644 index 0000000000..edfe633057 --- /dev/null +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences sequences.deep kernel +compiler.tree compiler.tree.def-use ; +IN: compiler.tree.def-use.simplified + +! Simplified def-use follows chains of copies. + +! A 'real' usage is a usage of a value that is not a #renaming. +TUPLE: real-usage value node ; + +GENERIC: actually-used-by* ( value node -- real-usages ) + +! Def +GENERIC: actually-defined-by* ( value node -- real-usage ) + +: actually-defined-by ( value -- real-usage ) + dup defined-by actually-defined-by* ; + +M: #renaming actually-defined-by* + inputs/outputs swap [ index ] dip nth actually-defined-by ; + +M: #return-recursive actually-defined-by* real-usage boa ; + +M: node actually-defined-by* real-usage boa ; + +! Use +: (actually-used-by) ( value -- real-usages ) + dup used-by [ actually-used-by* ] with map ; + +M: #renaming actually-used-by* + inputs/outputs [ indices ] dip nths + [ (actually-used-by) ] map ; + +M: #return-recursive actually-used-by* real-usage boa ; + +M: node actually-used-by* real-usage boa ; + +: actually-used-by ( value -- real-usages ) + (actually-used-by) flatten ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index ba7e4ff652..c312cb68dc 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -6,27 +6,20 @@ classes.tuple.private slots.private combinators layouts byte-arrays alien.accessors compiler.intrinsics compiler.tree -compiler.tree.builder -compiler.tree.recursive -compiler.tree.normalization -compiler.tree.propagation +compiler.tree.combinators compiler.tree.propagation.info -compiler.tree.cleanup -compiler.tree.def-use -compiler.tree.dead-code -compiler.tree.combinators ; +compiler.tree.late-optimizations ; IN: compiler.tree.finalization +! This is a late-stage optimization. +! See the comment in compiler.tree.late-optimizations. + ! This pass runs after propagation, so that it can expand ! built-in type predicates and memory allocation; these cannot ! be expanded before propagation since we need to see 'fixnum?' ! instead of 'tag 0 eq?' and so on, for semantic reasoning. ! We also delete empty stack shuffles and copies to facilitate -! tail call optimization in the code generator. After this pass -! runs, stack flow information is no longer accurate, since we -! punt in 'splice-quot' and don't update everything that we -! should; this simplifies the code, improves performance, and we -! don't need the stack flow information after this pass anyway. +! tail call optimization in the code generator. GENERIC: finalize* ( node -- nodes ) @@ -37,18 +30,6 @@ M: #shuffle finalize* [ in>> ] [ out>> ] bi sequence= [ drop f ] when ; -: splice-quot ( quot -- nodes ) - [ - build-tree - analyze-recursive - normalize - propagate - cleanup - compute-def-use - remove-dead-code - but-last - ] with-scope ; - : builtin-predicate? ( #call -- ? ) word>> "predicating" word-prop builtin-class? ; diff --git a/basis/compiler/tree/late-optimizations/late-optimizations.factor b/basis/compiler/tree/late-optimizations/late-optimizations.factor new file mode 100644 index 0000000000..e2641416b2 --- /dev/null +++ b/basis/compiler/tree/late-optimizations/late-optimizations.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences namespaces compiler.tree.builder +compiler.tree.recursive +compiler.tree.normalization +compiler.tree.propagation +compiler.tree.propagation.info +compiler.tree.cleanup +compiler.tree.def-use +compiler.tree.dead-code ; +IN: compiler.tree.late-optimizations + +! Late optimizations modify the tree such that stack flow +! information is no longer accurate, since we punt in +! 'splice-quot' and don't update everything that we should; +! this simplifies the code, improves performance, and we +! don't need the stack flow information after this pass anyway. + +: splice-quot ( quot -- nodes ) + [ + build-tree + analyze-recursive + normalize + propagate + cleanup + compute-def-use + remove-dead-code + but-last + ] with-scope ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor new file mode 100644 index 0000000000..b535dfe39c --- /dev/null +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -0,0 +1,130 @@ +IN: compiler.tree.modular-arithmetic.tests +USING: kernel kernel.private tools.test math math.partial-dispatch +math.private accessors slots.private sequences strings sbufs +compiler.tree.builder +compiler.tree.optimizer +compiler.tree.debugger ; + +: test-modular-arithmetic ( quot -- quot' ) + build-tree optimize-tree nodes>quot ; + +[ [ >r >fixnum r> >fixnum fixnum+fast ] ] +[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test + +[ [ +-integer-integer dup >fixnum ] ] +[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test + +[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ] +[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test + +TUPLE: declared-fixnum { x fixnum } ; + +[ t ] [ + [ { declared-fixnum } declare [ 1 + ] change-x ] + { + fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { declared-fixnum } declare x>> drop ] + { slot } inlined? +] unit-test + +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] { >fixnum } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? +] unit-test + + + +[ t ] [ + [ + { integer } declare [ 256 mod ] map + ] { mod fixnum-mod } inlined? +] unit-test + + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor new file mode 100644 index 0000000000..d65b1def16 --- /dev/null +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.partial-dispatch namespaces sequences sets +accessors assocs words kernel memoize fry combinators +compiler.tree +compiler.tree.combinators +compiler.tree.def-use +compiler.tree.def-use.simplified +compiler.tree.late-optimizations ; +IN: compiler.tree.modular-arithmetic + +! This is a late-stage optimization. +! See the comment in compiler.tree.late-optimizations. + +! Modular arithmetic optimization pass. +! +! { integer integer } declare + >fixnum +! ==> +! [ >fixnum ] bi@ fixnum+fast + +{ + - * bitand bitor bitxor } [ + [ + t "modular-arithmetic" set-word-prop + ] each-integer-derived-op +] each + +{ bitand bitor bitxor bitnot } +[ t "modular-arithmetic" set-word-prop ] each + +SYMBOL: modularize-values + +: modular-value? ( value -- ? ) + modularize-values get key? ; + +: modularize-value ( value -- ) modularize-values get conjoin ; + +GENERIC: maybe-modularize* ( value node -- ) + +: maybe-modularize ( value -- ) + actually-defined-by [ value>> ] [ node>> ] bi + over actually-used-by length 1 = [ + maybe-modularize* + ] [ 2drop ] if ; + +M: #call maybe-modularize* + dup word>> "modular-arithmetic" word-prop [ + [ modularize-value ] + [ in-d>> [ maybe-modularize ] each ] bi* + ] [ 2drop ] if ; + +M: node maybe-modularize* 2drop ; + +GENERIC: compute-modularized-values* ( node -- ) + +M: #call compute-modularized-values* + dup word>> { + { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] } + ! { [ + ! { + ! mod-integer-fixnum + ! mod-integer-integer + ! mod-fixnum-integer + ! } memq? + ! ] [ ] } + [ drop ] + } cond ; + +M: node compute-modularized-values* drop ; + +: compute-modularized-values ( nodes -- ) + [ compute-modularized-values* ] each-node ; + +GENERIC: optimize-modular-arithmetic* ( node -- nodes ) + +: redundant->fixnum? ( #call -- ? ) + in-d>> first actually-defined-by value>> modular-value? ; + +: optimize->fixnum ( #call -- nodes ) + dup redundant->fixnum? [ drop f ] when ; + +MEMO: fixnum-coercion ( flags -- nodes ) + [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; + +: optimize-modular-op ( #call -- nodes ) + dup out-d>> first modular-value? [ + [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri + [ + [ + [ actually-defined-by value>> modular-value? ] + [ fixnum eq? ] + bi* or + ] 2map fixnum-coercion + ] [ [ modular-variant ] change-word ] bi* suffix + ] when ; + +M: #call optimize-modular-arithmetic* + dup word>> { + { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } + [ drop ] + } cond ; + +M: node optimize-modular-arithmetic* ; + +: optimize-modular-arithmetic ( nodes -- nodes' ) + H{ } clone modularize-values set + dup compute-modularized-values + [ optimize-modular-arithmetic* ] map-nodes ; diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 3196253d45..e37323a2ec 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -10,7 +10,7 @@ compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use compiler.tree.dead-code -compiler.tree.strength-reduction +compiler.tree.modular-arithmetic compiler.tree.finalization compiler.tree.checker ; IN: compiler.tree.optimizer @@ -27,9 +27,10 @@ SYMBOL: check-optimizer? apply-identities compute-def-use remove-dead-code - ! strength-reduce check-optimizer? get [ compute-def-use dup check-nodes ] when + compute-def-use + optimize-modular-arithmetic finalize ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 48864d8782..197d1820bf 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces +words namespaces continuations compiler.tree compiler.tree.builder compiler.tree.recursive @@ -33,7 +33,7 @@ M: quotation splicing-nodes body>> (propagate) ; ! Dispatch elimination -: eliminate-dispatch ( #call class/f word/f -- ? ) +: eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip over method>> over = [ drop ] [ @@ -156,12 +156,19 @@ SYMBOL: history : always-inline-word? ( word -- ? ) { curry compose } memq? ; +: custom-inlining? ( word -- ? ) + "custom-inlining" word-prop ; + +: inline-custom ( #call word -- ? ) + [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack + first object swap eliminate-dispatch ; + : do-inlining ( #call word -- ? ) { + { [ dup custom-inlining? ] [ inline-custom ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ dup math-partial? ] [ inline-math-partial ] } { [ dup method-body? ] [ inline-method-body ] } [ 2drop f ] } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d208d31389..9f208bdc12 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -230,6 +230,32 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +{ + mod-integer-integer + mod-integer-fixnum + mod-fixnum-integer + fixnum-mod + rem +} [ + [ + in-d>> second value-info >literal< + [ power-of-2? [ 1- bitand ] f ? ] when + ] "custom-inlining" set-word-prop +] each + +{ + bitand-integer-integer + bitand-integer-fixnum + bitand-fixnum-integer +} [ + [ + in-d>> second value-info >literal< [ + 0 most-positive-fixnum between? + [ [ >fixnum ] bi@ fixnum-bitand ] f ? + ] when + ] "custom-inlining" set-word-prop +] each + { alien-signed-1 alien-unsigned-1 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index a115ee53c2..6638951723 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -6,27 +6,12 @@ alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use -compiler.tree.checker slots.private words hashtables -classes assocs ; +compiler.tree.debugger compiler.tree.checker +slots.private words hashtables classes assocs ; IN: compiler.tree.propagation.tests \ propagate must-infer -: final-info ( quot -- seq ) - build-tree - analyze-recursive - normalize - propagate - compute-def-use - dup check-nodes - peek node-input-infos ; - -: final-classes ( quot -- seq ) - final-info [ class>> ] map ; - -: final-literals ( quot -- seq ) - final-info [ literal>> ] map ; - [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test @@ -594,6 +579,14 @@ MIXIN: empty-mixin [ { float } declare 0 eq? ] final-classes ] unit-test +[ V{ integer } ] [ + [ { integer fixnum } declare mod ] final-classes +] unit-test + +[ V{ integer } ] [ + [ { fixnum integer } declare bitand ] final-classes +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/math/partial-dispatch/partial-dispatch-tests.factor b/basis/math/partial-dispatch/partial-dispatch-tests.factor index 64605b1818..388b4127cd 100644 --- a/basis/math/partial-dispatch/partial-dispatch-tests.factor +++ b/basis/math/partial-dispatch/partial-dispatch-tests.factor @@ -1,5 +1,6 @@ IN: math.partial-dispatch.tests -USING: math.partial-dispatch tools.test math kernel sequences ; +USING: math.partial-dispatch math.private +tools.test math kernel sequences ; [ t ] [ \ + integer fixnum math-both-known? ] unit-test [ t ] [ \ + bignum fixnum math-both-known? ] unit-test @@ -10,3 +11,17 @@ USING: math.partial-dispatch tools.test math kernel sequences ; [ f ] [ \ number= fixnum object math-both-known? ] unit-test [ t ] [ \ number= integer fixnum math-both-known? ] unit-test [ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test + +[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test +[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test +[ { fixnum fixnum } ] [ \ fixnum+fast integer-op-input-classes ] unit-test +[ { integer } ] [ \ bitnot integer-op-input-classes ] unit-test + +[ shift ] [ \ fixnum-shift generic-variant ] unit-test +[ fixnum-shift-fast ] [ \ fixnum-shift no-overflow-variant ] unit-test + +[ fixnum-shift-fast ] [ \ shift modular-variant ] unit-test +[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test +[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test +[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test + diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index b162406e5a..61678eb088 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -6,13 +6,41 @@ generic generic.math hashtables effects compiler.units classes.algebra ; IN: math.partial-dispatch -! Partial dispatch. - -! This code will be overhauled and generalized when -! multi-methods go into the core. PREDICATE: math-partial < word "derived-from" word-prop >boolean ; +GENERIC: integer-op-input-classes ( word -- classes ) + +M: math-partial integer-op-input-classes + "derived-from" word-prop rest ; + +M: word integer-op-input-classes + "input-classes" word-prop + [ "Bug: integer-op-input-classes" throw ] unless* ; + +: generic-variant ( op -- generic-op/f ) + dup "derived-from" word-prop [ first ] [ ] ?if ; + +: no-overflow-variant ( op -- fast-op ) + H{ + { fixnum+ fixnum+fast } + { fixnum- fixnum-fast } + { fixnum* fixnum*fast } + { fixnum-shift fixnum-shift-fast } + } at ; + +: modular-variant ( op -- fast-op ) + generic-variant dup H{ + { + fixnum+fast } + { - fixnum-fast } + { * fixnum*fast } + { shift fixnum-shift-fast } + { bitand fixnum-bitand } + { bitor fixnum-bitor } + { bitxor fixnum-bitxor } + { bitnot fixnum-bitnot } + } at swap or ; + :: fixnum-integer-op ( a b fix-word big-word -- c ) b tag 0 eq? [ a b fix-word execute @@ -69,10 +97,17 @@ PREDICATE: math-partial < word } swap [ prefix ] curry map ; : define-integer-ops ( word fix-word big-word -- ) - >r >r integer-op-triples r> r> - [ define-integer-op-words ] - [ 2drop [ dup integer-op-word ] { } map>assoc % ] - 3bi ; + [ + rot tuck + [ fixnum fixnum 3array "derived-from" set-word-prop ] + [ bignum bignum 3array "derived-from" set-word-prop ] + 2bi* + ] [ + [ integer-op-triples ] 2dip + [ define-integer-op-words ] + [ 2drop [ dup integer-op-word ] { } map>assoc % ] + 3bi + ] 3bi ; : define-math-ops ( op -- ) { fixnum bignum float } @@ -125,6 +160,9 @@ SYMBOL: fast-math-ops : each-fast-derived-op ( word quot -- ) >r fast-derived-ops r> each ; inline +: each-integer-derived-op ( word quot -- ) + >r integer-derived-ops r> each ; inline + [ [ \ + define-math-ops From 379566374cd568810d33a39dc947dad5a80ae478 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 18:15:22 -0500 Subject: [PATCH 14/35] Fix usages of nths --- extra/math/combinatorics/combinatorics.factor | 2 +- extra/project-euler/186/186.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 7c5d5ba4c0..a0c6df083b 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -39,7 +39,7 @@ PRIVATE> twiddle [ nPk ] keep factorial / ; : permutation ( n seq -- seq ) - tuck permutation-indices nths ; + tuck permutation-indices swap nths ; : all-permutations ( seq -- seq ) [ diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor index ac846f6064..5308662daf 100644 --- a/extra/project-euler/186/186.factor +++ b/extra/project-euler/186/186.factor @@ -9,7 +9,7 @@ IN: project-euler.186 55 [1,b] [ (generator) ] map ; : advance ( lag -- ) - [ { 0 31 } nths sum 1000000 rem ] keep push-circular ; + [ { 0 31 } swap nths sum 1000000 rem ] keep push-circular ; : next ( lag -- n ) [ first ] [ advance ] bi ; From f2eeeb4ae80e5686a80f0ce260a2d61059c53b55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 18:15:26 -0500 Subject: [PATCH 15/35] Cleanup --- extra/benchmark/spectral-norm/spectral-norm.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 6d4d42116c..3c20a1ceff 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -41,7 +41,7 @@ IN: benchmark.spectral-norm ] times ; inline : spectral-norm ( n -- norm ) - u/v [ v. ] keep norm-sq /f sqrt ; + u/v [ v. ] [ norm-sq ] bi /f sqrt ; HINTS: spectral-norm fixnum ; From 20cc730501312cdc9da64cfd61066edc26d39943 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 12 Sep 2008 18:57:34 -0500 Subject: [PATCH 16/35] Fix sequences tests --- core/sequences/sequences-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index f8765bc946..e27f2410b3 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -250,11 +250,11 @@ unit-test [ 50 ] [ 100 [ even? ] count ] unit-test [ 50 ] [ 100 [ odd? ] count ] unit-test -[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } nths ] unit-test -[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } nths ] unit-test -[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } nths ] unit-test -[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } nths ] unit-test - +[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test +[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test +[ { "d" "c" "b" "a" } ] [ { 3 2 1 0 } { "a" "b" "c" "d" } nths ] unit-test +[ { "d" "a" "b" "c" } ] [ { 3 0 1 2 } { "a" "b" "c" "d" } nths ] unit-test + TUPLE: bogus-hashcode ; M: bogus-hashcode hashcode* 2drop 0 >bignum ; @@ -265,6 +265,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test -[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] +[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test [ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test From dab32f7abe9342a3cb4d435fb187da33ef8b9542 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 21:56:25 -0500 Subject: [PATCH 17/35] unbreak regexp2 for fry change, use dip some, pprint*, make \^ and \$ parse --- unfinished/regexp2/backend/backend.factor | 1 - unfinished/regexp2/dfa/dfa.factor | 2 +- unfinished/regexp2/parser/parser.factor | 2 ++ unfinished/regexp2/regexp2-tests.factor | 2 ++ unfinished/regexp2/regexp2.factor | 31 ++++++++++++++++++- unfinished/regexp2/traversal/traversal.factor | 4 ++- unfinished/regexp2/utils/utils.factor | 2 +- 7 files changed, 39 insertions(+), 5 deletions(-) diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp2/backend/backend.factor index 81ffb334bd..fa5c1f7f97 100644 --- a/unfinished/regexp2/backend/backend.factor +++ b/unfinished/regexp2/backend/backend.factor @@ -21,7 +21,6 @@ TUPLE: regexp 0 >>state V{ } clone >>stack V{ } clone >>new-states - H{ } clone >>options H{ } clone >>visited-states ; SYMBOL: current-regexp diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor index 468ffa73e5..cd2f4186f4 100644 --- a/unfinished/regexp2/dfa/dfa.factor +++ b/unfinished/regexp2/dfa/dfa.factor @@ -15,7 +15,7 @@ IN: regexp2.dfa eps swap find-delta ; : find-epsilon-closure ( states regexp -- new-states ) - '[ dup , (find-epsilon-closure) union ] [ length ] while-changes + '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes natural-sort ; : find-closure ( states transition regexp -- new-states ) diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor index 206db3883d..a970f82aab 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp2/parser/parser.factor @@ -291,6 +291,8 @@ ERROR: bad-escaped-literals seq ; { CHAR: f [ HEX: c ] } { CHAR: a [ HEX: 7 ] } { CHAR: e [ HEX: 1b ] } + { CHAR: $ [ CHAR: $ ] } + { CHAR: ^ [ CHAR: ^ ] } { CHAR: d [ digit-class ] } { CHAR: D [ digit-class ] } diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp2/regexp2-tests.factor index 88bbc5f56c..f691c2becf 100644 --- a/unfinished/regexp2/regexp2-tests.factor +++ b/unfinished/regexp2/regexp2-tests.factor @@ -222,6 +222,8 @@ IN: regexp2-tests drop ] unit-test +[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" drop ] unit-test + ! Comment [ t ] [ "ac" "a(?#boo)c" matches? ] unit-test diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp2/regexp2.factor index 24221baeb6..feec8ea97e 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/unfinished/regexp2/regexp2.factor @@ -3,7 +3,8 @@ USING: accessors combinators kernel math math.ranges sequences regexp2.backend regexp2.utils memoize sets regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal -regexp2.transition-tables ; +regexp2.transition-tables assocs prettyprint.backend +make ; IN: regexp2 : default-regexp ( string -- regexp ) @@ -14,6 +15,7 @@ IN: regexp2 >>minimized-table H{ } clone >>nfa-traversal-flags H{ } clone >>dfa-traversal-flags + H{ } clone >>options reset-regexp ; : construct-regexp ( regexp -- regexp' ) @@ -60,3 +62,30 @@ IN: regexp2 : R` CHAR: ` ; parsing : R{ CHAR: } ; parsing : R| CHAR: | ; parsing + +: find-regexp-syntax ( string -- prefix suffix ) + { + { "R/ " "/" } + { "R! " "!" } + { "R\" " "\"" } + { "R# " "#" } + { "R' " "'" } + { "R( " ")" } + { "R@ " "@" } + { "R[ " "]" } + { "R` " "`" } + { "R{ " "}" } + { "R| " "|" } + } swap [ subseq? not nip ] curry assoc-find drop ; + +: option? ( option regexp -- ? ) + options>> key? ; + +M: regexp pprint* + [ + [ + dup raw>> + dup find-regexp-syntax swap % swap % % + case-insensitive swap option? [ "i" % ] when + ] "" make + ] keep present-text ; diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor index 0bc304bfe0..ba9284c110 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp2/traversal/traversal.factor @@ -45,7 +45,9 @@ TUPLE: dfa-traverser ] when text-finished? ; : increment-state ( dfa-traverser state -- dfa-traverser ) - >r [ 1+ ] change-current-index dup current-state>> >>last-state r> + [ + [ 1+ ] change-current-index dup current-state>> >>last-state + ] dip first >>current-state ; : match-failed ( dfa-traverser -- dfa-traverser ) diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp2/utils/utils.factor index 48c68d883f..ab51436f8b 100644 --- a/unfinished/regexp2/utils/utils.factor +++ b/unfinished/regexp2/utils/utils.factor @@ -9,7 +9,7 @@ IN: regexp2.utils : (while-changes) ( obj quot pred pred-ret -- obj ) ! quot: ( obj -- obj' ) ! pred: ( obj -- <=> ) - >r >r dup slip r> pick over call r> dupd = + [ [ dup slip ] dip pick over call ] dip dupd = [ 3drop ] [ (while-changes) ] if ; inline recursive : while-changes ( obj quot pred -- obj' ) From 7f832de824b131c06a1400baa94b3bb75971c5d7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Sep 2008 22:04:35 -0500 Subject: [PATCH 18/35] fix help-lint --- basis/mime-types/mime-types-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime-types/mime-types-docs.factor index 058a71d838..b7fa46d587 100644 --- a/basis/mime-types/mime-types-docs.factor +++ b/basis/mime-types/mime-types-docs.factor @@ -11,7 +11,7 @@ HELP: mime-db HELP: mime-type { $values - { "path" "a pathname string" } + { "filename" "a filename" } { "mime-type" "a MIME type string" } } { $description "Outputs the MIME type associtated with a path by parsing the path's file extension and looking it up in the table returned by " { $link mime-types } "." } ; From 7ba28ac8d5c45a638cd8027097e476e99c998d98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 02:37:16 -0500 Subject: [PATCH 19/35] Clean up raytracer a bit --- extra/benchmark/raytracer/raytracer.factor | 60 +++++++++++----------- 1 file changed, 31 insertions(+), 29 deletions(-) diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 69454505a5..34bac61292 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: arrays accessors float-arrays io io.files io.encodings.binary kernel math math.functions math.vectors -math.parser make sequences sequences.private words ; +math.parser make sequences sequences.private words hints ; IN: benchmark.raytracer ! parameters @@ -38,34 +38,40 @@ TUPLE: sphere { center float-array read-only } { radius float read-only } ; C: sphere : sphere-v ( sphere ray -- v ) - swap center>> swap orig>> v- ; inline + [ center>> ] [ orig>> ] bi* v- ; inline -: sphere-b ( ray v -- b ) swap dir>> v. ; inline +: sphere-b ( v ray -- b ) + dir>> v. ; inline -: sphere-disc ( sphere v b -- d ) - sq swap norm-sq - swap radius>> sq + ; inline +: sphere-d ( sphere b v -- d ) + [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline -: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline +: -+ ( x y -- x-y x+y ) + [ - ] [ + ] 2bi ; inline -: sphere-b/d ( b d -- t ) +: sphere-t ( b d -- t ) -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline -: ray-sphere ( sphere ray -- t ) - 2dup sphere-v tuck sphere-b [ sphere-disc ] keep - over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ; - inline +: sphere-b&v ( sphere ray -- b v ) + [ sphere-v ] [ nip ] 2bi + [ sphere-b ] [ drop ] 2bi ; inline -: sphere-n ( ray sphere l -- n ) - pick dir>> n*v swap center>> v- swap orig>> v+ ; - inline +: ray-sphere ( sphere ray -- t ) + [ drop ] [ sphere-b&v ] 2bi + [ drop ] [ sphere-d ] 3bi + dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline : if-ray-sphere ( hit ray sphere quot -- hit ) #! quot: hit ray sphere l -- hit [ - pick lambda>> [ 2dup swap ray-sphere dup ] dip >= - [ 3drop ] - ] dip if ; inline + [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri + [ drop ] [ < ] 2bi + ] dip [ 3drop ] if ; inline + +: sphere-n ( ray sphere l -- n ) + [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri* + swap [ v*n ] dip v- v+ ; inline M: sphere intersect-scene ( hit ray sphere -- hit ) [ [ sphere-n normalize ] keep nip ] if-ray-sphere ; @@ -79,21 +85,17 @@ TUPLE: group < sphere { objs array read-only } ; swap [ { } make ] dip ; inline M: group intersect-scene ( hit ray group -- hit ) - [ - drop - objs>> [ [ tuck ] dip intersect-scene swap ] each - drop - ] if-ray-sphere ; + [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ; -: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline +: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1/0. } ; inline : initial-intersect ( ray scene -- hit ) - initial-hit -rot intersect-scene ; inline + [ initial-hit ] 2dip intersect-scene ; inline : ray-o ( ray hit -- o ) - over dir>> over lambda>> v*n - swap normal>> delta v*n v+ - swap orig>> v+ ; inline + [ [ orig>> ] [ normal>> delta v*n ] bi* ] + [ [ dir>> ] [ lambda>> ] bi* v*n ] + 2bi v+ v+ ; inline : sray-intersect ( ray scene hit -- ray ) swap [ ray-o light vneg ] dip initial-intersect ; inline @@ -101,10 +103,10 @@ M: group intersect-scene ( hit ray group -- hit ) : ray-g ( hit -- g ) normal>> light v. ; inline : cast-ray ( ray scene -- g ) - 2dup initial-intersect dup lambda>> 1.0/0.0 = [ + 2dup initial-intersect dup lambda>> 1/0. = [ 3drop 0.0 ] [ - [ sray-intersect lambda>> 1.0/0.0 = ] keep swap + [ sray-intersect lambda>> 1/0. = ] keep swap [ ray-g neg ] [ drop 0.0 ] if ] if ; inline From 2cc40052bfeffb82a31f76a005ace9c6e3e6249d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 03:06:36 -0500 Subject: [PATCH 20/35] Rewrite locals-in-literals in idiomatic Factor, and fix a performance regression with locals in tuples --- basis/locals/locals-tests.factor | 4 +- basis/locals/locals.factor | 93 +++++++++++--------------------- 2 files changed, 35 insertions(+), 62 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 59ec325f39..eb06d05146 100755 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -329,4 +329,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test [ T{ slice f 0 3 "abc" } ] -[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test \ No newline at end of file +[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test + +{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index bfc92ee9e2..05ea3cb524 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,7 +6,7 @@ quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer +locals.backend memoize macros.expander lexer classes stack-checker.known-words ; IN: locals @@ -195,70 +195,41 @@ M: block lambda-rewrite* swap point-free , ] keep length \ curry % ; +GENERIC: rewrite-element ( obj -- ) + +: rewrite-elements ( seq -- ) + [ rewrite-element ] each ; + +: rewrite-sequence ( seq -- ) + [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; + +M: array rewrite-element rewrite-sequence ; + +M: vector rewrite-element rewrite-sequence ; + +M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; + +M: tuple rewrite-element + [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ; + +M: local rewrite-element , ; + +M: word rewrite-element literalize , ; + +M: object rewrite-element , ; + +M: array local-rewrite* rewrite-element ; + +M: vector local-rewrite* rewrite-element ; + +M: tuple local-rewrite* rewrite-element ; + +M: hashtable local-rewrite* rewrite-element ; + M: object lambda-rewrite* , ; M: object local-rewrite* , ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Broil is used to support locals in literals - -DEFER: [broil] -DEFER: [broil-hashtable] -DEFER: [broil-tuple] - -: broil-element ( obj -- quot ) - { - { [ dup number? ] [ 1quotation ] } - { [ dup string? ] [ 1quotation ] } - { [ dup sequence? ] [ [broil] ] } - { [ dup hashtable? ] [ [broil-hashtable] ] } - { [ dup tuple? ] [ [broil-tuple] ] } - { [ dup local? ] [ 1quotation ] } - { [ dup word? ] [ literalize 1quotation ] } - { [ t ] [ 1quotation ] } - } - cond ; - -: [broil] ( seq -- quot ) - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence ] curry curry compose ; - -MACRO: broil ( seq -- quot ) [broil] ; - -: [broil-hashtable] ( hashtable -- quot ) - >alist - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence >hashtable ] curry curry compose ; - -MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ; - -: [broil-tuple] ( tuple -- quot ) - tuple>array - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence >tuple ] curry curry compose ; - -MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ; - -! Engage broil on arrays and vectors. Can't do it on 'sequence' -! because that will pick up strings and integers. What do do... - -M: array local-rewrite* ( array -- ) [broil] % ; -M: vector local-rewrite* ( vector -- ) [broil] % ; -M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ; -M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : make-local ( name -- word ) "!" ?tail [ From 01129fb9bd9ad598bc2889125edb7d2ff681f230 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 03:09:16 -0500 Subject: [PATCH 21/35] Add unit test for locals performance regresion --- basis/compiler/tree/propagation/propagation-tests.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 6638951723..d73e8b7db1 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -7,7 +7,8 @@ byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker -slots.private words hashtables classes assocs ; +slots.private words hashtables classes assocs locals +float-arrays ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -587,6 +588,8 @@ MIXIN: empty-mixin [ { fixnum integer } declare bitand ] final-classes ] unit-test +[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test From 87797847987eb8c2252e2b3dc3956e78125fd970 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 03:12:52 -0500 Subject: [PATCH 22/35] Support hints on methods --- basis/hints/hints-docs.factor | 21 ++++++++++++++++++--- basis/hints/hints.factor | 5 +++-- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 99c4a2ddfc..347cfd3ef4 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,9 +20,24 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "word" word } { "hints..." "a list of sequences of classes" } } -{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." } +{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } } +{ $description "Defines specialization hints for a word or a method." +$nl +"Each sequence of classes in the list will cause a specialized version of the word to be compiled." } { $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code "HINTS: append { string string } { array array } ;" } } ; +{ $code "HINTS: append { string string } { array array } ;" } +"Specializers can also be defined on methods:" +{ $code + "GENERIC: count-occurrences ( elt obj -- n )" + "" + "M: sequence count-occurrences [ = ] with count ;" + "" + "M: assoc count-occurrences" + " swap [ = nip ] curry assoc-filter assoc-size ;" + "" + "HINTS: { sequence count-occurrences } { object array } ;" + "HINTS: { assoc count-occurrences } { object hashtable } ;" +} +} ; ABOUT: "hints" diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 1138ad872a..a10588d730 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,11 +42,11 @@ IN: hints : specialized-def ( word -- quot ) dup def>> swap { - { [ dup standard-method? ] [ specialize-method ] } { [ dup "specializer" word-prop ] [ "specializer" word-prop specialize-quot ] } + { [ dup standard-method? ] [ specialize-method ] } [ drop ] } cond ; @@ -54,7 +54,8 @@ IN: hints dup [ array? ] all? [ first ] when length ; : HINTS: - scan-word + scan-object + dup method-spec? [ first2 method ] when [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; parsing From d2646cfe1bc7cba51179131d17adc399c47e6462 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 13 Sep 2008 04:09:13 -0500 Subject: [PATCH 23/35] tools.annotations: Use fry in '(watch)' --- basis/tools/annotations/annotations.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 96c2ec2fcc..6a7e33e615 100755 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -3,7 +3,7 @@ USING: accessors kernel words parser io summary quotations sequences prettyprint continuations effects definitions compiler.units namespaces assocs tools.walker generic -inspector ; +inspector fry ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -49,10 +49,7 @@ M: word reset .s ] if* "\\--" print flush ; -: (watch) ( word def -- def ) - over [ entering ] curry - rot [ leaving ] curry - swapd 3append ; +: (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ; : watch ( word -- ) dup [ (watch) ] annotate ; From a211e44bb9264a9e345c132541c462251c6fb5ea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 04:43:29 -0500 Subject: [PATCH 24/35] Found a place to use the locals in literals feature --- basis/compiler/tree/dead-code/recursive/recursive.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 03d4e919ee..02dc42f058 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -84,7 +84,7 @@ M:: #recursive remove-dead-code* ( node -- nodes ) drop-outputs [ node drop-recursive-outputs ] | node [ (remove-dead-code) ] change-child drop node label>> [ filter-live ] change-enter-out drop - drop-inputs node drop-outputs 3array + { drop-inputs node drop-outputs } ] ; M: #return-recursive remove-dead-code* ; From d47a76b69bc9881f74602d75baf6eb15e6f5eebc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 06:13:49 -0500 Subject: [PATCH 25/35] 15% improvement --- extra/benchmark/spectral-norm/spectral-norm.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 3c20a1ceff..245027ef77 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -32,8 +32,10 @@ IN: benchmark.spectral-norm : eval-AtA-times-u ( u n -- seq ) [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline +: ones ( n -- seq ) [ 1.0 ] F{ } replicate-as ; inline + :: u/v ( n -- u v ) - n 1.0 >float-array dup + n ones dup 10 [ drop n eval-AtA-times-u From 1bf65e6dc5a91fd8bd2fa3ca22c5af53f5ea32f1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 13 Sep 2008 11:12:36 -0500 Subject: [PATCH 26/35] tools.annotations: Use fry in '(watch-vars)' --- basis/tools/annotations/annotations.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 6a7e33e615..c836bfc2b6 100755 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -55,11 +55,12 @@ M: word reset dup [ (watch) ] annotate ; : (watch-vars) ( quot word vars -- newquot ) - [ - "--- Entering: " write swap . - "--- Variable values:" print - [ dup get ] H{ } map>assoc describe - ] 2curry prepose ; + rot + '[ + "--- Entering: " write _ . + "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe + @ + ] ; : watch-vars ( word vars -- ) dupd [ (watch-vars) ] 2curry annotate ; From 8b9784108e5d8b7d50fc0104ab745652b1cc1b37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 14:25:06 -0500 Subject: [PATCH 27/35] Don't clobber RBX --- basis/cpu/x86/32/32.factor | 4 ---- basis/cpu/x86/64/64.factor | 15 +++++---------- basis/cpu/x86/architecture/architecture.factor | 2 -- 3 files changed, 5 insertions(+), 16 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 67a8ec8a2c..5328f2a263 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -62,10 +62,6 @@ M: float-regs store-return-reg load/store-float-return FSTP ; : with-aligned-stack ( n quot -- ) swap dup align-sub slip align-add ; inline -! On x86, we can always use an address as an operand -! directly. -M: x86.32 address-operand ; - M: x86.32 fixnum>slot@ 1 SHR ; M: x86.32 prepare-division CDQ ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 4770c09a83..c135d0490d 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -33,13 +33,6 @@ M: float-regs vregs M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; -M: x86.64 address-operand ( address -- operand ) - #! On AMD64, we have to load 64-bit addresses into a - #! scratch register first. The usage of R11 here is a hack. - #! This word can only be called right before a subroutine - #! call, where all vregs have been flushed anyway. - temp-reg v>operand [ swap MOV ] keep ; - M: x86.64 fixnum>slot@ drop ; M: x86.64 prepare-division CQO ; @@ -49,8 +42,8 @@ M: x86.64 load-indirect ( literal reg -- ) M: stack-params %load-param-reg drop - >r temp-reg v>operand swap stack@ MOV - r> stack@ temp-reg v>operand MOV ; + >r R11 swap stack@ MOV + r> stack@ R11 MOV ; M: stack-params %save-param-reg >r stack-frame* + cell + swap r> %load-param-reg ; @@ -138,7 +131,9 @@ M: x86.64 %alien-global [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; M: x86.64 %alien-invoke - 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ; + R11 0 MOV + rc-absolute-cell rel-dlsym + R11 CALL ; M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 171e67bcfb..04b496f12a 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -39,8 +39,6 @@ GENERIC: store-return-reg ( stack@ reg-class -- ) HOOK: temp-reg-1 cpu ( -- reg ) HOOK: temp-reg-2 cpu ( -- reg ) -HOOK: address-operand cpu ( address -- operand ) - HOOK: fixnum>slot@ cpu ( op -- ) HOOK: prepare-division cpu ( -- ) From 7724ad2387e355888e6607ede810c0776a37a573 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 13 Sep 2008 18:20:38 -0500 Subject: [PATCH 28/35] allow |b b| || regexps --- unfinished/regexp2/parser/parser-tests.factor | 4 ++++ unfinished/regexp2/parser/parser.factor | 2 +- unfinished/regexp2/regexp2-tests.factor | 7 +++++++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/unfinished/regexp2/parser/parser-tests.factor b/unfinished/regexp2/parser/parser-tests.factor index 9dc7dc7909..6911e8e76d 100644 --- a/unfinished/regexp2/parser/parser-tests.factor +++ b/unfinished/regexp2/parser/parser-tests.factor @@ -31,3 +31,7 @@ IN: regexp2.parser [ ] [ "[a-c]" test-regexp ] unit-test [ ] [ "[^a-c]" test-regexp ] unit-test [ "[^]" test-regexp ] must-fail + +[ ] [ "|b" test-regexp ] unit-test +[ ] [ "b|" test-regexp ] unit-test +[ ] [ "||" test-regexp ] unit-test diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor index a970f82aab..fb1bd08bfe 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp2/parser/parser.factor @@ -67,7 +67,7 @@ left-parenthesis pipe caret dash ; : ( obj -- negation ) negation boa ; : ( seq -- concatenation ) >vector get-reversed-regexp [ reverse ] when - concatenation boa ; + [ epsilon ] [ concatenation boa ] if-empty ; : ( seq -- alternation ) >vector alternation boa ; : ( obj -- capture-group ) capture-group boa ; : ( obj -- kleene-star ) kleene-star boa ; diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp2/regexp2-tests.factor index f691c2becf..e77a7a4419 100644 --- a/unfinished/regexp2/regexp2-tests.factor +++ b/unfinished/regexp2/regexp2-tests.factor @@ -14,6 +14,13 @@ IN: regexp2-tests [ t ] [ "c" "a|b|c" matches? ] unit-test [ f ] [ "c" "d|e|f" matches? ] unit-test +[ t ] [ "b" "|b" matches? ] unit-test +[ t ] [ "b" "b|" matches? ] unit-test +[ t ] [ "" "b|" matches? ] unit-test +[ t ] [ "" "b|" matches? ] unit-test +[ f ] [ "" "|" matches? ] unit-test +[ f ] [ "" "|||||||" matches? ] unit-test + [ f ] [ "aa" "a|b|c" matches? ] unit-test [ f ] [ "bb" "a|b|c" matches? ] unit-test [ f ] [ "cc" "a|b|c" matches? ] unit-test From 8efedbae269656a1397ec22b005bed3d2bffc2bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 20:27:48 -0500 Subject: [PATCH 29/35] Fix tags --- extra/morse/tags.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/morse/tags.txt b/extra/morse/tags.txt index 33a9488b16..1e107f52e4 100644 --- a/extra/morse/tags.txt +++ b/extra/morse/tags.txt @@ -1 +1 @@ -example +examples From 722cacddb485fa5c951ae4bf162c19e696a55b52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 20:28:13 -0500 Subject: [PATCH 30/35] Fixing some problems with returning structs by value in x86.64 FFI --- basis/alien/structs/structs.factor | 12 +- basis/compiler/generator/generator.factor | 28 ++-- basis/compiler/tests/alien.factor | 106 +++++++++++++ basis/cpu/architecture/architecture.factor | 14 +- .../cpu/ppc/architecture/architecture.factor | 7 +- basis/cpu/x86/32/32.factor | 141 ++++++++++-------- basis/cpu/x86/64/64.factor | 128 +++++++++------- .../cpu/x86/architecture/architecture.factor | 15 -- vm/ffi_test.c | 45 ++++++ vm/ffi_test.h | 16 ++ 10 files changed, 349 insertions(+), 163 deletions(-) diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index e82d663d08..ce30a2ee25 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -18,20 +18,16 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; M: struct-type unbox-parameter - [ heap-size %unbox-struct ] - [ unbox-parameter ] - if-value-structs? ; + [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ; M: struct-type unbox-return - f swap heap-size %unbox-struct ; + f swap %unbox-struct ; M: struct-type box-parameter - [ heap-size %box-struct ] - [ box-parameter ] - if-value-structs? ; + [ %box-struct ] [ box-parameter ] if-value-structs? ; M: struct-type box-return - f swap heap-size %box-struct ; + f swap %box-struct ; M: struct-type stack-size [ heap-size ] [ stack-size ] if-value-structs? ; diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 939d6e2276..0a9885357e 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -271,9 +271,7 @@ M: #return-recursive generate-node ! #alien-invoke : large-struct? ( ctype -- ? ) - dup c-struct? [ - heap-size struct-small-enough? not - ] [ drop f ] if ; + dup c-struct? [ struct-small-enough? not ] [ drop f ] if ; : alien-parameters ( params -- seq ) dup parameters>> @@ -304,10 +302,10 @@ M: #return-recursive generate-node alien-parameters parameter-sizes drop ; : alien-invoke-frame ( params -- n ) - #! One cell is temporary storage, temp@ - dup return>> return-size - swap alien-stack-frame + - cell + ; + #! Two cells for temporary storage, temp@ and on x86.64, + #! small struct return value unpacking + [ return>> return-size ] [ alien-stack-frame ] bi + + 2 cells + ; : set-stack-frame ( n -- ) dup [ frame-required ] when* \ stack-frame set ; @@ -361,17 +359,17 @@ M: float-regs inc-reg-class [ spill-param ] [ fastcall-param ] if [ param-reg ] keep ; -: (flatten-int-type) ( size -- ) - cell /i "void*" c-type % ; +: (flatten-int-type) ( size -- types ) + cell /i "void*" c-type ; -GENERIC: flatten-value-type ( type -- ) +GENERIC: flatten-value-type ( type -- types ) -M: object flatten-value-type , ; +M: object flatten-value-type 1array ; -M: struct-type flatten-value-type ( type -- ) +M: struct-type flatten-value-type ( type -- types ) stack-size cell align (flatten-int-type) ; -M: long-long-type flatten-value-type ( type -- ) +M: long-long-type flatten-value-type ( type -- types ) stack-size cell align (flatten-int-type) ; : flatten-value-types ( params -- params ) @@ -379,9 +377,9 @@ M: long-long-type flatten-value-type ( type -- ) [ 0 [ c-type - [ parameter-align (flatten-int-type) ] keep + [ parameter-align (flatten-int-type) % ] keep [ stack-size cell align + ] keep - flatten-value-type + flatten-value-type % ] reduce drop ] { } make ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index dc73888796..635dd42532 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -439,3 +439,109 @@ C-STRUCT: double-rect [ 1.0 2.0 3.0 4.0 ] [ 1.0 2.0 3.0 4.0 double-rect-test >double-rect< ] unit-test + +C-STRUCT: test_struct_14 +{ "double" "x1" } +{ "double" "x2" } ; + +FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; + +[ 1.0 2.0 ] [ + 1.0 2.0 ffi_test_40 + [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi +] unit-test + +: callback-10 ( -- callback ) + "test_struct_14" { "double" "double" } "cdecl" + [ + "test_struct_14" + [ set-test_struct_14-x2 ] keep + [ set-test_struct_14-x1 ] keep + ] alien-callback ; + +: callback-10-test ( x1 x2 callback -- result ) + "test_struct_14" { "double" "double" } "cdecl" alien-indirect ; + +[ 1.0 2.0 ] [ + 1.0 2.0 callback-10 callback-10-test + [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi +] unit-test + +FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; + +[ 1 2.0 ] [ + 1 2.0 ffi_test_41 + [ test-struct-12-a ] [ test-struct-12-x ] bi +] unit-test + +: callback-11 ( -- callback ) + "test-struct-12" { "int" "double" } "cdecl" + [ + "test-struct-12" + [ set-test-struct-12-x ] keep + [ set-test-struct-12-a ] keep + ] alien-callback ; + +: callback-11-test ( x1 x2 callback -- result ) + "test-struct-12" { "int" "double" } "cdecl" alien-indirect ; + +[ 1 2.0 ] [ + 1 2.0 callback-11 callback-11-test + [ test-struct-12-a ] [ test-struct-12-x ] bi +] unit-test + +C-STRUCT: test_struct_15 +{ "float" "x" } +{ "float" "y" } ; + +FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; + +[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test + +: callback-12 ( -- callback ) + "test_struct_15" { "float" "float" } "cdecl" + [ + "test_struct_15" + [ set-test_struct_15-y ] keep + [ set-test_struct_15-x ] keep + ] alien-callback ; + +: callback-12-test ( x1 x2 callback -- result ) + "test_struct_15" { "float" "float" } "cdecl" alien-indirect ; + +[ 1.0 2.0 ] [ + 1.0 2.0 callback-12 callback-12-test + [ test_struct_15-x ] [ test_struct_15-y ] bi +] unit-test + +C-STRUCT: test_struct_16 +{ "float" "x" } +{ "int" "a" } ; + +FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; + +[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test + +: callback-13 ( -- callback ) + "test_struct_16" { "float" "int" } "cdecl" + [ + "test_struct_16" + [ set-test_struct_16-a ] keep + [ set-test_struct_16-x ] keep + ] alien-callback ; + +: callback-13-test ( x1 x2 callback -- result ) + "test_struct_16" { "float" "int" } "cdecl" alien-indirect ; + +[ 1.0 2 ] [ + 1.0 2 callback-13 callback-13-test + [ test_struct_16-x ] [ test_struct_16-a ] bi +] unit-test + +FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline + +[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test + +: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; + +[ ] [ stack-frame-bustage 2drop ] unit-test diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 432e748cbf..63c52d1025 100755 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -95,7 +95,7 @@ HOOK: %box-float cpu ( dst src -- ) HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( size -- ? ) +HOOK: struct-small-enough? cpu ( heap-size -- ? ) ! Do we pass explode value structs? HOOK: value-structs? cpu ( -- ? ) @@ -109,9 +109,9 @@ HOOK: %unbox cpu ( n reg-class func -- ) HOOK: %unbox-long-long cpu ( n func -- ) -HOOK: %unbox-small-struct cpu ( size -- ) +HOOK: %unbox-small-struct cpu ( c-type -- ) -HOOK: %unbox-large-struct cpu ( n size -- ) +HOOK: %unbox-large-struct cpu ( n c-type -- ) HOOK: %box cpu ( n reg-class func -- ) @@ -119,9 +119,9 @@ HOOK: %box-long-long cpu ( n func -- ) HOOK: %prepare-box-struct cpu ( size -- ) -HOOK: %box-small-struct cpu ( size -- ) +HOOK: %box-small-struct cpu ( c-type -- ) -HOOK: %box-large-struct cpu ( n size -- ) +HOOK: %box-large-struct cpu ( n c-type -- ) GENERIC: %save-param-reg ( stack reg reg-class -- ) @@ -169,14 +169,14 @@ PREDICATE: small-tagged < integer v>operand small-enough? ; [ [ nip ] prepose ] dip if ; inline -: %unbox-struct ( n size -- ) +: %unbox-struct ( n c-type -- ) [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; -: %box-struct ( n size -- ) +: %box-struct ( n c-type -- ) [ %box-small-struct ] [ diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 12fbbea82e..38ffe50bd6 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -195,10 +195,10 @@ M: ppc %unbox-long-long ( n func -- ) 4 1 rot cell + local@ STW ] when* ; -M: ppc %unbox-large-struct ( n size -- ) +M: ppc %unbox-large-struct ( n c-type -- ) ! Value must be in r3 ! Compute destination address - 4 1 roll local@ ADDI + 4 1 roll heap-size local@ ADDI ! Load struct size 5 LI ! Call the function @@ -227,8 +227,9 @@ M: ppc %prepare-box-struct ( size -- ) 3 1 rot f struct-return@ ADDI 3 1 0 local@ STW ; -M: ppc %box-large-struct ( n size -- ) +M: ppc %box-large-struct ( n c-type -- ) #! If n = f, then we're boxing a returned struct + heap-size [ swap struct-return@ ] keep ! Compute destination address 3 1 roll ADDI diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 5328f2a263..50d8025b38 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -28,6 +28,10 @@ M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 struct-small-enough? ( size -- ? ) + heap-size { 1 2 4 8 } member? + os { linux netbsd solaris } member? not and ; + ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; M: int-regs param-regs drop { } ; @@ -73,62 +77,6 @@ M: object %load-param-reg 3drop ; M: object %save-param-reg 3drop ; -M: x86.32 %prepare-unbox ( -- ) - #! Move top of data stack to EAX. - EAX ESI [] MOV - ESI 4 SUB ; - -: (%unbox) ( func -- ) - 4 [ - ! Push parameter - EAX PUSH - ! Call the unboxer - f %alien-invoke - ] with-aligned-stack ; - -M: x86.32 %unbox ( n reg-class func -- ) - #! The value being unboxed must already be in EAX. - #! If n is f, we're unboxing a return value about to be - #! returned by the callback. Otherwise, we're unboxing - #! a parameter to a C function about to be called. - (%unbox) - ! Store the return value on the C stack - over [ store-return-reg ] [ 2drop ] if ; - -M: x86.32 %unbox-long-long ( n func -- ) - (%unbox) - ! Store the return value on the C stack - [ - dup stack@ EAX MOV - cell + stack@ EDX MOV - ] when* ; - -M: x86.32 %unbox-struct-2 - #! Alien must be in EAX. - 4 [ - EAX PUSH - "alien_offset" f %alien-invoke - ! Load second cell - EDX EAX 4 [+] MOV - ! Load first cell - EAX EAX [] MOV - ] with-aligned-stack ; - -M: x86.32 %unbox-large-struct ( n size -- ) - #! Alien must be in EAX. - ! Compute destination address - ECX ESP roll [+] LEA - 12 [ - ! Push struct size - PUSH - ! Push destination address - ECX PUSH - ! Push source address - EAX PUSH - ! Copy the struct to the stack - "to_value_struct" f %alien-invoke - ] with-aligned-stack ; - : box@ ( n reg-class -- stack@ ) #! Used for callbacks; we want to box the values given to #! us by the C function caller. Computes stack location of @@ -172,8 +120,9 @@ M: x86.32 %box-long-long ( n func -- ) : struct-return@ ( size n -- n ) [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ; -M: x86.32 %box-large-struct ( n size -- ) +M: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address + heap-size [ swap struct-return@ ] keep ECX ESP roll [+] LEA 8 [ @@ -191,7 +140,46 @@ M: x86.32 %prepare-box-struct ( size -- ) ! Store it as the first parameter ESP [] EAX MOV ; -M: x86.32 %unbox-struct-1 +M: x86.32 %box-small-struct ( c-type -- ) + #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. + 12 [ + heap-size PUSH + EDX PUSH + EAX PUSH + "box_small_struct" f %alien-invoke + ] with-aligned-stack ; + +M: x86.32 %prepare-unbox ( -- ) + #! Move top of data stack to EAX. + EAX ESI [] MOV + ESI 4 SUB ; + +: (%unbox) ( func -- ) + 4 [ + ! Push parameter + EAX PUSH + ! Call the unboxer + f %alien-invoke + ] with-aligned-stack ; + +M: x86.32 %unbox ( n reg-class func -- ) + #! The value being unboxed must already be in EAX. + #! If n is f, we're unboxing a return value about to be + #! returned by the callback. Otherwise, we're unboxing + #! a parameter to a C function about to be called. + (%unbox) + ! Store the return value on the C stack + over [ store-return-reg ] [ 2drop ] if ; + +M: x86.32 %unbox-long-long ( n func -- ) + (%unbox) + ! Store the return value on the C stack + [ + dup stack@ EAX MOV + cell + stack@ EDX MOV + ] when* ; + +: %unbox-struct-1 ( -- ) #! Alien must be in EAX. 4 [ EAX PUSH @@ -200,13 +188,38 @@ M: x86.32 %unbox-struct-1 EAX EAX [] MOV ] with-aligned-stack ; -M: x86.32 %box-small-struct ( size -- ) - #! Box a <= 8-byte struct returned in EAX:DX. OS X only. - 12 [ - PUSH - EDX PUSH +: %unbox-struct-2 ( -- ) + #! Alien must be in EAX. + 4 [ EAX PUSH - "box_small_struct" f %alien-invoke + "alien_offset" f %alien-invoke + ! Load second cell + EDX EAX 4 [+] MOV + ! Load first cell + EAX EAX [] MOV + ] with-aligned-stack ; + +M: x86 %unbox-small-struct ( size -- ) + #! Alien must be in EAX. + heap-size cell align cell /i { + { 1 [ %unbox-struct-1 ] } + { 2 [ %unbox-struct-2 ] } + } case ; + +M: x86.32 %unbox-large-struct ( n c-type -- ) + #! Alien must be in EAX. + heap-size + ! Compute destination address + ECX ESP roll [+] LEA + 12 [ + ! Push struct size + PUSH + ! Push destination address + ECX PUSH + ! Push source address + EAX PUSH + ! Copy the struct to the stack + "to_value_struct" f %alien-invoke ] with-aligned-stack ; M: x86.32 %prepare-alien-indirect ( -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c135d0490d..01b8935e39 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 @@ -6,7 +6,7 @@ cpu.x86.allot cpu.architecture kernel kernel.private math namespaces make sequences compiler.generator compiler.generator.registers compiler.generator.fixup system layouts alien alien.accessors alien.structs slots splitting -assocs ; +assocs combinators ; IN: cpu.x86.64 M: x86.64 ds-reg R14 ; @@ -48,6 +48,44 @@ M: stack-params %load-param-reg M: stack-params %save-param-reg >r stack-frame* + cell + swap r> %load-param-reg ; +: with-return-regs ( quot -- ) + [ + V{ RDX RAX } clone int-regs set + V{ XMM1 XMM0 } clone float-regs set + call + ] with-scope ; inline + +! The ABI for passing structs by value is pretty messed up +<< "void*" c-type clone "__stack_value" define-primitive-type +stack-params "__stack_value" c-type (>>reg-class) >> + +: struct-types&offset ( struct-type -- pairs ) + fields>> [ + [ type>> ] [ offset>> ] bi 2array + ] map ; + +: split-struct ( pairs -- seq ) + [ + [ 8 mod zero? [ t , ] when , ] assoc-each + ] { } make { t } split harvest ; + +: flatten-small-struct ( c-type -- seq ) + struct-types&offset split-struct [ + [ c-type c-type-reg-class ] map + int-regs swap member? "void*" "double" ? c-type + ] map ; + +: flatten-large-struct ( c-type -- seq ) + heap-size cell align + cell /i "__stack_value" c-type ; + +M: struct-type flatten-value-type ( type -- seq ) + dup heap-size 16 > [ + flatten-large-struct + ] [ + flatten-small-struct + ] if ; + M: x86.64 %prepare-unbox ( -- ) ! First parameter is top of stack RDI R14 [] MOV @@ -62,22 +100,26 @@ M: x86.64 %unbox ( n reg-class func -- ) M: x86.64 %unbox-long-long ( n func -- ) int-regs swap %unbox ; -M: x86.64 %unbox-struct-1 ( -- ) - #! Alien must be in RDI. - "alien_offset" f %alien-invoke - ! Load first cell - RAX RAX [] MOV ; +: %unbox-struct-field ( c-type i -- ) + ! Alien must be in RDI. + RDI swap cells [+] swap reg-class>> { + { int-regs [ int-regs get pop swap MOV ] } + { double-float-regs [ float-regs get pop swap MOVSD ] } + } case ; -M: x86.64 %unbox-struct-2 ( -- ) - #! Alien must be in RDI. +M: x86.64 %unbox-small-struct ( c-type -- ) + ! Alien must be in RDI. "alien_offset" f %alien-invoke - ! Load second cell - RDX RAX cell [+] MOV - ! Load first cell - RAX RAX [] MOV ; + ! Move alien_offset() return value to RDI so that we don't + ! clobber it. + RDI RAX MOV + [ + flatten-small-struct [ %unbox-struct-field ] each-index + ] with-return-regs ; -M: x86.64 %unbox-large-struct ( n size -- ) +M: x86.64 %unbox-large-struct ( n c-type -- ) ! Source is in RDI + heap-size ! Load destination address RSI RSP roll [+] LEA ! Load structure size @@ -100,20 +142,33 @@ M: x86.64 %box ( n reg-class func -- ) M: x86.64 %box-long-long ( n func -- ) int-regs swap %box ; -M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; +M: x86.64 struct-small-enough? ( size -- ? ) + heap-size 2 cells <= ; -M: x86.64 %box-small-struct ( size -- ) - #! Box a <= 16-byte struct returned in RAX:RDX. - RDI RAX MOV - RSI RDX MOV - RDX swap MOV - "box_small_struct" f %alien-invoke ; +: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ; + +: %box-struct-field ( c-type i -- ) + box-struct-field@ swap reg-class>> { + { int-regs [ int-regs get pop MOV ] } + { double-float-regs [ float-regs get pop MOVSD ] } + } case ; + +M: x86.64 %box-small-struct ( c-type -- ) + #! Box a <= 16-byte struct. + [ + [ flatten-small-struct [ %box-struct-field ] each-index ] + [ RDX swap heap-size MOV ] bi + RDI 0 box-struct-field@ MOV + RSI 1 box-struct-field@ MOV + "box_small_struct" f %alien-invoke + ] with-return-regs ; : struct-return@ ( size n -- n ) [ ] [ \ stack-frame get swap - ] ?if ; -M: x86.64 %box-large-struct ( n size -- ) +M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 + heap-size RSI over MOV ! Compute destination address swap struct-return@ RDI RSP rot [+] LEA @@ -170,32 +225,3 @@ USE: cpu.x86.intrinsics \ alien-signed-4 small-reg-32 define-signed-getter \ set-alien-signed-4 small-reg-32 define-setter - -! The ABI for passing structs by value is pretty messed up -<< "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type (>>reg-class) >> - -: struct-types&offset ( struct-type -- pairs ) - fields>> [ - [ type>> ] [ offset>> ] bi 2array - ] map ; - -: split-struct ( pairs -- seq ) - [ - [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split harvest ; - -: flatten-large-struct ( type -- ) - heap-size cell align - cell /i "__stack_value" c-type % ; - -M: struct-type flatten-value-type ( type -- seq ) - dup heap-size 16 > [ - flatten-large-struct - ] [ - struct-types&offset split-struct [ - [ c-type c-type-reg-class ] map - int-regs swap member? - "void*" "double" ? c-type , - ] each - ] if ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 04b496f12a..c97552a649 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -139,21 +139,6 @@ M: x86 small-enough? ( n -- ? ) : temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ; -HOOK: %unbox-struct-1 cpu ( -- ) - -HOOK: %unbox-struct-2 cpu ( -- ) - -M: x86 %unbox-small-struct ( size -- ) - #! Alien must be in EAX. - cell align cell /i { - { 1 [ %unbox-struct-1 ] } - { 2 [ %unbox-struct-2 ] } - } case ; - -M: x86 struct-small-enough? ( size -- ? ) - { 1 2 4 8 } member? - os { linux netbsd solaris } member? not and ; - M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 44a14f21f5..081ae42ebf 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -280,3 +280,48 @@ int ffi_test_39(long a, long b, struct test_struct_13 s) if(a != b) abort(); return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6; } + +struct test_struct_14 ffi_test_40(double x1, double x2) +{ + struct test_struct_14 retval; + retval.x1 = x1; + retval.x2 = x2; + printf("ffi_test_40(%f,%f)\n",x1,x2); + return retval; +} + +struct test_struct_12 ffi_test_41(int a, double x) +{ + struct test_struct_12 retval; + retval.a = a; + retval.x = x; + printf("ffi_test_41(%d,%f)\n",a,x); + return retval; +} + +struct test_struct_15 ffi_test_42(float x, float y) +{ + struct test_struct_15 retval; + retval.x = x; + retval.y = y; + printf("ffi_test_42(%f,%f)\n",x,y); + return retval; +} + +struct test_struct_16 ffi_test_43(float x, int a) +{ + struct test_struct_16 retval; + retval.x = x; + retval.a = a; + printf("ffi_test_43(%f,%d)\n",x,a); + return retval; +} + +struct test_struct_14 ffi_test_44(void) +{ + struct test_struct_14 retval; + retval.x1 = 1.0; + retval.x2 = 2.0; + //printf("ffi_test_44()\n"); + return retval; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 779cb97857..f9195a4285 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -71,3 +71,19 @@ DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long lon struct test_struct_13 { float x1, x2, x3, x4, x5, x6; }; DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s); + +struct test_struct_14 { double x1, x2; }; + +DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2); + +DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x); + +struct test_struct_15 { float x, y; }; + +DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y); + +struct test_struct_16 { float x; int a; }; + +DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); + +DLLEXPORT struct test_struct_14 ffi_test_44(); From 2305117c213aa47cfaa80dd62f29df85cb4221fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 20:40:54 -0500 Subject: [PATCH 31/35] Fix PPC bootstrap --- basis/cpu/ppc/architecture/architecture.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 38ffe50bd6..80ee1802e1 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -198,9 +198,9 @@ M: ppc %unbox-long-long ( n func -- ) M: ppc %unbox-large-struct ( n c-type -- ) ! Value must be in r3 ! Compute destination address - 4 1 roll heap-size local@ ADDI + 4 1 roll local@ ADDI ! Load struct size - 5 LI + heap-size 5 LI ! Call the function "to_value_struct" f %alien-invoke ; From 7887515d0057c62ee607086af870f160ea7cdc62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 13 Sep 2008 21:23:25 -0500 Subject: [PATCH 32/35] Fix stack effects of load-source, load-docs so that stack isn't filled up with crap in stage2 --- core/vocabs/loader/loader.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 44f538d5d9..f48a3d1950 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -54,19 +54,19 @@ SYMBOL: load-help? : load-source ( vocab -- vocab ) f over set-vocab-source-loaded? [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep - t over set-vocab-source-loaded? - [ [ % ] [ call ] if-bootstrapping ] dip ; + t swap set-vocab-source-loaded? + [ % ] [ call ] if-bootstrapping ; : load-docs ( vocab -- vocab ) load-help? get [ f over set-vocab-docs-loaded? [ vocab-docs-path [ ?run-file ] when* ] keep - t over set-vocab-docs-loaded? - ] when ; + t swap set-vocab-docs-loaded? + ] [ drop ] if ; : reload ( name -- ) [ - dup vocab [ load-source load-docs drop ] [ no-vocab ] ?if + dup vocab [ [ load-source ] [ load-docs ] bi ] [ no-vocab ] ?if ] with-compiler-errors ; : require ( vocab -- ) @@ -90,8 +90,8 @@ GENERIC: (load-vocab) ( name -- ) M: vocab (load-vocab) [ - dup vocab-source-loaded? [ load-source ] unless - dup vocab-docs-loaded? [ load-docs ] unless + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless drop ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; From 95c905f9ec236f42618795b8bfa1147486997e93 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 13 Sep 2008 21:24:36 -0500 Subject: [PATCH 33/35] update the build script to check for 64bit mac. defaults to 32bit for now --- build-support/factor.sh | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index c60ab46671..f3a2f27fec 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -197,7 +197,7 @@ write_test_program() { echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } -find_word_size() { +c_find_word_size() { $ECHO "Finding WORD..." C_WORD=factor-word-size write_test_program @@ -207,6 +207,28 @@ find_word_size() { rm -f $C_WORD* } +macosx_supports_64bit() { + ensure_program_installed sysctl + $ECHO -n "Testing if your Intel Mac supports 64bit binaries..." + sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null + if [[ $? -eq 0 ]] ; then + WORD=32 + $ECHO "yes!" + $ECHO "Defaulting to 32bit for now though..." + else + WORD=32 + $ECHO "no." + fi +} + +find_word_size() { + if [[ $OS -eq "macosx" && $ARCH -eq "x86" ]] ; then + macosx_supports_64bit + else + c_find_word_size + fi +} + set_factor_binary() { case $OS in # winnt) FACTOR_BINARY=factor-nt;; @@ -415,8 +437,7 @@ make_boot_image() { } install_build_system_apt() { - ensure_program_installed yes - yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make check_ret sudo } @@ -447,6 +468,7 @@ case "$1" in quick-update) update; refresh_image ;; update) update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; + report) find_build_info ;; dlls) get_config_info; maybe_download_dlls;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; From cd10ca1b239ac6cc181a4c22aebd32e8c442de5e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 13 Sep 2008 22:00:54 -0500 Subject: [PATCH 34/35] add ability to override default target --- build-support/factor.sh | 49 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 44 insertions(+), 5 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index f3a2f27fec..fa3252cdaa 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -159,6 +159,7 @@ check_factor_exists() { } find_os() { + if [[ -n $OS ]] ; then return; fi $ECHO "Finding OS..." uname_s=`uname -s` check_ret uname @@ -178,6 +179,7 @@ find_os() { } find_architecture() { + if [[ -n $ARCH ]] ; then return; fi $ECHO "Finding ARCH..." uname_m=`uname -m` check_ret uname @@ -207,7 +209,7 @@ c_find_word_size() { rm -f $C_WORD* } -macosx_supports_64bit() { +intel_macosx_word_size() { ensure_program_installed sysctl $ECHO -n "Testing if your Intel Mac supports 64bit binaries..." sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null @@ -222,8 +224,9 @@ macosx_supports_64bit() { } find_word_size() { + if [[ -n $WORD ]] ; then return; fi if [[ $OS -eq "macosx" && $ARCH -eq "x86" ]] ; then - macosx_supports_64bit + intel_macosx_word_size else c_find_word_size fi @@ -252,15 +255,18 @@ echo_build_info() { $ECHO MAKE=$MAKE } -set_build_info() { +check_os_arch_word() { if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then $ECHO "OS: $OS" $ECHO "ARCH: $ARCH" $ECHO "WORD: $WORD" - $ECHO "OS, ARCH, or WORD is empty. Please report this" + $ECHO "OS, ARCH, or WORD is empty. Please report this." exit 5 fi +} +set_build_info() { + check_os_arch_word MAKE_TARGET=$OS-$ARCH-$WORD MAKE_IMAGE_TARGET=$ARCH.$WORD BOOT_IMAGE=boot.$ARCH.$WORD.image @@ -276,6 +282,31 @@ set_build_info() { fi } +parse_build_info() { + ensure_program_installed cut + $ECHO "Parsing make target from command line: $1" + OS=`echo $1 | cut -d '-' -f 1` + ARCH=`echo $1 | cut -d '-' -f 2` + WORD=`echo $1 | cut -d '-' -f 3` + + if [[ $OS == linux && $ARCH == ppc ]] ; then + WORD=32 + fi + if [[ $OS == linux && $ARCH == arm ]] ; then + WORD=32 + fi + if [[ $OS == macosx && $ARCH == ppc ]] ; then + WORD=32 + fi + if [[ $OS == wince && $ARCH == arm ]] ; then + WORD=32 + fi + + $ECHO "OS=$OS" + $ECHO "ARCH=$ARCH" + $ECHO "WORD=$WORD" +} + find_build_info() { find_os find_architecture @@ -455,11 +486,19 @@ install_build_system_port() { } usage() { - echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target" + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]" echo "If you are behind a firewall, invoke as:" echo "env GIT_PROTOCOL=http $0 " + echo "" + echo "Example for overriding the default target:" + echo " $0 update macosx-x86-32" } +# -n is nonzero length, -z is zero length +if [[ -n "$2" ]] ; then + parse_build_info $2 +fi + case "$1" in install) install ;; install-x11) install_build_system_apt; install ;; From 0895201f27841a3706022c986976279a0558c5b9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 13 Sep 2008 22:18:56 -0500 Subject: [PATCH 35/35] more readable build script --- build-support/factor.sh | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index fa3252cdaa..f247ddb27e 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -289,18 +289,10 @@ parse_build_info() { ARCH=`echo $1 | cut -d '-' -f 2` WORD=`echo $1 | cut -d '-' -f 3` - if [[ $OS == linux && $ARCH == ppc ]] ; then - WORD=32 - fi - if [[ $OS == linux && $ARCH == arm ]] ; then - WORD=32 - fi - if [[ $OS == macosx && $ARCH == ppc ]] ; then - WORD=32 - fi - if [[ $OS == wince && $ARCH == arm ]] ; then - WORD=32 - fi + if [[ $OS == linux && $ARCH == ppc ]] ; then WORD=32; fi + if [[ $OS == linux && $ARCH == arm ]] ; then WORD=32; fi + if [[ $OS == macosx && $ARCH == ppc ]] ; then WORD=32; fi + if [[ $OS == wince && $ARCH == arm ]] ; then WORD=32; fi $ECHO "OS=$OS" $ECHO "ARCH=$ARCH"