new simplifier

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 143a0a3f4a575fe987464caac2059519d13e312a..1710ca5718a63c11df927961dc1694fcb7116757 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,6 +1,5 @@
 + compiler:\r
 \r
-- recursive? and tree-contains? should handle vectors\r
 - type inference fails with some assembler words;\r
   displaced, register and other predicates need to inherit from list\r
   not cons, and need stronger branch partial eval\r

diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor
index c16f80af3ebd74d716c3598ff211cbd9f60ffcf3..6b7e0dd495fa8ca577281b92c478f63e8f3c2994 100644 (file)
--- a/library/bootstrap/boot.factor
+++ b/library/bootstrap/boot.factor
@@ -72,9 +72,11 @@ USE: hashtables
 
     "traits" [ "generic" ] search
     "delegate" [ "generic" ] search
+    "object" [ "generic" ] search
 
     vocabularies get [ "generic" off ] bind
 
+    reveal
     reveal
     reveal
 

diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor
index 741cc386b03e9675fd37f084aaa995bfda25f712..699826f3da9d65943c529728b6169b62bf8675d7 100644 (file)
--- a/library/compiler/generator.factor
+++ b/library/compiler/generator.factor
@@ -49,10 +49,6 @@ SYMBOL: relocation-table
     #! If flag is true; relative.
     0 1 ? rel, relocating word-primitive rel, ;
 
-: rel-word ( word rel/abs -- )
-    #! If flag is true; relative.
-    over primitive? [ rel-primitive ] [ 2drop ] ifte ;
-
 : rel-dlsym ( name dll rel/abs -- )
     #! If flag is true; relative.
     2 3 ? rel, relocating cons intern-literal rel, ;
@@ -61,6 +57,14 @@ SYMBOL: relocation-table
     #! Relocate address just compiled.
     4 rel, relocating 0 rel, ;
 
