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

Merge branch 'master' of git://factorcode.org/git/factor 

Conflicts:

	build-support/factor.sh
db4
Doug Coleman 2008-09-13 22:21:54 -05:00
parent 3676b8812a 0895201f27
commit af3af9c74b
66 changed files with 1168 additions and 567 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms-docs.factor
View File

@ -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 }

9
basis/alias/alias-docs.factor
View File

@ -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"

12
basis/alien/structs/structs.factor
View File

@ -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? ;

2
basis/ascii/ascii-docs.factor
View File

@ -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? }

18
basis/base64/base64-docs.factor
View File

@ -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"

2
basis/base64/base64.factor
View File

@ -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 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = ] count-end ]

22
basis/binary-search/binary-search-docs.factor
View File

@ -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"

28
basis/compiler/generator/generator.factor
View File

@ -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 <repetition> % ;
: (flatten-int-type) ( size -- types )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- )
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type , ;
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- )
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@ -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 ;

106
basis/compiler/tests/alien.factor
View File

@ -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> 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" <c-object>
[ 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" <c-object>
[ 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" <c-object>
[ 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" <c-object>
[ 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

16
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -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

8
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -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<= ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -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 ;

2
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -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* ;

45
basis/compiler/tree/debugger/debugger.factor
View File

@ -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 ;

10
basis/compiler/tree/def-use/simplified/simplified-tests.factor Normal file
View File

@ -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

40
basis/compiler/tree/def-use/simplified/simplified.factor Normal file
View File

@ -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 ;

31
basis/compiler/tree/finalization/finalization.factor
View File

@ -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? ;

29
basis/compiler/tree/late-optimizations/late-optimizations.factor Normal file
View File

@ -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 ;

130
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor Normal file
View File

@ -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

108
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor Normal file
View File

@ -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 ;

5
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -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 ;

13
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -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 ;

26
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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

30
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

119
basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
View File

@ -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

5
basis/compiler/tree/strength-reduction/strength-reduction.factor
View File

@ -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' ) ;

14
basis/cpu/architecture/architecture.factor
View File

@ -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
] [

7
basis/cpu/ppc/architecture/architecture.factor
View File

@ -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

145
basis/cpu/x86/32/32.factor
View File

@ -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 ( -- )

143
basis/cpu/x86/64/64.factor
View File

@ -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 <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
@ -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 <repetition> % ;
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 ;

17
basis/cpu/x86/architecture/architecture.factor
View File

@ -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

21
basis/hints/hints-docs.factor
View File

@ -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"

5
basis/hints/hints.factor
View File

@ -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

4
basis/locals/locals-tests.factor
View File

@ -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
[ 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

93
basis/locals/locals.factor
View File

@ -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 <repetition> % ;
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 [
<local-reader>

17
basis/math/partial-dispatch/partial-dispatch-tests.factor
View File

@ -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

54
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -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

4
basis/math/vectors/vectors-tests.factor
View File

@ -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

35
basis/mime-types/mime-types-docs.factor Normal file
View File

@ -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"

2
basis/sorting/human/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Doug Coleman
Slava Pestov

6
basis/sorting/human/human-tests.factor Normal file
View File

@ -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

10
basis/sorting/human/human.factor Normal file
View File

@ -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 ;

1
basis/sorting/human/summary.txt Normal file
View File

@ -0,0 +1 @@
Correct sorting of sequences of strings with embedded numbers

2
basis/sorting/human/tags.txt Normal file
View File

@ -0,0 +1,2 @@
collections
text

18
basis/tools/annotations/annotations.factor
View File

@ -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 ;

63
build-support/factor.sh
View File

@ -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 <command>"
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 ;;

2
core/kernel/kernel-docs.factor
View File

@ -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

12
core/sequences/sequences-tests.factor
View File

@ -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

11
core/sequences/sequences.factor
View File

@ -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

14
core/vocabs/loader/loader.factor
View File

@ -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 ;

60
extra/benchmark/raytracer/raytracer.factor
View File

@ -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
: 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 <hit> nip ] if-ray-sphere ;
@ -79,21 +85,17 @@ TUPLE: group < sphere { objs array read-only } ;
swap [ { } make ] dip <group> ; 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 <ray> ] 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

6
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -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 <repetition> >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 ;

2
extra/math/combinatorics/combinatorics.factor
View File

@ -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 )
[

2
extra/morse/tags.txt
View File

@ -1 +1 @@
example
examples

2
extra/project-euler/186/186.factor
View File

@ -9,7 +9,7 @@ IN: project-euler.186
55 [1,b] [ (generator) ] map <circular> ;
: 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 ;

25
extra/sequences/lib/lib.factor
View File

@ -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 ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )
[

1
unfinished/regexp2/backend/backend.factor
View File

@ -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

2
unfinished/regexp2/dfa/dfa.factor
View File

@ -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 )

4
unfinished/regexp2/parser/parser-tests.factor
View File

@ -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

4
unfinished/regexp2/parser/parser.factor
View File

@ -67,7 +67,7 @@ left-parenthesis pipe caret dash ;
: <negation> ( obj -- negation ) negation boa ;
: <concatenation> ( seq -- concatenation )
>vector get-reversed-regexp [ reverse ] when
concatenation boa ;
[ epsilon ] [ concatenation boa ] if-empty ;
: <alternation> ( seq -- alternation ) >vector alternation boa ;
: <capture-group> ( obj -- capture-group ) capture-group boa ;
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
@ -291,6 +291,8 @@ ERROR: bad-escaped-literals seq ;
{ CHAR: f [ HEX: c <constant> ] }
{ CHAR: a [ HEX: 7 <constant> ] }
{ CHAR: e [ HEX: 1b <constant> ] }
{ CHAR: $ [ CHAR: $ <constant> ] }
{ CHAR: ^ [ CHAR: ^ <constant> ] }
{ CHAR: d [ digit-class ] }
{ CHAR: D [ digit-class <negation> ] }

9
unfinished/regexp2/regexp2-tests.factor
View File

@ -14,6 +14,13 @@ IN: regexp2-tests
[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
[ t ] [ "b" "|b" <regexp> matches? ] unit-test
[ t ] [ "b" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
[ f ] [ "" "|" <regexp> matches? ] unit-test
[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
@ -222,6 +229,8 @@ IN: regexp2-tests
<regexp> drop
] unit-test
[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
! Comment
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test

31
unfinished/regexp2/regexp2.factor
View File

@ -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
<transition-table> >>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: ` <regexp> ; parsing
: R{ CHAR: } <regexp> ; parsing
: R| CHAR: | <regexp> ; 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 ;

4
unfinished/regexp2/traversal/traversal.factor
View File

@ -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 )

2
unfinished/regexp2/utils/utils.factor
View File

@ -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' )

45
vm/ffi_test.c
View File

@ -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;
}

16
vm/ffi_test.h
View File

@ -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();