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

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

db4
Joe Groff 2009-06-25 09:15:24 -05:00
parent b6abd4a90c 12a672b9f1
commit 1c0a0155eb
9 changed files with 235 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1414,7 +1414,7 @@ USING: math.private ;
{ uses { 5 10 } } { uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } } { ranges V{ T{ live-range f 5 10 } } }
} }
intersect-inactive relevant-ranges intersect-live-ranges
] unit-test ] unit-test
! Bug in live spill slots calculation ! Bug in live spill slots calculation

85
basis/compiler/cfg/stack-analysis/merge/merge.factor Normal file
View File

@ -0,0 +1,85 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping
sets compiler.cfg compiler.cfg.hats
compiler.cfg.stack-analysis.state ;
IN: compiler.cfg.stack-analysis.merge
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
ERROR: must-equal-failed seq ;
: must-equal ( seq -- elt )
dup all-equal? [ first ] [ must-equal-failed ] if ;
: merge-heights ( state predecessors states -- state )
nip
[ [ ds-height>> ] map must-equal >>ds-height ]
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
: insert-peek ( predecessor loc -- vreg )
! XXX critical edges
'[ _ ^^peek ] add-instructions ;
: merge-loc ( predecessors locs>vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
[ '[ [ _ ] dip at ] map ] keep
'[ [ ] [ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ;
: (merge-locs) ( predecessors assocs -- assoc )
dup [ keys ] map concat prune
[ [ 2nip ] [ merge-loc ] 3bi ] with with
H{ } map>assoc ;
: merge-locs ( state predecessors states -- state )
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
: merge-actual-loc ( locs>vregs loc -- vreg )
'[ [ _ ] dip at ] map
dup all-equal? [ first ] [ drop f ] if ;
: merge-actual-locs ( state predecessors states -- state )
nip
[ actual-locs>vregs>> ] map
dup [ keys ] map concat prune
[ [ nip ] [ merge-actual-loc ] 2bi ] with
H{ } map>assoc
[ nip ] assoc-filter
>>actual-locs>vregs ;
: merge-changed-locs ( state predecessors states -- state )
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
[ <state> ] 2dip
sift merge-heights
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
] [
[ state new ] 2dip
[ predecessors>> ] dip
{
[ merge-locs ]
[ merge-actual-locs ]
[ merge-heights ]
[ merge-changed-locs ]
} 2cleave
] if
] if ;
: merge-states ( bb states -- state )
! If any states are poisoned, save all registers
! to the stack in each branch
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
} case ;

