More powerful templating

diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor
deleted file mode 100644 (file)
index 2510c32..0000000
--- a/library/compiler/basic-blocks.factor
+++ /dev/null
@@ -1,178 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: arrays hashtables kernel lists math namespaces sequences ;
-
-! Optimizations performed here:
-! - combining %inc-d/%inc-r within a single basic block
-! - if a literal is loaded into a vreg but the vreg is
-!   overwritten before being read, the literal load is deleted
-! - if a %replace is writing a vreg to a stack location already
-!   holding that vreg, or a stack location that is not read
-!   before being popped, the %replace is deleted
-! - if a %peek is reading a stack location into a vreg that
-!   already holds that vreg, or if the vreg is overwritten
-!   before being read, the %peek is deleted
-! - removing dead loads of stack locations into vregs
-! - removing dead stores of vregs into stack locations
-
-: vop-in ( vop n -- input ) swap vop-inputs nth ;
-: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
-: vop-out ( vop n -- input ) swap vop-outputs nth ;
-: set-vop-out ( output vop n -- ) swap vop-outputs set-nth ;
-
-: (split-blocks) ( n linear -- )
-    2dup length = [
-        dup like , drop
-    ] [
-        2dup nth basic-block? [
-            >r 1+ r> (split-blocks)
-        ] [
-            (cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
-        ] if
-    ] if ;
-
-: split-blocks ( linear -- blocks )
-    [ 0 swap (split-blocks) ] { } make ;
-
-SYMBOL: d-height
-SYMBOL: r-height
-
-! combining %inc-d/%inc-r
-GENERIC: simplify-stack* ( vop -- )
-
-M: tuple simplify-stack* ( vop -- ) drop ;
-
-: accum-height ( vop var -- )
-    >r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ;
-
-M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
-
-M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
-
-GENERIC: update-loc ( loc -- loc )
-
-M: ds-loc update-loc ds-loc-n d-height get - <ds-loc> ;
-
-M: cs-loc update-loc cs-loc-n r-height get - <cs-loc> ;
-
-M: %peek simplify-stack* ( vop -- )
-    0 [ vop-in update-loc ] 2keep set-vop-in ;
-
-M: %replace simplify-stack* ( vop -- )
-    0 [ vop-out update-loc ] 2keep set-vop-out ;
-
-: simplify-stack ( block -- )
-    #! Combine all %inc-d/%inc-r into two final ones.
-    #! Destructively modifies the VOPs in the block.
-    [ simplify-stack* ] each ;
-
-: each-tail ( seq quot -- | quot: tail -- )
-    >r dup length [ swap tail-slice ] map-with r> each ; inline
-
-! removing dead loads/stores
-: preserves-location? ( exitcc location vop -- ? )
-    #! If the VOP writes the register, call the loop exit
-    #! continuation with 'f'.
-    {
-        { [ 2dup vop-inputs member? ] [ 3drop t ] }
-        { [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }
-        { [ t ] [ 3drop f ] }
-    } cond ;
-
-GENERIC: live@end? ( location -- ? )
-
-M: tuple live@end? drop t ;
-
-M: ds-loc live@end? ds-loc-n d-height get + 0 >= ;
-
-M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
-
-: location-live? ( location tail -- ? )
-    #! A location is not live if and only if it is overwritten
-    #! before the end of the basic block.
-    [
-        -rot [ >r 2dup r> preserves-location? ] contains?
-        [ dup live@end? ] unless*
-    ] callcc1 2nip ;
-
-! Used for elimination of dead loads from the stack:
-! we keep a map of vregs to ds-loc/cs-loc/f.
-SYMBOL: vreg-contents
-
-GENERIC: trim-dead* ( tail vop -- )
-
-: forget-vregs ( vop -- )
-    vop-outputs [ vreg-contents get remove-hash ] each ;
-
-M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
-
-: ?, [ , ] [ drop ] if ;
-
-: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
-
-M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
-
-M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ;
-
-: live-load? ( tail vop -- ? )
-    #! If the VOP's output location is overwritten before being
-    #! read again, kill the VOP.
-    0 vop-out swap location-live? ;
-
-: remember-peek ( vop -- )
-    dup 0 vop-in swap 0 vop-out vreg-contents get set-hash ;
-
-: redundant-peek? ( vop -- ? )
-    dup 0 vop-in swap 0 vop-out vreg-contents get hash = ;
-
-M: %peek trim-dead* ( tail vop -- )
-    dup redundant-peek? >r tuck live-load? not r> or
-    [ dup remember-peek dup , ] unless drop ;
-
-: redundant-replace? ( vop -- ? )
-    dup 0 vop-out swap 0 vop-in vreg-contents get hash = ;
-
-: forget-stack-loc ( loc -- )
-    #! Forget that any vregs hold this stack location.
-    vreg-contents [ [ nip swap = not ] hash-subset-with ] change ;
-
-: remember-replace ( vop -- )
-    #! If a vreg claims to hold the stack location we are
-    #! writing to, we must forget this fact, since that stack
-    #! location no longer holds this value!
-    dup 0 vop-out forget-stack-loc
-    dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ;
-
-M: %replace trim-dead* ( tail vop -- )
-    dup redundant-replace? >r tuck live-load? not r> or
-    [ dup remember-replace dup , ] unless drop ;
-
-: ?dead-literal dup forget-vregs tuck live-load? ?, ;
-
-M: %immediate trim-dead* ( tail vop -- ) ?dead-literal ;
-
-M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ;
-
-: trim-dead ( block -- )
-    #! Remove dead loads and stores.
-    [ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ;
-
-: simplify-block ( block -- block )
-    #! Destructively modifies the VOPs in the block.
-    [
-        0 d-height set
-        0 r-height set
-        H{ } clone vreg-contents set
-        dup simplify-stack
-        d-height get %inc-d r-height get %inc-r 2array append
-        trim-dead
-    ] { } make ;
-
-: keep-simplifying ( block -- block )
-    dup length >r simplify-block dup length r> =
-    [ keep-simplifying ] unless ;
-
-: simplify ( blocks -- blocks )
-    #! Simplify basic block IR.
-    [ keep-simplifying ] map ;

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index f4c064914e167e3304efe208de03c866df0afd32..1abc111a1f97adf763985f8292c2f1e8c26aa352 100644 (file)
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -61,6 +61,9 @@ M: object vreg>stack ( value loc -- )
     [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
     inline
 
+: reset-stack ( vector -- )
+    0 swap set-length ;
+
 : end-basic-block ( -- )
     \ %inc-d d-height finalize-height
     \ %inc-r r-height finalize-height
@@ -68,8 +71,8 @@ M: object vreg>stack ( value loc -- )
     phantom-r get [ <cs-loc> ] f vregs>stack
     phantom-d get [ <ds-loc> ] t vregs>stack
     phantom-r get [ <cs-loc> ] t vregs>stack
-    0 phantom-d get set-length
-    0 phantom-r get set-length ;
+    phantom-d get reset-stack
+    phantom-r get reset-stack ;
 
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
@@ -98,14 +101,41 @@ SYMBOL: any-reg
     3array flip
     [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
+: phantom-vregs ( phantom template -- )
+    [ second ] map [ set ] 2each ;
+
 : stack>vregs ( stack template quot -- )
-    >r unpair -rot alloc-regs dup length reverse r> map
-    (stack>vregs) swap [ set ] 2each ; inline
+    >r dup [ first ] map swapd alloc-regs
+    dup length reverse r> map
+    (stack>vregs) swap phantom-vregs ; inline
+
+: compatible-vreg?
+    swap dup value? [ 2drop t ] [ vreg-n = ] if ;
+
+: compatible-values? ( value template -- ? )
+    {
+        { [ dup any-reg eq? ] [ 2drop t ] }
+        { [ dup integer? ] [ compatible-vreg? ] }
+        { [ dup value eq? ] [ drop value? ] }
+    } cond ;
+
+: template-match? ( phantom template -- ? )
+    2dup [ length ] 2apply = [
+        f [ first compatible-values? and ] 2reduce
+    ] [
+        2drop f
+    ] if ;
+
+: template-input ( values template phantom quot -- )
+    >r swap [ template-match? ] 2keep rot [
+        rot r> 2drop over >r phantom-vregs r> reset-stack
+    ] [
+        nip end-basic-block r> stack>vregs
+    ] if ; inline
 
 : template-inputs ( stack template stack template -- )
-    end-basic-block
-    over >r [ <cs-loc> ] stack>vregs
-    over >r [ <ds-loc> ] stack>vregs
+    over >r phantom-r get [ <cs-loc> ] template-input
+    over >r phantom-d get [ <ds-loc> ] template-input
     r> r> [ length neg ] 2apply adjust-stacks ;
 
 : >phantom ( seq stack -- )