+: rel-word ( word rel/abs -- )
+    #! If flag is true; relative.
+    over primitive? [
+        rel-primitive
+    ] [
+        nip [ rel-address ] unless
+    ] ifte ;
+
 : generate-node ( [[ op params ]] -- )
     #! Generate machine code for a node.
     unswons dup "generator" word-property [
@@ -107,6 +111,8 @@ SYMBOL: previous-offset
 
 #label [ save-xt ] "generator" set-word-property
 
+#end-dispatch [ drop ] "generator" set-word-property
+
 : type-tag ( type -- tag )
     #! Given a type number, return the tag number.
     dup 6 > [ drop 3 ] when ;

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 2f67034160c158a145b59186ae19cfbcb2fa6f08..4ab12d6d8baa67bbe4bfecc75fd41362de4c6873 100644 (file)
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -53,10 +53,13 @@ SYMBOL: #jump ( tail-call )
 SYMBOL: #jump-label ( tail-call )
 SYMBOL: #return-to ( push addr on C stack )
 
-! dispatch is linearized as dispatch followed by a #target
-! for each dispatch table entry. The linearizer ensures the
-! correct number of #targets is emitted.
+! dispatch is linearized as dispatch followed by a #target or
+! #target-label for each dispatch table entry. The dispatch
+! table terminates with #end-dispatch. The linearizer ensures
+! the correct number of #targets is emitted.
 SYMBOL: #target ( part of jump table )
+SYMBOL: #target-label
+SYMBOL: #end-dispatch
 
 : linear, ( node -- )
     #! Add a node to the linear IR.
@@ -146,7 +149,8 @@ SYMBOL: #target ( part of jump table )
     #! label/branch pairs.
     [ dispatch ] ,
     <label> ( end label ) swap
-    [ <label> dup #target swons ,  cons ] map ;
+    [ <label> dup #target-label swons ,  cons ] map
+    [ #end-dispatch ] , ;
 
 : dispatch-body ( end label/param -- )
     #! Output each branch, with a jump to the end label.

diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor
index 93b20d68db9ebc9563257528174749b241c179df..88b7847174916cece51e847a6443bd283efa731d 100644 (file)
--- a/library/compiler/optimizer.factor
+++ b/library/compiler/optimizer.factor
@@ -33,6 +33,7 @@ USE: inference
 USE: words
 USE: prettyprint
 USE: kernel-internals
+USE: vectors
 
 ! The optimizer transforms dataflow IR to dataflow IR. Currently
 ! it removes literals that are eventually dropped, and never
@@ -89,12 +90,24 @@ USE: kernel-internals
     #! Push a list of literals that may be killed in the IR.
     dup scan-literals [ over can-kill? ] subset nip ;
 
+SYMBOL: branch-returns
+
 : can-kill-branches? ( literal node -- ? )
-    #! Check if the literal appears in either branch.
+    #! Check if the literal appears in either branch. This
+    #! assumes that the last element of each branch is a #values
+    #! node.
     2dup consumes-literal? [
         2drop f
     ] [
-        [ node-param get ] bind [ dupd can-kill? ] all? nip
+        [ node-param get ] bind
+        [
+            dup [
+                last [ node-consume-d get list>vector ] bind
+            ] map
+            unify-stacks vector>list
+            branch-returns set
+            [ dupd can-kill? ] all? nip
+        ] with-scope
     ] ifte ;
 
 : kill-node ( literals node -- )
@@ -170,6 +183,14 @@ USE: kernel-internals
     ] extend ,
 ] "kill-node" set-word-property
 
+#values [
+    dupd consumes-literal? [
+        branch-returns get mentions-literal?
+    ] [
+        drop t
+    ] ifte
+] "can-kill" set-word-property
+
 \ ifte [ scan-branches ] "scan-literal" set-word-property
 \ ifte [ can-kill-branches? ] "can-kill" set-word-property
 \ ifte [ kill-branches ] "kill-node" set-word-property

diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor
index 66adc5ba08395c956a6ebf9e31af99d6c1b7d9d8..6ab799283be3cc62d2fce0b4c7c17fde4935f3ae 100644 (file)
--- a/library/compiler/simplifier.factor
+++ b/library/compiler/simplifier.factor
@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -26,101 +26,176 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: compiler
-USE: inference
-USE: errors
-USE: generic
-USE: hashtables
 USE: kernel
 USE: lists
-USE: math
 USE: namespaces
-USE: parser
-USE: prettyprint
-USE: stdio
-USE: strings
-USE: unparser
-USE: vectors
 USE: words
+USE: inference
+USE: strings
+USE: strings
+USE: prettyprint
 
-: labels ( linear -- list )
-    #! Make a list of all labels defined in the linear IR.
-    [ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ;
+! The linear IR being simplified is stored in this variable.
+SYMBOL: simplifying
 
-: label-called? ( label linear -- ? )
-    [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
+: simplifiers ( linear -- list )
+    #! A list of quotations with stack effect
+    #! ( linear -- linear ? ) that can simplify the first node
+    #! in the linear IR.
+    car car "simplifiers" word-property ;
 
-: purge-label ( label linear -- )
-    >r dup cdr r> label-called? [ , ] [ drop ] ifte ;
+: simplify-node ( linear list -- linear ? )
+    dup [
+        uncons >r call [
+            r> drop t
+        ] [
+            r> simplify-node
+        ] ifte
+    ] when ;
 
-: purge-labels ( linear -- linear )
-    #! Remove all unused labels.
-    [
-        dup [
-            dup car #label = [ over purge-label ] [ , ] ifte
-        ] each drop
-    ] make-list ;
-
-: singleton ( word op default -- )
-    >r word-property dup [
-        r> drop call
+: simplify-1 ( linear -- linear ? )
+    #! Return a new linear IR.
+    dup [
+        dup simplifiers simplify-node
+        [ uncons simplify-1 >r cons r> ] unless*
     ] [
-        drop r> call
+        f
     ] ifte ;
 
-: simplify-node ( node rest -- rest ? )
-    over car "simplify" [ swap , f ] singleton ;
+: simplify ( linear -- linear )
+    #! Keep simplifying until simplify-1 returns f.
+    [
+        dup simplifying set  simplify-1 [ simplify ] when
+    ] with-scope ;
 
-: find-label ( label linear -- rest )
-    [ cdr over = ] some? cdr nip ;
+: label-called? ( label linear -- ? )
+    [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
 
-: (simplify) ( list -- ? )
-    dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ;
+: next-physical? ( op linear -- ? )
+    cdr dup [ car car = ] [ 2drop f ] ifte ;
 
-: simplify ( linear -- linear )
-    ( purge-labels ) [ (simplify) ] make-list ;
+: cancel ( linear op -- linear param ? )
+    #! If the following op is as given, remove it, and return
+    #! its param.
+    over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
 
-: follow ( linear -- linear )
-    dup car car "follow" [ ] singleton ;
+#label [
+    [
+        dup car cdr simplifying get
+        label-called? [ f ] [ cdr t ] ifte
+    ]
+] "simplifiers" set-word-property
+
+\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-property
+\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-property
+\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-property
+\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-property
+
+: next-logical ( linear -- linear )
+    dup car car "next-logical" word-property call ;
 
 #label [
-    cdr follow
-] "follow" set-word-property
+    cdr next-logical
+] "next-logical" set-word-property
+
+: find-label ( label -- rest )
+    simplifying get [
+        uncons pick = swap #label = and
+    ] some? nip ;
 
 #jump-label [
-    uncons >r cdr r> find-label follow
-] "follow" set-word-property
+    car cdr find-label cdr
+] "next-logical" set-word-property
 
