[
{
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ _copy { dst 5 } { src 4 } { class int-regs } }
+ T{ _spill { src 0 } { class int-regs } { n 6 } }
+ T{ _copy { dst 0 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 6 } }
+ T{ _spill { src 0 } { class float-regs } { n 7 } }
+ T{ _copy { dst 0 } { src 1 } { class float-regs } }
+ T{ _reload { dst 1 } { class float-regs } { n 7 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- } trace-chains
+ T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+ T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+ T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+ } mapping-instructions
] unit-test
[
{
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ _spill { src 0 } { class int-regs } { n 3 } }
+ T{ _copy { dst 0 } { src 2 } { class int-regs } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 3 } }
}
] [
{
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- } trace-chains
-] unit-test
-
-[
- {
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- }
-] [
- {
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- } trace-chains
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ } mapping-instructions
] unit-test
[
{
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ _spill { src 0 } { class int-regs } { n 3 } }
+ T{ _copy { dst 0 } { src 2 } { class int-regs } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 3 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- } trace-chains
+ } mapping-instructions
] unit-test
[
{
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
- T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
}
] [
{
- T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- } trace-chains
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
] unit-test
[
- {
- T{ _copy { dst 5 } { src 4 } { class int-regs } }
- T{ _spill { src 1 } { class int-regs } { n 6 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 6 } }
- T{ _spill { src 1 } { class float-regs } { n 7 } }
- T{ _copy { dst 1 } { src 0 } { class float-regs } }
- T{ _reload { dst 0 } { class float-regs } { n 7 } }
- }
+ { }
] [
{
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
- T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
- T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
- {
- T{ _spill { src 1 } { class int-regs } { n 3 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _copy { dst 0 } { src 2 } { class int-regs } }
- T{ _reload { dst 2 } { class int-regs } { n 3 } }
- }
+ { T{ _spill { src 4 } { class int-regs } { n 4 } } }
] [
{
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
+
[
{
- T{ _spill { src 1 } { class int-regs } { n 3 } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _copy { dst 0 } { src 2 } { class int-regs } }
- T{ _reload { dst 2 } { class int-regs } { n 3 } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _spill { src 3 } { class int-regs } { n 5 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 3 } { src 4 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 5 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
- { }
-] [
{
- T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 9 } { src 1 } { class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _spill { src 3 } { class int-regs } { n 10 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 3 } { src 4 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ }
] [
{
- T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
-combinators combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
-fry hashtables histogram kernel locals make math math.order
-namespaces parser prettyprint random sequences sets
-sorting.functor sorting.slots words ;
+combinators combinators.short-circuit fry hashtables kernel locals
+make math math.order namespaces sequences sets words parser
+compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
+compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
<<
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
-: (trace-chain) ( pair -- )
- to-reg froms get at [
- dup length 1 = [
- first [ , ] [ (trace-chain) ] bi
- ] [
- drop
- ] if
- ] when* ;
-
-: trace-chain ( pair -- seq )
- [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
-
: start? ( operations -- pair )
from-reg tos get key? not ;
+: independent-assignment? ( operations -- pair )
+ to-reg froms get key? not ;
+
: init-temp-spill ( operations -- )
[ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
1 + temp-spill set ;
: set-tos/froms ( operations -- )
- {
- [ [ from-reg ] collect-values froms set ]
- [ [ to-reg ] collect-values tos set ]
- } cleave ;
+ [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+ [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
+ bi ;
+
+:: (trace-chain) ( obj hashtable -- )
+ obj to-reg froms get at* [
+ obj over hashtable clone [ maybe-set-at ] keep swap
+ [ (trace-chain) ] [ , drop ] if
+ ] [
+ drop hashtable ,
+ ] if ;
+
+: trace-chain ( obj -- seq )
+ [
+ dup dup associate (trace-chain)
+ ] { } make [ keys ] map concat reverse ;
-: trace-chains ( operations -- operations' )
- [ set-tos/froms ]
- [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+: trace-chains ( seq -- seq' )
+ [ trace-chain ] map concat ;
: break-cycle-n ( operations -- operations' )
- unclip [ trace-chains ] dip
- [
+ unclip [
[ from>> temp-spill get ]
[ reg-class>> ] bi \ register->memory boa
] [
: break-cycle ( operations -- operations' )
dup length {
- { 1 [ drop { } ] }
+ { 1 [ ] }
[ drop break-cycle-n ]
} case ;
-: follow-cycle ( obj -- seq )
- dup dup associate [
- [ to-reg froms get at first dup dup ] dip
- [ maybe-set-at ] keep swap
- ] loop nip keys ;
-
: (group-cycles) ( seq -- )
[
- unclip follow-cycle [ diff ] keep , (group-cycles)
+ dup set-tos/froms
+ unclip trace-chain
+ [ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
-: partition-mappings ( mappings -- no-cycles cycles )
- [ start? not ] partition
- [ trace-chain ] map concat tuck diff ;
+: remove-dead-mappings ( seq -- seq' )
+ prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
- partition-mappings [
- group-cycles [ break-cycle ] map concat append
- ] unless-empty ;
+ [
+ [ independent-assignment? not ] partition %
+ [ start? not ] partition
+ [ trace-chain ] map concat dup %
+ diff group-cycles [ break-cycle ] map concat %
+ ] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[
] with-scope ;
: fork? ( from to -- ? )
- [ successors>> length 1 >= ]
- [ predecessors>> length 1 = ] bi* and ; inline
+ {
+ [ drop successors>> length 1 >= ]
+ [ nip predecessors>> length 1 = ]
+ } 2&& ; inline
: insert-position/fork ( from to -- before after )
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
: join? ( from to -- ? )
- [ successors>> length 1 = ]
- [ predecessors>> length 1 >= ] bi* and ; inline
+ {
+ [ drop successors>> length 1 = ]
+ [ nip predecessors>> length 1 >= ]
+ } 2&& ; inline
: insert-position/join ( from to -- before after )
drop instructions>> dup pop 1array ;
'[ _ untranslate-loc ] assoc-map-values ;
: collect-locs ( loc-maps states -- assoc )
- ! assoc maps locs to sequences of vregs
+ ! assoc maps locs to sequences
[ untranslate-locs ] 2map
[ [ keys ] map concat prune ] keep
'[ dup _ [ at ] with map ] H{ } map>assoc ;
-: insert-peek ( predecessor state loc -- vreg )
- '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+: insert-peek ( predecessor loc state -- vreg )
+ '[ _ _ translate-loc ^^peek ] add-instructions ;
-: merge-loc ( predecessors states vregs loc -- vreg )
+: merge-loc ( predecessors vregs loc state -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
- '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
+ '[ [ ] [ _ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ;
:: merge-locs ( state predecessors states -- state )
states [ locs>vregs>> ] map states collect-locs
[| key value |
key
- predecessors states value key merge-loc
+ predecessors value key state merge-loc
] assoc-map
state translate-locs
state (>>locs>vregs)
: merge-actual-loc ( vregs -- vreg/f )
dup all-equal? [ first ] [ drop f ] if ;
-: merge-actual-locs ( state states -- state )
- [ [ actual-locs>vregs>> ] map ] keep collect-locs
+:: merge-actual-locs ( state states -- state )
+ states [ actual-locs>vregs>> ] map states collect-locs
[ merge-actual-loc ] assoc-map [ nip ] assoc-filter
- over translate-locs
- >>actual-locs>vregs ;
+ state translate-locs
+ state (>>actual-locs>vregs)
+ state ;
: merge-changed-locs ( state states -- state )
- [ changed-locs>> ] map assoc-combine >>changed-locs ;
+ [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
+ over translate-locs
+ >>changed-locs ;
ERROR: cannot-merge-poisoned states ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
-: check-for-redundant-ops ( cfg -- )
- [
- instructions>>
- [
- [ ##peek? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant peeks" throw ] unless
- ] [
- [ ##replace? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant replaces" throw ] unless
- ] bi
- ] each-basic-block ;
-
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
- delete-useless-blocks
- delete-useless-conditionals
stack-analysis
- dup check-cfg
- dup check-for-redundant-ops ;
+ dup check-cfg ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
! Correct height tracking
[ t ] [
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
- reverse-post-order 2 swap nth
+ reverse-post-order 3 swap nth
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
2array { D 1 D 0 } set=
] unit-test
drop
3 get instructions>> second loc>>
+] unit-test
+
+! Do inserted ##peeks reference the correct stack location if
+! an ##inc-d/r was also inserted?
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##call f \ + -1 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> [ ##peek? ] find nip loc>>
+] unit-test
+
+! Missing ##replace
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ reverse-post-order last
+ instructions>> [ ##replace? ] filter [ loc>> ] map
+ { D 0 D 1 D 2 } set=
+] unit-test
+
+! Inserted ##peeks reference the wrong stack location
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ eliminate-dead-code reverse-post-order 3 swap nth
+ instructions>> [ ##peek? ] filter [ loc>> ] map
+ { R 0 D 0 D 1 } set=
+] unit-test
+
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> [ ##peek? ] find nip loc>>
] unit-test
\ No newline at end of file
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
- [ changed-locs>> ] [ locs>vregs>> ] bi '[
- _ at swap 2dup redundant-replace?
+ [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
+ dup _ at swap 2dup redundant-replace?
[ 2drop ] [ state get untranslate-loc ##replace ] if
- ] assoc-each ;
+ ] each ;
ERROR: poisoned-state state ;
USING: help.markup help.syntax math sequences ;
IN: math.primes.factors
-{ factors group-factors unique-factors } related-words
+{ divisors factors group-factors unique-factors } related-words
HELP: factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
HELP: totient
{ $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;
+
+HELP: divisors
+{ $values { "n" "a positive integer" } { "seq" sequence } }
+{ $description { "Return the ordered list of divisors of " { $snippet "n" } ", including 1 and " { $snippet "n" } "." } } ;
-USING: math.primes.factors tools.test ;
+USING: math.primes.factors sequences tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { } } [ -5 factors ] unit-test
{ 0 } [ 1 totient ] unit-test
{ { 425612003 } } [ 425612003 factors ] unit-test
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
+{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
+{ 24 } [ 360 divisors length ] unit-test
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel make math math.functions
-math.primes sequences ;
+math.primes math.ranges sequences sequences.product sorting ;
IN: math.primes.factors
<PRIVATE
{ [ dup 2 < ] [ drop 0 ] }
[ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
} cond ; foldable
+
+: divisors ( n -- seq )
+ group-factors [ first2 [0,b] [ ^ ] with map ] map
+ [ product ] product-map natural-sort ;
projects / factor.git / commitdiff