ok simplify the refs back

5 files changed, 54 insertions, 66 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 9e4215c..53ebe82 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -10,10 +10,14 @@ import qualified Operators as O
 
 bi = Builtin
 
-hello =
-  bi $ do
-    liftIO $ putStrLn "hllo prlg"
-    return Nothing
+hello :: BuiltinFn
+hello = do
+  liftIO $ putStrLn "hllo prlg"
+  return Nothing
+
+printLocals :: BuiltinFn
+printLocals = do
+  return Nothing
 
 addBuiltins :: PrlgEnv ()
 addBuiltins = do
@@ -21,28 +25,30 @@ addBuiltins = do
   a <- findAtom "a"
   b <- findAtom "b"
   c <- findAtom "c"
+  varX <- findAtom "X"
   b0 <- findStruct "b" 0
   any1 <- findStruct "any" 1
   eq2 <- findStruct "=" 2
   hello0 <- findStruct "hello" 0
   fail0 <- findStruct "fail" 0
   true0 <- findStruct "true" 0
-  prlgstate0 <- findStruct "prlgstate" 0
+  printlocals0 <- findStruct "print_locals" 0
+  debugprint0 <- findStruct "interpreter_state" 0
   modify $ \s ->
     s
       { defs =
           M.fromList
-            [ (eq2, [[U (LocalRef 0 Nothing), U (LocalRef 0 Nothing), NoGoal]])
+            [ (eq2, [[U (LocalRef 0 varX), U (LocalRef 0 varX), NoGoal]])
             , (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]])
             , ( b0
               , [ [Goal, U (Struct a1), U (Atom c), LastCall]
                 , [Goal, U (Struct a1), U (Atom b), LastCall]
                 ])
-            , (any1, [[U (VoidRef Nothing), NoGoal]])
-            , (hello0, [[Invoke hello]])
+            , (any1, [[U VoidRef, NoGoal]])
+            , (hello0, [[Invoke $ bi hello]])
             , (fail0, [[Invoke $ bi backtrack]])
             , (true0, [[Invoke $ bi (pure Nothing)]])
-            , ( prlgstate0
+            , ( debugprint0
               , [[Invoke $ bi (get >>= liftIO . print >> pure Nothing)]])
             ]
       , ops = [(O.xfy "," 1000), (O.xfx "=" 700)]
diff --git a/app/Code.hs b/app/Code.hs
index 5721d17..df3401e 100644
--- a/app/Code.hs
+++ b/app/Code.hs
@@ -9,9 +9,9 @@ import System.Console.Haskeline
 data Datum
   = Atom Int -- unifies a constant
   | Struct Id -- unifies a structure with arity
-  | VoidRef (Maybe Int) -- unifies with anything (references may refer to variable names)
-  | LocalRef Int (Maybe Int) -- code-local variable idx (should not occur on heap)
-  | HeapRef Int (Maybe Int) -- heap structure idx
+  | VoidRef -- unifies with anything
+  | LocalRef Int Int -- code-local variable idx (should never occur on heap)
+  | HeapRef Int -- something further on the heap
   deriving (Show, Eq, Ord)
 
 data Instr
@@ -34,7 +34,7 @@ data Heap =
 
 emptyHeap = Heap 0 M.empty
 
-type Scope = M.Map Int Int
+type Scope = M.Map Int (Int, Int)
 
 emptyScope :: Scope
 emptyScope = M.empty
diff --git a/app/Compiler.hs b/app/Compiler.hs
index e9bd7f4..1adefc3 100644
--- a/app/Compiler.hs
+++ b/app/Compiler.hs
@@ -32,7 +32,7 @@ variablizePrlg :: Int -> [Int] -> PrlgInt -> PrlgInt
 variablizePrlg void vs (CallI id ps) =
   CallI id $ map (variablizePrlg void vs) ps
 variablizePrlg void vs (LiteralI i)
-  | i == void = VoidI i
+  | i == void = VoidI
   | Just idx <- elemIndex i vs = VarI idx i
   | otherwise = LiteralI i
 
@@ -50,8 +50,8 @@ compileGoal x = compileArg x
 compileArg :: PrlgInt -> Code
 compileArg (CallI x args) = U (Struct x) : concatMap compileArg args
 compileArg (LiteralI x) = [U (Atom x)]
-compileArg (VarI x i) = [U (LocalRef x $ Just i)]
-compileArg (VoidI i) = [U (VoidRef $ Just i)]
+compileArg (VarI x i) = [U (LocalRef x i)]
+compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
 seqGoals [] = [NoGoal]
diff --git a/app/IR.hs b/app/IR.hs
index e1aa9ba..50c7493 100644
--- a/app/IR.hs
+++ b/app/IR.hs
@@ -18,7 +18,7 @@ data PrlgInt
   = CallI Id [PrlgInt]
   | LiteralI Int
   | VarI Int Int
-  | VoidI Int
+  | VoidI
   deriving (Show)
 
 data StrTable =
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index 3d1c569..ada3cf0 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -69,7 +69,6 @@ proveStep = St.get >>= go
                                , gol = U g:gs
                                , heap = heap@(Heap _ hmap)
                                }} = unify h g
-        {- termination tools -}
       where
         uok = c i {cur = cur {hed = hs, gol = gs}}
         setHeap r x =
@@ -77,7 +76,7 @@ proveStep = St.get >>= go
         {- heap tools -}
         deref x =
           case hmap M.!? x of
