From 125e4befd3f4462724aabb63415ac4b6557051a8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Jan 2013 14:16:51 -0800
Subject: [PATCH] compiler.cfg.liveness: Add parallel-copy method for
 lookup-base-pointer*. Adjust lookup-base-pointer* stack effect to take two
 parameters. Still retain stack overflows, but more correct now...

---
 basis/compiler/cfg/liveness/liveness.factor | 26 ++++++++++++---------
 1 file changed, 15 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 7a03a77b94..5cc9456d56 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -68,36 +68,40 @@ M: vreg-insn visit-insn
 
 DEFER: lookup-base-pointer
 
-GENERIC: lookup-base-pointer* ( insn -- vreg/f )
+GENERIC: lookup-base-pointer* ( vreg insn -- vreg/f )
 
-M: ##tagged>integer lookup-base-pointer* src>> ;
+M: ##tagged>integer lookup-base-pointer* nip src>> ;
 
 M: ##unbox-any-c-ptr lookup-base-pointer*
     ! If the input to unbox-any-c-ptr was an alien and not a
     ! byte array, then the derived pointer will be outside of
     ! the data heap. The GC has to handle this case and ignore
     ! it.
-    src>> ;
+    nip src>> ;
 
-M: ##copy lookup-base-pointer* src>> lookup-base-pointer ;
+M: ##copy lookup-base-pointer* nip src>> lookup-base-pointer ;
 
-M: ##add-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+M: ##add-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
 
-M: ##sub-imm lookup-base-pointer* src1>> lookup-base-pointer ;
+M: ##sub-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
+
+M: ##parallel-copy lookup-base-pointer* values>> value-at ;
 
 M: ##add lookup-base-pointer*
     ! If both operands have a base pointer, then the user better
     ! not be doing memory reads and writes on the object, since
     ! we don't give it a base pointer in that case at all.
-    [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
+    nip [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
 
 M: ##sub lookup-base-pointer*
-    src1>> lookup-base-pointer ;
+    nip src1>> lookup-base-pointer ;
 
-M: vreg-insn lookup-base-pointer* drop f ;
+M: vreg-insn lookup-base-pointer* 2drop f ;
 
-: lookup-base-pointer ( vreg -- vreg/f )
-    base-pointers get [ ?leader insn-of lookup-base-pointer* ] cache ;
+: lookup-base-pointer ( vreg -- vregs/f )
+    base-pointers get [
+        dup ?leader insn-of lookup-base-pointer*
+    ] cache ;
 
 :: visit-derived-root ( vreg derived-roots gc-roots -- )
     vreg lookup-base-pointer :> base