unit tests mostly pass with new compiler

diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor
new file mode 100644 (file)
index 0000000..17623e7
--- /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 6012ba1237cd2339e719b568f7efd0e10825afdc..5825c52181ad196c6e4bf2b2f783268619380fd8 100644 (file)
--- 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 8c3f67c108e1e687c065b046c01e3c9b8f27ed7c..95090e650d53efb11334ccc85ff6ec1b92a8e0c7 100644 (file)
--- 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 (file)
index dd3670e..0000000
--- 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 b98beb0bc05e7768ab7e176dea8efff99dba2d99..d1026aaf28037f33f54270d30e5d2da6f6b2baaf 100644 (file)
--- 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 94dd9b81e68f4d104126b052c5e35b3a02fd691b..201c1b606c4c5b58efaa487cf304d67f122ef5b1 100644 (file)
--- 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 1f1d783d2a1e28a8a1551e5727f396ecf2cf0070..b2b08c12d5188e4481056fe8fc9f24c5dd6a6122 100644 (file)
--- 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 <sbuf> [ CHAR: x >bignum over push ] keep ] unit-test
+[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test

diff --git a/library/test/test.factor b/library/test/test.factor
index 77b7c474c193ed949b782840781540400440f4d0..6dff74bd0252d8091d1281f9ae1f77bf67fb0324 100644 (file)
--- 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 26c43db441001c5ef9e9befd278e68406649dd42..c6d157d3ee6eddda910120a781bc1830c5942ce3 100644 (file)
--- 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 1fc8cf62216be4b1db8dffd021d37bf2b270139d..713459797824cc369c9d646dc6ad173cdafc330a 100644 (file)
--- 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 ] [