diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor index 1abc111a1f..c5ee0fcf4b 100644 --- a/library/compiler/templates.factor +++ b/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: ( n stack -- loc ) +! +! TUPLE: phantom-datastack ; +! +! C: phantom-datastack [ >r r> ] set-delegate ; +! +! M: phantom-datastack drop ; +! +! TUPLE: phantom-callstack ; +! +! C: phantom-callstack [ >r r> ] set-delegate ; +! +! M: phantom-callstack drop ; + 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 dup r> %peek , nip ; M: value stack>vreg ( value vreg loc -- operand ) - drop >r value-literal r> dup value eq? - [ drop ] [ [ load-literal ] keep ] if ; + drop dup value eq? [ + drop + ] [ + >r value-literal r> [ 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 ; diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 263be79353..b5b3dbb34e 100644 --- a/library/inference/dataflow.factor +++ b/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 - -: \ counter ; - -TUPLE: value uid literal recursion ; - -C: value ( obj -- value ) - 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. diff --git a/library/inference/shuffle.factor b/library/inference/shuffle.factor index 54f29336e7..d65af168ab 100644 --- a/library/inference/shuffle.factor +++ b/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 + +: \ counter ; + +TUPLE: value uid literal recursion ; + +C: value ( obj -- value ) + 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 -- )