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 } 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" 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/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 ] 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" 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/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/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* ; 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..d73e8b7db1 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -6,27 +6,13 @@ 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 locals +float-arrays ; 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 +580,16 @@ 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{ float-array } ] [ [| | F{ } ] final-classes ] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test 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/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..80ee1802e1 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -195,12 +195,12 @@ 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 ! Load struct size - 5 LI + heap-size 5 LI ! Call the function "to_value_struct" f %alien-invoke ; @@ -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 67a8ec8a2c..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 { } ; @@ -62,10 +66,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 ; @@ -77,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 @@ -176,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 [ @@ -195,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 @@ -204,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 4770c09a83..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 ; @@ -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,12 +42,50 @@ 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 ; +: 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 @@ -69,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 @@ -107,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 @@ -138,7 +186,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 @@ -175,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 171e67bcfb..c97552a649 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 ( -- ) @@ -141,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/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 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 [ 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 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 diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime-types/mime-types-docs.factor new file mode 100644 index 0000000000..b7fa46d587 --- /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 + { "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 } "." } ; + +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" 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/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/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 diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 96c2ec2fcc..c836bfc2b6 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,20 +49,18 @@ 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 ; : (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 ; diff --git a/build-support/factor.sh b/build-support/factor.sh index cda833d581..f247ddb27e 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 @@ -197,7 +199,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 +209,29 @@ find_word_size() { rm -f $C_WORD* } +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 + 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 [[ -n $WORD ]] ; then return; fi + if [[ $OS -eq "macosx" && $ARCH -eq "x86" ]] ; then + intel_macosx_word_size + else + c_find_word_size + fi +} + set_factor_binary() { case $OS in # winnt) FACTOR_BINARY=factor-nt;; @@ -230,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 @@ -254,6 +282,23 @@ 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 @@ -415,7 +460,6 @@ make_boot_image() { } install_build_system_apt() { - ensure_program_installed yes 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 } @@ -434,11 +478,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 ;; @@ -447,6 +499,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 ;; 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 diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 8018fe1cdc..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 ; @@ -266,3 +266,5 @@ 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 + +[ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 57dba9ed4e..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 ; @@ -480,8 +480,13 @@ PRIVATE> : last-index-from ( obj i seq -- n ) rot [ = ] curry find-last-from drop ; -: nths ( seq indices -- seq' ) - swap [ nth ] curry map ; +: indices ( obj seq -- indices ) + V{ } clone spin + [ rot = [ over push ] [ drop ] if ] + curry each-index ; + +: nths ( indices seq -- seq' ) + [ nth ] curry map ; : contains? ( seq quot -- ? ) find drop >boolean ; inline 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 ; 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 diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 6d4d42116c..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 @@ -41,7 +43,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 ; 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/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 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 ; 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 ; - >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-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 206db3883d..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 ; @@ -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..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 @@ -222,6 +229,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' ) 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();