diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor new file mode 100644 index 0000000000..17623e785c --- /dev/null +++ b/library/compiler/simplifier.factor @@ -0,0 +1,230 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: compiler-backend +USING: generic inference kernel lists math namespaces +prettyprint strings words ; + +! A peephole optimizer operating on the linear IR. + +! The linear IR being simplified is stored in this variable. +SYMBOL: simplifying + +GENERIC: simplify-node ( linear vop -- linear ? ) + +! The next node following this node in terms of control flow, or +! f if this is a conditional. +GENERIC: next-logical ( linear vop -- linear ) + +! No delegation. +M: tuple simplify-node drop f ; + +: simplify-1 ( list -- list ? ) + #! Return a new linear IR. + dup [ + dup car simplify-node + [ uncons simplify-1 drop cons t ] + [ uncons simplify-1 >r cons r> ] ifte + ] [ + f + ] ifte ; + +: simplify ( linear -- linear ) + #! Keep simplifying until simplify-1 returns f. + [ + dup simplifying set simplify-1 + ] with-scope [ simplify ] when ; + +: label-called? ( label -- ? ) + simplifying get [ calls-label? ] some-with? ; + +M: %label simplify-node ( linear vop -- linear ? ) + vop-label label-called? [ f ] [ cdr t ] ifte ; + +: next-physical? ( linear class -- vop ? ) + #! If the following op has given class, remove it and + #! return it. + over cdr dup [ + car class = [ cdr car t ] [ f ] ifte + ] [ + 3drop f f + ] ifte ; + +M: %inc-d simplify-node ( linear vop -- linear ? ) + #! %inc-d cancels a following %inc-d. + >r dup \ %inc-d next-physical? [ + vop-literal r> vop-literal + dup 0 = [ + drop cdr cdr f + ] [ + %inc-d >r cdr cdr r> swons t + ] ifte + ] [ + r> 2drop f + ] ifte ; + +: dead-load? ( linear vop -- ? ) + #! Is the %replace-d followed by a %peek-d of the same + #! stack slot and vreg? + swap cdr car dup %peek-d? [ + over vop-source over vop-dest = >r + swap vop-literal swap vop-literal = r> and + ] [ + 2drop f + ] ifte ; + +: dead-store? ( linear n -- ? ) + #! Is the %replace-d followed by a %dec-d, so the stored + #! value is lost? + swap \ %inc-d next-physical? [ + vop-literal + 0 < + ] [ + 2drop f + ] ifte ; + +M: %replace-d simplify-node ( linear vop -- linear ? ) + 2dup dead-load? [ + drop uncons cdr cons t + ] [ + 2dup vop-literal dead-store? [ + drop cdr t + ] [ + drop f + ] ifte + ] ifte ; + +M: %immediate-d simplify-node ( linear vop -- linear ? ) + over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ; + +: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ; + +: can-fast-branch? ( linear -- ? ) + unswons class fast-branch [ + unswons pop? [ car %jump-t? ] [ drop f ] ifte + ] [ + drop f + ] ifte ; + +: fast-branch-params ( linear -- src dest label linear ) + uncons >r dup vop-source swap vop-dest r> cdr + uncons >r vop-label r> ; + +M: %fixnum<= simplify-node ( linear vop -- linear ? ) + drop dup can-fast-branch? [ + fast-branch-params >r + %jump-fixnum<= >r -1 %inc-d r> + r> cons cons t + ] [ + f + ] ifte ; + +M: %eq? simplify-node ( linear vop -- linear ? ) + drop dup can-fast-branch? [ + fast-branch-params >r + %jump-eq? >r -1 %inc-d r> + r> cons cons t + ] [ + f + ] ifte ; + +: find-label ( label -- rest ) + simplifying get [ + dup %label? [ vop-label = ] [ 2drop f ] ifte + ] some-with? ; + +M: %label next-logical ( linear vop -- linear ) + drop cdr dup car next-logical ; + +M: %jump-label next-logical ( linear vop -- linear ) + nip vop-label find-label cdr ; + +M: %target-label next-logical ( linear vop -- linear ) + nip vop-label find-label cdr ; + +M: object next-logical ( linear vop -- linear ) + drop ; + +: next-logical? ( op linear -- ? ) + dup car next-logical dup [ car class = ] [ 2drop f ] ifte ; + +: reduce ( linear op new -- linear ? ) + >r over cdr next-logical? [ + dup car vop-label + r> execute swap cdr cons t + ] [ + r> drop f + ] ifte ; inline + +M: %call simplify-node ( linear vop -- ? ) + #! Tail call optimization. + drop \ %return \ %jump reduce ; + +M: %call-label simplify-node ( linear vop -- ? ) + #! Tail call optimization. + drop \ %return \ %jump-label reduce ; + +: double-jump ( linear op2 op1 -- linear ? ) + #! A jump to a jump is just a jump. If the next logical node + #! is a jump of type op1, replace the jump at the car of the + #! list with a jump of type op2. + pick next-logical? [ + >r dup dup car next-logical car vop-label + r> execute swap cdr cons t + ] [ + drop f + ] ifte ; inline + +: useless-jump ( linear -- linear ? ) + #! A jump to a label immediately following is not needed. + dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ; + +: (dead-code) ( linear -- linear ? ) + #! Remove all nodes until the next #label. + dup [ + dup car %label? [ + f + ] [ + cdr (dead-code) t or + ] ifte + ] [ + f + ] ifte ; + +: dead-code ( linear -- linear ? ) + uncons (dead-code) >r cons r> ; + +M: %jump-label simplify-node ( linear vop -- linear ? ) + drop + \ %return dup double-jump [ + t + ] [ + \ %jump-label dup double-jump [ + t + ] [ + \ %jump dup double-jump + ! [ + ! t + ! ] [ + ! useless-jump [ + ! t + ! ] [ + ! dead-code + ! ] ifte + ! ] ifte + ] ifte + ] ifte ; +! +! #jump-label [ +! [ #return #return double-jump ] +! [ #jump-label #jump-label double-jump ] +! [ #jump #jump double-jump ] +! [ useless-jump ] +! [ dead-code ] +! ] "simplifiers" set-word-prop +! +! #target-label [ +! [ #target-label #jump-label double-jump ] +! ! [ #target #jump double-jump ] +! ] "simplifiers" set-word-prop +! +! #jump [ [ dead-code ] ] "simplifiers" set-word-prop +! #return [ [ dead-code ] ] "simplifiers" set-word-prop +! #end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop diff --git a/library/test/compiler/linearizer.factor b/library/test/compiler/linearizer.factor index 6012ba1237..5825c52181 100644 --- a/library/test/compiler/linearizer.factor +++ b/library/test/compiler/linearizer.factor @@ -2,6 +2,7 @@ IN: temporary USE: test USE: kernel USE: compiler +USE: compiler-frontend USE: inference USE: words diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 8c3f67c108..95090e650d 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -1,11 +1,13 @@ IN: temporary USE: test USE: compiler +USE: compiler-frontend USE: inference USE: words USE: math USE: kernel USE: lists +USE: sequences : foo 1 2 3 ; diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor deleted file mode 100644 index dd3670ee9f..0000000000 --- a/library/test/compiler/simplifier.factor +++ /dev/null @@ -1,75 +0,0 @@ -IN: temporary -USE: compiler -USE: test -USE: inference -USE: lists -USE: kernel -USE: namespaces - -[ t ] [ \ >r [ [ r> ] [ >r ] ] next-physical? ] unit-test -[ f t ] [ [ [ r> ] [ >r ] ] \ >r cancel nip ] unit-test -[ [ [ >r ] [ r> ] ] f ] [ [ [ >r ] [ r> ] ] \ >r cancel nip ] unit-test - -[ [ [ #jump 123 ] [ #return ] ] t ] -[ [ [ #call 123 ] [ #return ] ] #return #jump reduce ] unit-test - -[ [ ] ] [ [ ] simplify ] unit-test -[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test -[ [[ #jump car ]] ] [ [ [[ #call car ]] [ #return ] ] simplify car ] unit-test - -[ [ [ #return ] ] ] -[ - [ - 123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ] - simplifying set find-label cdr - ] with-scope -] -unit-test - -[ [ [ #return ] ] ] -[ - [ - [ - [[ #jump-label 123 ]] - [[ #call car ]] - [[ #label 123 ]] - [ #return ] - ] dup simplifying set next-logical - ] with-scope -] -unit-test - -[ - [ [[ #return f ]] ] -] -[ - [ - [[ #jump-label 123 ]] - [[ #label 123 ]] - [ #return ] - ] simplify -] unit-test - -[ - [ [[ #jump car ]] ] -] -[ - [ - [[ #call car ]] - [[ #jump-label 123 ]] - [[ #label 123 ]] - [ #return ] - ] simplify -] unit-test - -[ - [ [[ swap f ]] ] -] [ - [ - [[ #jump-label 1 ]] - [[ #label 1 ]] - [[ #jump-label 2 ]] - [[ #label 2 ]] - [[ swap f ]] - ] simplify -] unit-test diff --git a/library/test/math/integer.factor b/library/test/math/integer.factor index b98beb0bc0..d1026aaf28 100644 --- a/library/test/math/integer.factor +++ b/library/test/math/integer.factor @@ -22,6 +22,8 @@ USING: kernel math test unparser ; [ -1 ] [ 1 neg ] unit-test [ -1 ] [ 1 >bignum neg ] unit-test +[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test +[ 268435456 ] [ -268435456 >fixnum neg ] unit-test [ 9 3 ] [ 93 10 /mod ] unit-test [ 9 3 ] [ 93 >bignum 10 /mod ] unit-test diff --git a/library/test/random.factor b/library/test/random.factor index 94dd9b81e6..201c1b606c 100644 --- a/library/test/random.factor +++ b/library/test/random.factor @@ -5,8 +5,10 @@ USE: math USE: namespaces USE: random USE: test +USE: errors : check-random-int ( min max -- ) - 2dup random-int -rot between? assert ; + 2dup random-int -rot between? + [ "Assertion failed" throw ] unless ; [ ] [ 100 [ -12 674 check-random-int ] times ] unit-test diff --git a/library/test/sbuf.factor b/library/test/sbuf.factor index 1f1d783d2a..b2b08c12d5 100644 --- a/library/test/sbuf.factor +++ b/library/test/sbuf.factor @@ -16,4 +16,4 @@ USING: kernel math namespaces sequences strings test ; CHAR: H 0 SBUF" hello world" [ set-nth ] keep 0 swap nth ] unit-test -[ SBUF" x" ] [ 1 [ CHAR: x >bignum over push ] keep ] unit-test +[ SBUF" x" ] [ 1 CHAR: x >bignum over push ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 77b7c474c1..6dff74bd02 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -90,7 +90,7 @@ SYMBOL: failures cpu "unknown" = [ [ "io/buffer" "compiler/optimizer" - "compiler/simplifier" "compiler/simple" + "compiler/simple" "compiler/stack" "compiler/ifte" "compiler/generic" "compiler/bail-out" "compiler/linearizer" "compiler/intrinsics" diff --git a/library/test/unparser.factor b/library/test/unparser.factor index 26c43db441..c6d157d3ee 100644 --- a/library/test/unparser.factor +++ b/library/test/unparser.factor @@ -28,7 +28,5 @@ unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ ] [ { 1 2 3 } unparse drop ] unit-test -! Unreadable objects -[ { 1 2 3 } vector-array unparse parse ] unit-test-fails [ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 1fc8cf6221..7134597978 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -75,14 +75,14 @@ unit-test [ "funky" ] [ "funny-stack" get pop ] unit-test [ t ] [ - { 1 2 3 4 } dup vector-array length - >r clone vector-array length r> + { 1 2 3 4 } dup underlying length + >r clone underlying length r> = ] unit-test [ f ] [ { 1 2 3 4 } dup clone - swap vector-array swap vector-array eq? + swap underlying swap underlying eq? ] unit-test [ 0 ] [