-: follows? ( op linear -- ? )
-    follow dup [ car car = ] [ 2drop f ] ifte ;
+#target-label [
+    car cdr find-label cdr
+] "next-logical" set-word-property
 
-GENERIC: simplify-call ( node rest -- rest ? )
-M: cons simplify-call ( node rest -- rest ? )
-    swap , f ;
+: next-logical? ( op linear -- ? )
+    next-logical dup [ car car = ] [ 2drop f ] ifte ;
 
-PREDICATE: cons return-follows #return swap follows? ;
-M: return-follows simplify-call ( node rest -- rest ? )
-    >r
-    unswons [
-        [[ #call #jump ]]
-        [[ #call-label #jump-label ]]
-    ] assoc swons , r> t ;
+: reduce ( linear op new -- linear ? )
+    >r over cdr next-logical? [
+        unswons cdr r> swons swons t
+    ] [
+        r> drop f
+    ] ifte ;
+
+#call [
+    [
+        #return #jump reduce
+    ]
+] "simplifiers" set-word-property
 
-#call [ simplify-call ] "simplify" set-word-property
-#call-label [ simplify-call ] "simplify" set-word-property
+#call-label [
+    [
+        #return #jump-label reduce
+    ]
+] "simplifiers" set-word-property
+
+: double-jump ( linear op1 op2 -- 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 just of type op2.
+    swap pick next-logical? [
+        over next-logical car cdr cons swap cdr cons t
+    ] [
+        drop f
+    ] ifte ;
 
-GENERIC: simplify-drop ( node rest -- rest ? )
-M: cons simplify-drop ( node rest -- rest ? )
-    swap , f ;
+: 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 ;
 
-PREDICATE: cons push-next ( list -- ? )
+: (dead-code) ( linear -- linear ? )
+    #! Remove all nodes until the next #label.
     dup [
-        car car [ #push-immediate #push-indirect ] contains?
-    ] when ;
+        dup car car #label = [
+            f
+        ] [
+            cdr (dead-code) t or
+        ] ifte
+    ] [
+        f
+    ] ifte ;
 
-M: push-next simplify-drop ( node rest -- rest ? )
-    nip uncons >r unswons [
-        [[ #push-immediate #replace-immediate ]]
-        [[ #push-indirect #replace-indirect ]]
-    ] assoc swons , r> t ;
+: dead-code ( linear -- linear ? )
+    uncons (dead-code) >r cons r> ;
 
-\ drop [ simplify-drop ] "simplify" set-word-property
+#jump-label [
+    [
+        #return #return double-jump
+    ] [
+        #jump-label #jump-label double-jump
+    ] [
+        #jump #jump double-jump
+    ] [
+        useless-jump
+    ] [
+        dead-code
+    ]
+] "simplifiers" set-word-property
+
+#target-label [
+    [
+        #jump-label #target-label double-jump
+    ] [
+        #jump #target double-jump
+    ]
+] "simplifiers" set-word-property
+
+#jump [ [ dead-code ] ] "simplifiers" set-word-property
+#return [ [ dead-code ] ] "simplifiers" set-word-property
+#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-property
+
+\ drop [
+    [
+        #push-immediate cancel [
+            #replace-immediate swons swons t
+        ] when
+    ] [
+        #push-indirect cancel [
+            #replace-indirect swons swons t
+        ] when
+    ]
+] "simplifiers" set-word-property

diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor
index 49869123281c8939e6b347a6ffbf1993f4cd2ace..35a2f15012317fffa89751c572092a50bc45ea37 100644 (file)
--- a/library/compiler/x86/generator.factor
+++ b/library/compiler/x86/generator.factor
@@ -52,6 +52,9 @@ USE: words
 : compile-call ( word -- )
     dup dup postpone-word  compile-call-label  t rel-word ;
 
+: compile-target ( word -- )
+    compiled-offset 0 compile-cell 0 defer-xt ;
+
 #call [
     compile-call
 ] "generator" set-word-property
@@ -97,9 +100,14 @@ USE: words
     compiled-offset swap set-compiled-cell ( fixup -- )
 ] "generator" set-word-property
 