150
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -1,42 +1,19 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping USING: accessors assocs kernel namespaces math sequences fry grouping
sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use sets make combinators
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo compiler.cfg
compiler.cfg.hats compiler.cfg ; compiler.cfg.copy-prop
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge ;
IN: compiler.cfg.stack-analysis IN: compiler.cfg.stack-analysis
! Convert stack operations to register operations ! Convert stack operations to register operations
! If 'poisoned' is set, disregard height information. This is set if we don't have
! height change information for an instruction.
TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
: <state> ( -- state )
state new
H{ } clone >>locs>vregs
H{ } clone >>actual-locs>vregs
H{ } clone >>changed-locs
0 >>ds-height
0 >>rs-height ;
M: state clone
call-next-method
[ clone ] change-locs>vregs
[ clone ] change-actual-locs>vregs
[ clone ] change-changed-locs ;
: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
: record-peek ( dst loc -- )
state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
: changed-loc ( loc -- )
state get changed-locs>> conjoin ;
: record-replace ( src loc -- )
dup changed-loc state get locs>vregs>> set-at ;
GENERIC: height-for ( loc -- n ) GENERIC: height-for ( loc -- n )
M: ds-loc height-for drop state get ds-height>> ; M: ds-loc height-for drop state get ds-height>> ;
@ -64,12 +41,6 @@ M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
[ 2drop ] [ untranslate-loc ##replace ] if [ 2drop ] [ untranslate-loc ##replace ] if
] assoc-each ; ] assoc-each ;
: clear-state ( state -- )
[ locs>vregs>> clear-assoc ]
[ actual-locs>vregs>> clear-assoc ]
[ changed-locs>> clear-assoc ]
tri ;
ERROR: poisoned-state state ; ERROR: poisoned-state state ;
: sync-state ( -- ) : sync-state ( -- )
@ -84,6 +55,14 @@ ERROR: poisoned-state state ;
! Abstract interpretation ! Abstract interpretation
GENERIC: visit ( insn -- ) GENERIC: visit ( insn -- )
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
! Instructions which don't have any effect on the stack ! Instructions which don't have any effect on the stack
UNION: neutral-insn UNION: neutral-insn
##flushable ##flushable
@ -113,14 +92,6 @@ t local-only? set-global
M: sync-if-back-edge visit M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ; sync-state? [ sync-state ] when , ;
: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
: eliminate-peek ( dst src -- ) : eliminate-peek ( dst src -- )
! the requested stack location is already in 'src' ! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ; [ ##copy ] [ swap copies get set-at ] 2bi ;
@ -138,7 +109,7 @@ M: ##copy visit
[ call-next-method ] [ record-copy ] bi ; [ call-next-method ] [ record-copy ] bi ;
M: ##call visit M: ##call visit
[ call-next-method ] [ height>> adjust-d ] bi ; [ call-next-method ] [ height>> adjust-ds ] bi ;
! Instructions that poison the stack state ! Instructions that poison the stack state
UNION: poison-insn UNION: poison-insn
@ -167,7 +138,7 @@ UNION: kill-vreg-insn
M: kill-vreg-insn visit sync-state , ; M: kill-vreg-insn visit sync-state , ;
: visit-alien-node ( node -- ) : visit-alien-node ( node -- )
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
M: ##alien-invoke visit M: ##alien-invoke visit
[ call-next-method ] [ visit-alien-node ] bi ; [ call-next-method ] [ visit-alien-node ] bi ;
@ -180,87 +151,6 @@ M: ##alien-callback visit , ;
! Maps basic-blocks to states ! Maps basic-blocks to states
SYMBOLS: state-in state-out ; SYMBOLS: state-in state-out ;
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
ERROR: must-equal-failed seq ;
: must-equal ( seq -- elt )
dup all-equal? [ first ] [ must-equal-failed ] if ;
: merge-heights ( state predecessors states -- state )
nip
[ [ ds-height>> ] map must-equal >>ds-height ]
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
: insert-peek ( predecessor loc -- vreg )
! XXX critical edges
'[ _ ^^peek ] add-instructions ;
: merge-loc ( predecessors locs>vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
[ '[ [ _ ] dip at ] map ] keep
'[ [ ] [ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ;
: (merge-locs) ( predecessors assocs -- assoc )
dup [ keys ] map concat prune
[ [ 2nip ] [ merge-loc ] 3bi ] with with
H{ } map>assoc ;
: merge-locs ( state predecessors states -- state )
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
: merge-loc' ( locs>vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
'[ [ _ ] dip at ] map
dup all-equal? [ first ] [ drop f ] if ;
: merge-actual-locs ( state predecessors states -- state )
nip
[ actual-locs>vregs>> ] map
dup [ keys ] map concat prune
[ [ nip ] [ merge-loc' ] 2bi ] with
H{ } map>assoc
[ nip ] assoc-filter
>>actual-locs>vregs ;
: merge-changed-locs ( state predecessors states -- state )
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
[ <state> ] 2dip
sift merge-heights
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
] [
[ state new ] 2dip
[ predecessors>> ] dip
{
[ merge-locs ]
[ merge-actual-locs ]
[ merge-heights ]
[ merge-changed-locs ]
} 2cleave
] if
] if ;
: merge-states ( bb states -- state )
! If any states are poisoned, save all registers
! to the stack in each branch
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
} case ;
: block-in-state ( bb -- states ) : block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ; dup predecessors>> state-out get '[ _ at ] map merge-states ;

43
basis/compiler/cfg/stack-analysis/state/state.factor Normal file
View File

@ -0,0 +1,43 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
ds-height rs-height poisoned? ;
: <state> ( -- state )
state new
H{ } clone >>locs>vregs
H{ } clone >>actual-locs>vregs
H{ } clone >>changed-locs
0 >>ds-height
0 >>rs-height ;
M: state clone
call-next-method
[ clone ] change-locs>vregs
[ clone ] change-actual-locs>vregs
[ clone ] change-changed-locs ;
: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
: record-peek ( dst loc -- )
state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
: changed-loc ( loc -- )
state get changed-locs>> conjoin ;
: record-replace ( src loc -- )
dup changed-loc state get locs>vregs>> set-at ;
: clear-state ( state -- )
[ locs>vregs>> clear-assoc ]
[ actual-locs>vregs>> clear-assoc ]
[ changed-locs>> clear-assoc ]
tri ;
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;

10
basis/math/primes/erato/erato-docs.factor
View File

@ -3,10 +3,8 @@ IN: math.primes.erato
HELP: sieve HELP: sieve
{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } } { $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } }
{ $description "Return a bit array containing a primality bit for every odd number between 3 and " { $snippet "n" } " (inclusive). " { $snippet ">index" } " can be used to retrieve the index of an odd number to be tested." } ; { $description "Apply Eratostene sieve up to " { $snippet "n" } ". Primality can then be tested using " { $link sieve } "." } ;
HELP: >index HELP: marked-prime?
{ $values { "n" "an odd number" } { "i" "the corresponding index" } } { $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } }
{ $description "Retrieve the index corresponding to the odd number on the stack." } ; { $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ;
{ sieve >index } related-words

11
basis/math/primes/erato/erato-tests.factor
View File

@ -1,3 +1,10 @@
USING: bit-arrays math.primes.erato tools.test ; USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ;
[ ?{ t t t f t t f t t f t f f t } ] [ 29 sieve ] unit-test [ B{ 255 251 247 126 } ] [ 100 sieve ] unit-test
[ 1 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
[ 120 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
[ f ] [ 119 100 sieve marked-prime? ] unit-test
[ t ] [ 113 100 sieve marked-prime? ] unit-test
! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test

46
basis/math/primes/erato/erato.factor
View File

@ -1,25 +1,41 @@
! Copyright (C) 2009 Samuel Tardieu. ! Copyright (C) 2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays kernel math math.functions math.ranges sequences ; USING: arrays byte-arrays kernel math math.bitwise math.functions math.order
math.ranges sequences sequences.private ;
IN: math.primes.erato IN: math.primes.erato
: >index ( n -- i ) <PRIVATE
3 - 2 /i ; inline
: index> ( i -- n ) CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
2 * 3 + ; inline
: mark-multiples ( i arr -- ) : bit-pos ( n -- byte/f mask/f )
[ index> [ sq >index ] keep ] dip 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
[ length 1 - swap <range> f swap ] keep
[ set-nth ] curry with each ;
: maybe-mark-multiples ( i arr -- ) : marked-unsafe? ( n arr -- ? )
2dup nth [ mark-multiples ] [ 2drop ] if ; [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
: init-sieve ( n -- arr ) : unmark ( n arr -- )
>index 1 + <bit-array> dup set-bits ; [ bit-pos swap ] dip
over [ [ swap unmask ] change-nth-unsafe ] [ 3drop ] if ;
: upper-bound ( arr -- n ) length 30 * 1 - ;
: unmark-multiples ( i arr -- )
2dup marked-unsafe? [
[ [ dup sq ] [ upper-bound ] bi* rot <range> ] keep
[ unmark ] curry each
] [
2drop
] if ;
: init-sieve ( n -- arr ) 29 + 30 /i 255 <array> >byte-array ;
PRIVATE>
: sieve ( n -- arr ) : sieve ( n -- arr )
[ init-sieve ] [ sqrt >index [0,b] ] bi init-sieve [ 2 swap upper-bound sqrt [a,b] ] keep
over [ maybe-mark-multiples ] curry each ; foldable [ [ unmark-multiples ] curry each ] keep ;
: marked-prime? ( n arr -- ? )
2dup upper-bound 2 swap between? [ bounds-error ] unless
over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;

12
basis/math/primes/primes-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays math math.primes math.primes.miller-rabin USING: arrays kernel math math.primes math.primes.miller-rabin
tools.test ; sequences tools.test ;
IN: math.primes.tests IN: math.primes.tests
{ 1237 } [ 1234 next-prime ] unit-test { 1237 } [ 1234 next-prime ] unit-test
@ -10,6 +10,9 @@ IN: math.primes.tests
{ { 4999963 4999999 5000011 5000077 5000081 } } { { 4999963 4999999 5000011 5000077 5000081 } }
[ 4999962 5000082 primes-between >array ] unit-test [ 4999962 5000082 primes-between >array ] unit-test
{ { 8999981 8999993 9000011 9000041 } }
[ 8999980 9000045 primes-between >array ] unit-test
[ 2 ] [ 1 next-prime ] unit-test [ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test [ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test [ 5 ] [ 3 next-prime ] unit-test
@ -18,3 +21,8 @@ IN: math.primes.tests
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ 49 ] [ 50 random-prime log2 ] unit-test [ 49 ] [ 50 random-prime log2 ] unit-test
[ t ] [ 5000077 dup find-relative-prime coprime? ] unit-test
[ 5 t { 14 14 14 14 14 } ]
[ 5 15 unique-primes [ length ] [ [ prime? ] all? ] [ [ log2 ] map ] tri ] unit-test

46
basis/math/primes/primes.factor
View File

@ -1,37 +1,55 @@
! Copyright (C) 2007-2009 Samuel Tardieu. ! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math math.bitwise math.functions USING: combinators combinators.short-circuit fry kernel math
math.order math.primes.erato math.primes.miller-rabin math.bitwise math.functions math.order math.primes.erato
math.ranges random sequences sets fry ; math.primes.erato.private math.primes.miller-rabin math.ranges
literals random sequences sets vectors ;
IN: math.primes IN: math.primes
<PRIVATE <PRIVATE
: look-in-bitmap ( n -- ? ) >index 4999999 sieve nth ; : look-in-bitmap ( n -- ? ) $[ 8999999 sieve ] marked-unsafe? ; inline
: really-prime? ( n -- ? ) : (prime?) ( n -- ? )
dup 5000000 < [ look-in-bitmap ] [ miller-rabin ] if ; foldable dup 8999999 <= [ look-in-bitmap ] [ miller-rabin ] if ;
! In order not to reallocate large vectors, we compute the upper bound
! of the number of primes in a given interval. We use a double inequality given
! by Pierre Dusart in http://www.ams.org/mathscinet-getitem?mr=99d:11133
! for x > 598. Under this limit, we know that there are at most 108 primes.
: upper-pi ( x -- y )
dup log [ / ] [ 1.2762 swap / 1 + ] bi * ceiling ;
: lower-pi ( x -- y )
dup log [ / ] [ 0.992 swap / 1 + ] bi * floor ;
: <primes-vector> ( low high -- vector )
swap [ [ upper-pi ] [ lower-pi ] bi* - >integer
108 max 10000 min <vector> ] keep
3 < [ [ 2 swap push ] keep ] when ;
: simple? ( n -- ? ) { [ even? ] [ 3 mod 0 = ] [ 5 mod 0 = ] } 1|| ;
PRIVATE> PRIVATE>
: prime? ( n -- ? ) : prime? ( n -- ? )
{ {
{ [ dup 2 < ] [ drop f ] } { [ dup 7 < ] [ { 2 3 5 } member? ] }
{ [ dup even? ] [ 2 = ] } { [ dup simple? ] [ drop f ] }
[ really-prime? ] [ (prime?) ]
} cond ; foldable } cond ; foldable
: next-prime ( n -- p ) : next-prime ( n -- p )
dup 2 < [ dup 2 < [
drop 2 drop 2
] [ ] [
next-odd [ dup really-prime? ] [ 2 + ] until next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable ] if ; foldable
: primes-between ( low high -- seq ) : primes-between ( low high -- seq )
[ dup 3 max dup even? [ 1 + ] when ] dip [ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
2 <range> [ prime? ] filter [ <primes-vector> ] 2bi
swap 3 < [ 2 prefix ] when ; [ '[ [ prime? ] _ push-if ] each ] keep clone ;
: primes-upto ( n -- seq ) 2 swap primes-between ; : primes-upto ( n -- seq ) 2 swap primes-between ;
@ -65,5 +83,5 @@ ERROR: too-few-primes n numbits ;
: unique-primes ( n numbits -- seq ) : unique-primes ( n numbits -- seq )
2dup 2^ estimated-primes > [ too-few-primes ] when 2dup 2^ estimated-primes > [ too-few-primes ] when
2dup '[ _ random-prime ] replicate 2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ; dup all-unique? [ 2nip ] [ drop unique-primes ] if ;