From 989a330f67aaab99f94b9ab2bf770fcc30078fc9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 18 Sep 2005 02:52:02 +0000
Subject: [PATCH] missing file

---
 library/compiler/stack.factor  | 97 ++++++++++++++++++++++++++++++++++
 library/inference/stack.factor | 51 ++++++++++++++++++
 2 files changed, 148 insertions(+)
 create mode 100644 library/compiler/stack.factor
 create mode 100644 library/inference/stack.factor

diff --git a/library/compiler/stack.factor b/library/compiler/stack.factor
new file mode 100644
index 0000000000..beb08f9d66
--- /dev/null
+++ b/library/compiler/stack.factor
@@ -0,0 +1,97 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler-frontend
+USING: compiler-backend generic inference kernel math namespaces
+sequences vectors words ;
+
+: immediate? ( obj -- ? )
+    #! fixnums and f have a pointerless representation, and
+    #! are compiled immediately. Everything else can be moved
+    #! by GC, and is indexed through a table.
+    dup fixnum? swap f eq? or ;
+
+GENERIC: load-value ( vreg n value -- )
+
+M: object load-value ( vreg n value -- )
+    drop %peek-d , ;
+
+: load-literal ( vreg obj -- )
+    dup immediate? [ %immediate ] [ %indirect ] ifte , ;
+
+M: literal load-value ( vreg n value -- )
+    nip literal-value load-literal ;
+
+SYMBOL: vreg-allocator
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup literal?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: stack>vreg ( value stack-pos loader -- )
+    pick >r vreg-allocator get r> set
+    pick value-dropped? [ pick get pick pick execute , ] unless
+    3drop vreg-allocator inc ; inline
+
+: (stacks>vregs) ( stack loader -- )
+    swap reverse-slice dup length
+    [ pick stack>vreg ] 2each drop ; inline
+
+: stacks>vregs ( #shuffle -- )
+    dup
+    node-in-d \ %peek-d (stacks>vregs)
+    node-in-r \ %peek-r (stacks>vregs) ;
+
+: shuffle-height ( #shuffle -- )
+    dup node-out-d length over node-in-d length - %inc-d ,
+    dup node-out-r length swap node-in-r length - %inc-r , ;
+
+: literal>stack ( stack-pos value storer -- )
+    >r literal-value r> fixnum-imm? pick immediate? and [
+        >r 0 swap load-literal 0 <vreg> r>
+    ] unless swapd execute , ; inline
+
+: computed>stack >r get <vreg> swap r> execute , ;
+
+: vreg>stack ( stack-pos value storer -- )
+    @{
+        @{ [ over not ] [ 3drop ] }@
+        @{ [ over literal? ] [ literal>stack ] }@
+        @{ [ t ] [ computed>stack ] }@
+    }@ cond ; inline
+
+: (vregs>stack) ( stack storer -- )
+    swap reverse-slice [ length ] keep
+    [ pick vreg>stack ] 2each drop ; inline
+
+: (vregs>stacks) ( stack stack -- )
+    \ %replace-r (vregs>stack) \ %replace-d (vregs>stack) ;
+
+: literals/computed ( stack -- literals computed )
+    dup [ dup literal? [ drop f ] unless ] map
+    swap [ dup literal? [ drop f ] when ] map ;
+
+: vregs>stacks ( -- )
+    live-d get literals/computed
+    live-r get literals/computed
+    swapd (vregs>stacks) (vregs>stacks) ;
+
+: ?nth ( n seq -- elt/f )
+    2dup length >= [ 2drop f ] [ nth ] ifte ;
+
+: live-stores ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
+
+M: #shuffle linearize* ( #shuffle -- )
+    [
+        0 vreg-allocator set
+        dup node-in-d over node-out-d live-stores live-d set
+        dup node-in-r over node-out-r live-stores live-r set
+        dup stacks>vregs
+        dup shuffle-height
+        vregs>stacks
+    ] with-scope linearize-next ;
diff --git a/library/inference/stack.factor b/library/inference/stack.factor
new file mode 100644
index 0000000000..2b3fa38e14
--- /dev/null
+++ b/library/inference/stack.factor
@@ -0,0 +1,51 @@
+IN: inference
+USING: generic interpreter kernel lists math namespaces
+sequences words ;
+
+: infer-shuffle-inputs ( shuffle node -- )
+    >r dup shuffle-in-d length swap shuffle-in-r length r>
+    node-inputs ;
+
+: shuffle-stacks ( shuffle -- )
+    #! Shuffle simulated stacks.
+    meta-d get meta-r get rot shuffle meta-r set meta-d set ;
+
+: infer-shuffle-outputs ( shuffle node -- )
+    >r dup shuffle-out-d length swap shuffle-out-r length r>
+    node-outputs ;
+
+: infer-shuffle ( shuffle -- )
+    #shuffle
+    2dup infer-shuffle-inputs
+    over shuffle-stacks
+    tuck infer-shuffle-outputs
+    node, ;
+
+: shuffle>effect ( shuffle -- effect )
+    dup shuffle-in-d [ drop object ] map
+    swap shuffle-out-d [ drop object ] map 2list ;
+
+: define-shuffle ( word shuffle -- )
+    [ shuffle>effect "infer-effect" set-word-prop ] 2keep
+    [ , \ infer-shuffle , ] [ ] make "infer" set-word-prop ;
+
+{
+    { drop  << shuffle f 1 0 {             } {   } >> }
+    { 2drop << shuffle f 2 0 {             } {   } >> }
+    { 3drop << shuffle f 3 0 {             } {   } >> }
+    { dup   << shuffle f 1 0 { 0 0         } {   } >> }
+    { 2dup  << shuffle f 2 0 { 0 1 0 1     } {   } >> }
+    { 3dup  << shuffle f 3 0 { 0 1 2 0 1 2 } {   } >> }
+    { rot   << shuffle f 3 0 { 1 2 0       } {   } >> }
+    { -rot  << shuffle f 3 0 { 2 0 1       } {   } >> }
+    { dupd  << shuffle f 2 0 { 0 0 1       } {   } >> }
+    { swapd << shuffle f 3 0 { 1 0 2       } {   } >> }
+    { nip   << shuffle f 2 0 { 1           } {   } >> }
+    { 2nip  << shuffle f 3 0 { 2           } {   } >> }
+    { tuck  << shuffle f 2 0 { 1 0 1       } {   } >> }
+    { over  << shuffle f 2 0 { 0 1 0       } {   } >> }
+    { pick  << shuffle f 3 0 { 0 1 2 0     } {   } >> }
+    { swap  << shuffle f 2 0 { 1 0         } {   } >> }
+    { >r    << shuffle f 1 0 {             } { 0 } >> }
+    { r>    << shuffle f 0 1 { 0           } {   } >> }
+} [ first2 define-shuffle ] each