+#target-label [
+    #! Jump table entries are absolute addresses.
+    compile-target rel-address
+] "generator" set-word-property
+
 #target [
     #! Jump table entries are absolute addresses.
-    compiled-offset 0 compile-cell 0 defer-xt rel-address
+    dup dup postpone-word compile-target f rel-word
 ] "generator" set-word-property
 
 #c-call [

diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor
index a7a746f6614890a6964ea59f8a2561f6f7ef81b4..551b2af6409991536b5e68af8475cec0d5026393 100644 (file)
--- a/library/test/compiler/optimizer.factor
+++ b/library/test/compiler/optimizer.factor
@@ -18,3 +18,5 @@ USE: lists
 [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
 
 [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f <literal> ] map kill-mask ] unit-test
+
+[ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test

diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor
index 8b9876555dc10dc8154a0805ef53d17b3cbe1d87..5f8a64fe223b35c8c27bdda5125ea1dd7117b19c 100644 (file)
--- a/library/test/compiler/simplifier.factor
+++ b/library/test/compiler/simplifier.factor
@@ -4,32 +4,54 @@ 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 ] ] find-label ]
+[
+    [
+        123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ]
+        simplifying set find-label cdr
+    ] with-scope
+]
 unit-test
 
 [ [ [ #return ] ] ]
-[ [ [[ #label 123 ]] [ #return ] ] follow ]
+[
+    [
+        [
+            [[ #jump-label 123 ]]
+            [[ #call car ]]
+            [[ #label 123 ]]
+            [ #return ]
+        ] dup simplifying set next-logical
+    ] with-scope
+]
 unit-test
 
-[ [ [ #return ] ] ]
+[
+    [ [[ #return f ]] ]
+]
 [
     [
         [[ #jump-label 123 ]]
-        [[ #call car ]]
         [[ #label 123 ]]
         [ #return ]
-    ] follow
-]
-unit-test
+    ] simplify
+] unit-test
 
 [
-    [[ #jump car ]]
+    [ [[ #jump car ]] ]
 ]
 [
     [
@@ -37,22 +59,17 @@ unit-test
         [[ #jump-label 123 ]]
         [[ #label 123 ]]
         [ #return ]
-    ] simplify car
+    ] simplify
 ] unit-test
 
 [
-    t
+    [ [[ swap f ]] ]
 ] [
     [
-        [[ #push-immediate 1 ]]
-    ] push-next? >boolean
-] unit-test
-
-[
-    [
-        [[ #replace-immediate 1 ]]
-        [ #return ]
-    ]
-] [
-    [ drop 1 ] dataflow linearize simplify
+        [[ #jump-label 1 ]]
+        [[ #label 1 ]]
+        [[ #jump-label 2 ]]
+        [[ #label 2 ]]
+        [[ swap f ]]
+    ] simplify
 ] unit-test

diff --git a/library/tools/word-tools.factor b/library/tools/word-tools.factor
index 073d41fd86c27a3e193d200792509923877b832d..14a38b0943d38c808a97d9fc337b370133201d46 100644 (file)
--- a/library/tools/word-tools.factor
+++ b/library/tools/word-tools.factor
@@ -36,13 +36,18 @@ USE: stdio
 USE: strings
 USE: unparser
 USE: math
+USE: hashtables
 
-: word-uses? ( of in -- ? )
+GENERIC: word-uses? ( of in -- ? )
+M: word word-uses? 2drop f ;
+M: compound word-uses? ( of in -- ? )
     2dup = [
         2drop f ! Don't say that a word uses itself
     ] [
         word-parameter tree-contains?
     ] ifte ;
+M: generic word-uses? ( of in -- ? )
+    "methods" word-property hash>alist tree-contains? ;
 
 : usages-in-vocab ( of vocab -- usages )
     #! Push a list of all usages of a word in a vocabulary.

diff --git a/library/vectors.factor b/library/vectors.factor
index dc8ec5be543b22236b2ed88f68cb2a1bdcc870e8..a2cf2c11acbb6be1279caf3cf8fe3bb0d173ba99 100644 (file)
--- a/library/vectors.factor
+++ b/library/vectors.factor
@@ -167,11 +167,6 @@ M: vector hashcode ( vec -- n )
         over vector-nth hashcode rot bitxor swap
     ] times* drop ;
 
-: vector-head ( n vector -- list )
-    #! Return a new list with all elements up to the nth
-    #! element.
-    swap [ over vector-nth ] vector-project nip ;
-
 : vector-tail ( n vector -- list )
     #! Return a new list with all elements from the nth
     #! index upwards.

diff --git a/native/bignum.c b/native/bignum.c
index 2347778a947cbad77c03c2e95ec19f341a6c895d..3f3bbd797d0afb16e415b35e45dbd810f63167e4 100644 (file)
--- a/native/bignum.c
+++ b/native/bignum.c
@@ -2,7 +2,7 @@
 
 F_FIXNUM to_integer(CELL x)
 {
-       switch(type_of(x))
+       switch(TAG(x))
        {
        case FIXNUM_TYPE:
                return untag_fixnum_fast(x);

diff --git a/native/fixnum.c b/native/fixnum.c
index 9f9d5fb2728bab8844af00a4c6dcb4bad1522e24..8e48d2d019e1c2dadb0b495d230e673f4744cec3 100644 (file)
--- a/native/fixnum.c
+++ b/native/fixnum.c
@@ -7,7 +7,7 @@ F_FIXNUM to_fixnum(CELL tagged)
        F_ARRAY* y;
        F_FLOAT* f;
 
-       switch(type_of(tagged))
+       switch(TAG(tagged))
        {
        case FIXNUM_TYPE:
                return untag_fixnum_fast(tagged);

diff --git a/native/float.c b/native/float.c
index 3a5f2498703e26aad0949402869277144b23cdac..25db348551c5c6ff82003d1ad61102e43b7e4058 100644 (file)
--- a/native/float.c
+++ b/native/float.c
@@ -6,7 +6,7 @@ double to_float(CELL tagged)
        double x;
        double y;
 
-       switch(type_of(tagged))
+       switch(TAG(tagged))
        {
        case FIXNUM_TYPE:
                return (double)untag_fixnum_fast(tagged);