new simplifier

TODO.FACTOR.txt

@@ -1,6 +1,5 @@
 + compiler:
 
-- recursive? and tree-contains? should handle vectors
 - type inference fails with some assembler words;
   displaced, register and other predicates need to inherit from list
   not cons, and need stronger branch partial eval

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
 

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 ;

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
+! dispatch is linearized as dispatch followed by a #target or
-! for each dispatch table entry. The linearizer ensures the
+! #target-label for each dispatch table entry. The dispatch
-! correct number of #targets is emitted.
+! 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.

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

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 )
+! The linear IR being simplified is stored in this variable.
-    #! Make a list of all labels defined in the linear IR.
+SYMBOL: simplifying
-    [ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ;
+
+: 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 ;
+
+: simplify-node ( linear list -- linear ? )
+    dup [
+        uncons >r call [
+            r> drop t
+        ] [
+            r> simplify-node
+        ] ifte
+    ] when ;
+
+: simplify-1 ( linear -- linear ? )
+    #! Return a new linear IR.
+    dup [
+        dup simplifiers simplify-node
+        [ uncons simplify-1 >r cons r> ] unless*
+    ] [
+        f
+    ] ifte ;
+
+: simplify ( linear -- linear )
+    #! Keep simplifying until simplify-1 returns f.
+    [
+        dup simplifying set  simplify-1 [ simplify ] when
+    ] with-scope ;
 
 : label-called? ( label linear -- ? )
     [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
 
-: purge-label ( label linear -- )
+: next-physical? ( op linear -- ? )
-    >r dup cdr r> label-called? [ , ] [ drop ] ifte ;
+    cdr dup [ car car = ] [ 2drop f ] ifte ;
 
-: purge-labels ( linear -- linear )
+: cancel ( linear op -- linear param ? )
-    #! Remove all unused labels.
+    #! If the following op is as given, remove it, and return
-    [
+    #! its param.
-        dup [
+    over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
-            dup car #label = [ over purge-label ] [ , ] ifte
-        ] each drop
-    ] make-list ;
-
-: singleton ( word op default -- )
-    >r word-property dup [
-        r> drop call
-    ] [
-        drop r> call
-    ] ifte ;
-
-: simplify-node ( node rest -- rest ? )
-    over car "simplify" [ swap , f ] singleton ;
-
-: find-label ( label linear -- rest )
-    [ cdr over = ] some? cdr nip ;
-
-: (simplify) ( list -- ? )
-    dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ;
-
-: simplify ( linear -- linear )
-    ( purge-labels ) [ (simplify) ] make-list ;
-
-: follow ( linear -- linear )
-    dup car car "follow" [ ] singleton ;
 
 #label [
-    cdr follow
+    [
-] "follow" set-word-property
+        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 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
+    car cdr find-label cdr
-] "follow" set-word-property
+] "next-logical" set-word-property
 
-: follows? ( op linear -- ? )
+#target-label [
-    follow dup [ car car = ] [ 2drop f ] ifte ;
+    car cdr find-label cdr
+] "next-logical" set-word-property
 
-GENERIC: simplify-call ( node rest -- rest ? )
+: next-logical? ( op linear -- ? )
-M: cons simplify-call ( node rest -- rest ? )
+    next-logical dup [ car car = ] [ 2drop f ] ifte ;
-    swap , f ;
 
-PREDICATE: cons return-follows #return swap follows? ;
+: reduce ( linear op new -- linear ? )
-M: return-follows simplify-call ( node rest -- rest ? )
+    >r over cdr next-logical? [
-    >r
+        unswons cdr r> swons swons t
-    unswons [
+    ] [
-        [[ #call #jump ]]
+        r> drop f
-        [[ #call-label #jump-label ]]
+    ] ifte ;
-    ] assoc swons , r> t ;
 
-#call [ simplify-call ] "simplify" set-word-property
+#call [
-#call-label [ simplify-call ] "simplify" set-word-property
+    [
+        #return #jump reduce
+    ]
+] "simplifiers" set-word-property
 
-GENERIC: simplify-drop ( node rest -- rest ? )
+#call-label [
-M: cons simplify-drop ( node rest -- rest ? )
+    [
-    swap , f ;
+        #return #jump-label reduce
+    ]
+] "simplifiers" set-word-property
 
-PREDICATE: cons push-next ( list -- ? )
+: 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 ;
+
+: 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 [
-        car car [ #push-immediate #push-indirect ] contains?
+        dup car car #label = [
-    ] when ;
+            f
+        ] [
+            cdr (dead-code) t or
+        ] ifte
+    ] [
+        f
+    ] ifte ;
 
-M: push-next simplify-drop ( node rest -- rest ? )
+: dead-code ( linear -- linear ? )
-    nip uncons >r unswons [
+    uncons (dead-code) >r cons r> ;
-        [[ #push-immediate #replace-immediate ]]
-        [[ #push-indirect #replace-indirect ]]
-    ] assoc swons , r> t ;
 
-\ 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

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 [

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

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 ]
+[
-unit-test
+    [
-
+        123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ]
-[ [ [ #return ] ] ]
+        simplifying set find-label cdr
-[ [ [[ #label 123 ]] [ #return ] ] follow ]
+    ] with-scope
+]
 unit-test
 
 [ [ [ #return ] ] ]
 [
     [
-        [[ #jump-label 123 ]]
+        [
-        [[ #call car ]]
+            [[ #jump-label 123 ]]
-        [[ #label 123 ]]
+            [[ #call car ]]
-        [ #return ]
+            [[ #label 123 ]]
-    ] follow
+            [ #return ]
+        ] dup simplifying set next-logical
+    ] with-scope
 ]
 unit-test
 
 [
-    [[ #jump car ]]
+    [ [[ #return f ]] ]
+]
+[
+    [
+        [[ #jump-label 123 ]]
+        [[ #label 123 ]]
+        [ #return ]
+    ] simplify
+] unit-test
+
+[
+    [ [[ #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 ]]
+        [[ #jump-label 1 ]]
-    ] push-next? >boolean
+        [[ #label 1 ]]
-] unit-test
+        [[ #jump-label 2 ]]
-
+        [[ #label 2 ]]
-[
+        [[ swap f ]]
-    [
+    ] simplify
-        [[ #replace-immediate 1 ]]
-        [ #return ]
-    ]
-] [
-    [ drop 1 ] dataflow linearize simplify
 ] unit-test

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.

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.

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);

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);

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);