Debugging compiler

library/compiler/templates.factor

@@ -4,6 +4,22 @@ IN: compiler
 USING: arrays generic inference kernel math
 namespaces sequences vectors words ;
 
+! TUPLE: phantom-stack height elements ;
+! 
+! GENERIC: <loc> ( n stack -- loc )
+! 
+! TUPLE: phantom-datastack ;
+! 
+! C: phantom-datastack [ >r <phantom-stack> r> ] set-delegate ;
+! 
+! M: phantom-datastack <loc> drop <ds-loc> ;
+! 
+! TUPLE: phantom-callstack ;
+! 
+! C: phantom-callstack [ >r <phantom-stack> r> ] set-delegate ;
+! 
+! M: phantom-callstack <loc> drop <cs-loc> ;
+
 SYMBOL: d-height
 SYMBOL: r-height
 
@@ -35,11 +51,6 @@ C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
 : load-literal ( obj vreg -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-: literal>stack ( value loc -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
 G: vreg>stack ( value loc -- ) 1 standard-combination ;
 
 M: f vreg>stack ( value loc -- ) 2drop ;
@@ -83,8 +94,11 @@ M: object stack>vreg ( value vreg loc -- operand )
     >r <vreg> dup r> %peek , nip ;
 
 M: value stack>vreg ( value vreg loc -- operand )
-    drop >r value-literal r> dup value eq?
+    drop dup value eq? [
-    [ drop ] [ <vreg> [ load-literal ] keep ] if ;
+        drop
+    ] [
+        >r value-literal r> <vreg> [ load-literal ] keep
+    ] if ;
 
 SYMBOL: vreg-allocator
 
@@ -102,7 +116,9 @@ SYMBOL: any-reg
     [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
 : phantom-vregs ( phantom template -- )
-    [ second ] map [ set ] 2each ;
+    >r [ dup value? [ value-literal ] when ] map r>
+    [ second ] map
+    [ set ] 2each ;
 
 : stack>vregs ( stack template quot -- )
     >r dup [ first ] map swapd alloc-regs
@@ -110,18 +126,19 @@ SYMBOL: any-reg
     (stack>vregs) swap phantom-vregs ; inline
 
 : compatible-vreg?
-    swap dup value? [ 2drop t ] [ vreg-n = ] if ;
+    swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
     {
-        { [ dup any-reg eq? ] [ 2drop t ] }
+        { [ dup any-reg eq? ] [ drop vreg? ] }
         { [ dup integer? ] [ compatible-vreg? ] }
         { [ dup value eq? ] [ drop value? ] }
+        { [ dup not ] [ 2drop t ] }
     } cond ;
 
 : template-match? ( phantom template -- ? )
     2dup [ length ] 2apply = [
-        f [ first compatible-values? and ] 2reduce
+        t [ first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;

library/inference/dataflow.factor

@@ -4,26 +4,6 @@ IN: inference
 USING: arrays generic hashtables interpreter kernel lists math
 namespaces parser sequences words ;
 
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
-
-: <computed> \ <computed> counter ;
-
-TUPLE: value uid literal recursion ;
-
-C: value ( obj -- value )
-    <computed> over set-value-uid
-    recursive-state get over set-value-recursion
-    [ set-value-literal ] keep ;
-
-M: value hashcode value-uid ;
-
-M: value = eq? ;
-
-M: integer value-uid ;
-
-M: integer value-recursion drop f ;
-
 ! The dataflow IR is the first of the two intermediate
 ! representations used by Factor. It annotates concatenative
 ! code with stack flow information and types.

library/inference/shuffle.factor

@@ -1,6 +1,28 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: inference
 USING: hashtables kernel math namespaces sequences ;
 
+! Recursive state. An alist, mapping words to labels.
+SYMBOL: recursive-state
+
+: <computed> \ <computed> counter ;
+
+TUPLE: value uid literal recursion ;
+
+C: value ( obj -- value )
+    <computed> over set-value-uid
+    recursive-state get over set-value-recursion
+    [ set-value-literal ] keep ;
+
+M: value hashcode value-uid ;
+
+M: value = eq? ;
+
+M: integer value-uid ;
+
+M: integer value-recursion drop f ;
+
 TUPLE: shuffle in-d in-r out-d out-r ;
 
 : load-shuffle ( d r shuffle -- )