-            Just (HeapRef x' _) ->
+            Just (HeapRef x') ->
               if x == x'
                 then FreeRef x'
                 else deref x'
@@ -88,71 +87,56 @@ proveStep = St.get >>= go
         newHeapVars n (Heap nxt m) =
           let addrs = [nxt + i - 1 | i <- [1 .. n]]
            in ( Heap (nxt + n) $
-                foldr (uncurry M.insert) m [(a, HeapRef a Nothing) | a <- addrs]
+                foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
               , addrs)
-        allocLocal reg scope cont
-          | Just addr <- scope M.!? reg = cont scope heap addr
+        allocLocal (LocalRef reg ident) scope cont
+          | Just (addr, _) <- scope M.!? reg = cont scope heap addr
           | (heap', addr) <- newHeapVar heap =
-            cont (M.insert reg addr scope) heap' addr
+            cont (M.insert reg (addr, ident) scope) heap' addr
         newHeapStruct addr s@(Struct Id {arity = arity}) cont =
           let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
               m'' =
-                M.insert addr (HeapRef (head addrs) Nothing) .
-                M.insert (head addrs) s $
+                M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $
                 m'
-           in cont [HeapRef a Nothing | a <- tail addrs] (Heap nxt' m'')
+           in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
         {- simple cases first -}
-        unify (VoidRef _) (VoidRef _) = uok
+        unify VoidRef VoidRef = uok
         unify (Atom a) (Atom b)
           | a == b = uok
-        unify (VoidRef _) (Atom _) = uok
-        unify (Atom _) (VoidRef _) = uok
+        unify VoidRef (Atom _) = uok
+        unify (Atom _) VoidRef = uok
         unify (Struct a) (Struct b)
           | a == b = uok
         {- unifying a struct with void must cause us to skip the void -}
-        unify (VoidRef _) (Struct Id {arity = a}) =
-          c
-            i
-              { cur =
-                  cur {hed = replicate a (U $ VoidRef Nothing) ++ hs, gol = gs}
-              }
-        unify (Struct Id {arity = a}) (VoidRef _) =
-          c
-            i
-              { cur =
-                  cur {hed = hs, gol = replicate a (U $ VoidRef Nothing) ++ gs}
-              }
+        unify VoidRef (Struct Id {arity = a}) =
+          c i {cur = cur {hed = replicate a (U VoidRef) ++ hs, gol = gs}}
+        unify (Struct Id {arity = a}) VoidRef =
+          c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ gs}}
         {- handle local refs; first ignore their combination with voids to save memory -}
-        unify (LocalRef _ _) (VoidRef _) = uok
-        unify (VoidRef _) (LocalRef _ _) = uok
+        unify (LocalRef _ _) VoidRef = uok
+        unify VoidRef (LocalRef _ _) = uok
         {- allocate heap for LocalRefs and retry with HeapRefs -}
-        unify (LocalRef hv ident) _ =
-          allocLocal hv (hvar cur) $ \hvar' heap' addr ->
+        unify lr@(LocalRef _ _) _ =
+          allocLocal lr (hvar cur) $ \hvar' heap' addr ->
             c
               i
                 { cur =
                     cur
-                      { hed = U (HeapRef addr ident) : hs
-                      , hvar = hvar'
-                      , heap = heap'
-                      }
+                      {hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'}
                 }
-        unify _ (LocalRef gv ident) =
-          allocLocal gv (gvar cur) $ \gvar' heap' addr ->
+        unify _ lr@(LocalRef _ _) =
+          allocLocal lr (gvar cur) $ \gvar' heap' addr ->
             c
               i
                 { cur =
                     cur
-                      { gol = U (HeapRef addr ident) : gs
-                      , gvar = gvar'
-                      , heap = heap'
-                      }
+                      {gol = U (HeapRef addr) : gs, gvar = gvar', heap = heap'}
                 }
         {- handle heap refs; first ignore their combination with voids again -}
-        unify (HeapRef _ _) (VoidRef _) = uok
-        unify (VoidRef _) (HeapRef _ _) = uok
+        unify (HeapRef _) VoidRef = uok
+        unify VoidRef (HeapRef _) = uok
         {- actual HeapRefs, these are dereferenced and then unified (sometimes with copying) -}
-        unify (HeapRef hr' hident) g =
+        unify (HeapRef hr') g =
           case deref hr' of
             FreeRef hr ->
               case g of
@@ -168,10 +152,10 @@ proveStep = St.get >>= go
                                cur
                                  {hed = map U nhs ++ hs, gol = gs, heap = nheap}
                            })
-                HeapRef gr' _ ->
+                HeapRef gr' ->
                   case deref gr' of
-                    FreeRef gr -> setHeap hr (HeapRef gr hident)
-                    BoundRef addr _ -> setHeap hr (HeapRef addr hident)
+                    FreeRef gr -> setHeap hr (HeapRef gr)
+                    BoundRef addr _ -> setHeap hr (HeapRef addr)
                     _ -> ifail "dangling goal ref (from head ref)"
             BoundRef _ atom@(Atom a) -> unify atom g
             BoundRef addr struct@(Struct Id {arity = arity}) ->
@@ -181,13 +165,12 @@ proveStep = St.get >>= go
                       cur
                         { hed =
                             U struct :
-                            [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++
-                            hs
+                            [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ hs
                         , gol = U g : gs
                         }
                   }
             _ -> ifail "dangling head ref"
-        unify h (HeapRef gr' gident) =
+        unify h (HeapRef gr') =
           case deref gr' of
             FreeRef gr ->
               case h of
@@ -212,8 +195,7 @@ proveStep = St.get >>= go
                         { hed = U h : hs
                         , gol =
                             U struct :
-                            [U (HeapRef (addr + i) Nothing) | i <- [1 .. arity]] ++
-                            gs
+                            [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ gs
                         }
                   }
             _ -> ifail "dangling goal ref"