{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
- intersect-inactive
+ relevant-ranges intersect-live-ranges
] unit-test
! Bug in live spill slots calculation
--- /dev/null
+! 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 ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.hats compiler.cfg ;
+sets make combinators
+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
! 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 )
M: ds-loc height-for drop state get ds-height>> ;
[ 2drop ] [ untranslate-loc ##replace ] if
] assoc-each ;
-: clear-state ( state -- )
- [ locs>vregs>> clear-assoc ]
- [ actual-locs>vregs>> clear-assoc ]
- [ changed-locs>> clear-assoc ]
- tri ;
-
ERROR: poisoned-state state ;
: sync-state ( -- )
! Abstract interpretation
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
UNION: neutral-insn
##flushable
M: sync-if-back-edge visit
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 -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
[ call-next-method ] [ record-copy ] bi ;
M: ##call visit
- [ call-next-method ] [ height>> adjust-d ] bi ;
+ [ call-next-method ] [ height>> adjust-ds ] bi ;
! Instructions that poison the stack state
UNION: poison-insn
M: kill-vreg-insn visit sync-state , ;
: 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
[ call-next-method ] [ visit-alien-node ] bi ;
! Maps basic-blocks to states
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 )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
--- /dev/null
+! 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 ;
HELP: sieve
{ $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
-{ $values { "n" "an odd number" } { "i" "the corresponding index" } }
-{ $description "Retrieve the index corresponding to the odd number on the stack." } ;
-
-{ sieve >index } related-words
+HELP: marked-prime?
+{ $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } }
+{ $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ;
-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
\ No newline at end of file
! Copyright (C) 2009 Samuel Tardieu.
! 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
-: >index ( n -- i )
- 3 - 2 /i ; inline
+<PRIVATE
-: index> ( i -- n )
- 2 * 3 + ; inline
+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 }
-: mark-multiples ( i arr -- )
- [ index> [ sq >index ] keep ] dip
- [ length 1 - swap <range> f swap ] keep
- [ set-nth ] curry with each ;
+: bit-pos ( n -- byte/f mask/f )
+ 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
-: maybe-mark-multiples ( i arr -- )
- 2dup nth [ mark-multiples ] [ 2drop ] if ;
+: marked-unsafe? ( n arr -- ? )
+ [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
-: init-sieve ( n -- arr )
- >index 1 + <bit-array> dup set-bits ;
+: unmark ( n arr -- )
+ [ 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 )
- [ init-sieve ] [ sqrt >index [0,b] ] bi
- over [ maybe-mark-multiples ] curry each ; foldable
+ init-sieve [ 2 swap upper-bound sqrt [a,b] ] keep
+ [ [ 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 ;
\ No newline at end of file
-USING: arrays math math.primes math.primes.miller-rabin
-tools.test ;
+USING: arrays kernel math math.primes math.primes.miller-rabin
+sequences tools.test ;
IN: math.primes.tests
{ 1237 } [ 1234 next-prime ] unit-test
{ { 4999963 4999999 5000011 5000077 5000081 } }
[ 4999962 5000082 primes-between >array ] unit-test
+{ { 8999981 8999993 9000011 9000041 } }
+[ 8999980 9000045 primes-between >array ] unit-test
+
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] 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
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.bitwise math.functions
-math.order math.primes.erato math.primes.miller-rabin
-math.ranges random sequences sets fry ;
+USING: combinators combinators.short-circuit fry kernel math
+math.bitwise math.functions math.order math.primes.erato
+math.primes.erato.private math.primes.miller-rabin math.ranges
+literals random sequences sets vectors ;
IN: math.primes
<PRIVATE
-: look-in-bitmap ( n -- ? ) >index 4999999 sieve nth ;
+: look-in-bitmap ( n -- ? ) $[ 8999999 sieve ] marked-unsafe? ; inline
-: really-prime? ( n -- ? )
- dup 5000000 < [ look-in-bitmap ] [ miller-rabin ] if ; foldable
+: (prime?) ( n -- ? )
+ 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>
: prime? ( n -- ? )
{
- { [ dup 2 < ] [ drop f ] }
- { [ dup even? ] [ 2 = ] }
- [ really-prime? ]
+ { [ dup 7 < ] [ { 2 3 5 } member? ] }
+ { [ dup simple? ] [ drop f ] }
+ [ (prime?) ]
} cond ; foldable
: next-prime ( n -- p )
dup 2 < [
drop 2
] [
- next-odd [ dup really-prime? ] [ 2 + ] until
+ next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable
: primes-between ( low high -- seq )
- [ dup 3 max dup even? [ 1 + ] when ] dip
- 2 <range> [ prime? ] filter
- swap 3 < [ 2 prefix ] when ;
+ [ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
+ [ <primes-vector> ] 2bi
+ [ '[ [ prime? ] _ push-if ] each ] keep clone ;
: primes-upto ( n -- seq ) 2 swap primes-between ;
: unique-primes ( n numbits -- seq )
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 ;
projects / factor.git / commitdiff