diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 1f8112a893..60dfbd83bc 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1414,7 +1414,7 @@ USING: math.private ; { 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 diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor new file mode 100644 index 0000000000..9db6d595bf --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor @@ -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 ; + +: 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? [ + [ ] 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 diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 4ebdf7012f..3946e0b897 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -1,42 +1,19 @@ ! 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 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>> ; @@ -64,12 +41,6 @@ M: rs-loc untranslate-loc (translate-loc) + ; [ 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 ( -- ) @@ -84,6 +55,14 @@ ERROR: poisoned-state 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 @@ -113,14 +92,6 @@ t local-only? set-global 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 ; @@ -138,7 +109,7 @@ M: ##copy visit [ 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 @@ -167,7 +138,7 @@ UNION: kill-vreg-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 ; @@ -180,87 +151,6 @@ M: ##alien-callback visit , ; ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: initial-state ( bb states -- state ) 2drop ; - -: 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? [ - [ ] 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 ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor new file mode 100644 index 0000000000..d8cec0183f --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/state/state.factor @@ -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 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 ; diff --git a/basis/math/primes/erato/erato-docs.factor b/basis/math/primes/erato/erato-docs.factor index b12ea45052..1e32818fe3 100644 --- a/basis/math/primes/erato/erato-docs.factor +++ b/basis/math/primes/erato/erato-docs.factor @@ -3,10 +3,8 @@ IN: math.primes.erato 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."} ; diff --git a/basis/math/primes/erato/erato-tests.factor b/basis/math/primes/erato/erato-tests.factor index 917824c9c1..e78e5210f9 100644 --- a/basis/math/primes/erato/erato-tests.factor +++ b/basis/math/primes/erato/erato-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index 70a9c10ff5..673f9c97cd 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -1,25 +1,41 @@ ! 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 + ( 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 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 + 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 ] keep + [ unmark ] curry each + ] [ + 2drop + ] if ; + +: init-sieve ( n -- arr ) 29 + 30 /i 255 >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 diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index 6580f0780e..3d21a3e7d6 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,5 +1,5 @@ -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 @@ -10,6 +10,9 @@ IN: math.primes.tests { { 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 @@ -18,3 +21,8 @@ IN: math.primes.tests [ 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 diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index e3985fc600..7e877a03ce 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,37 +1,55 @@ ! 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 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 ; + +: ( low high -- vector ) + swap [ [ upper-pi ] [ lower-pi ] bi* - >integer + 108 max 10000 min ] 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 [ prime? ] filter - swap 3 < [ 2 prefix ] when ; + [ [ 3 max dup even? [ 1 + ] when ] dip 2 ] + [ ] 2bi + [ '[ [ prime? ] _ push-if ] each ] keep clone ; : primes-upto ( n -- seq ) 2 swap primes-between ; @@ -65,5 +83,5 @@ ERROR: too-few-primes n numbits ; : 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 ;