From 32f6fe0291e289c88d29710e42da3e6aca47a3fa Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Sat, 26 Nov 2022 20:15:09 +0100
Subject: [PATCH] fix minor stuff

---
 app/Builtins.hs |  3 +--
 app/Compiler.hs | 24 ++++++++++++++----------
 2 files changed, 15 insertions(+), 12 deletions(-)

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 64838bb..555623c 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -110,8 +110,7 @@ retractall = do
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
 
-addClause struct code = do
-  lift . outputStrLn $ "Adding " ++ show struct ++ " with code " ++ show code
+addClause struct code =
   modify $ \s ->
     s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s}
 
diff --git a/app/Compiler.hs b/app/Compiler.hs
index efa641c..67ca20f 100644
--- a/app/Compiler.hs
+++ b/app/Compiler.hs
@@ -1,7 +1,6 @@
 module Compiler where
 
 import Data.Char (isUpper)
-import Data.Containers.ListUtils (nubOrd)
 import qualified Data.Map as M
 
 import Code (Code, Datum(..), Heap, Instr(..), heapStruct)
@@ -12,10 +11,10 @@ varname ('_':_) = True
 varname (c:_) = isUpper c
 varname _ = False
 
-varIds :: PrlgInt -> [Int]
-varIds (CallI _ xs) = nubOrd $ concatMap varIds xs
-varIds (VarI idx _) = [idx]
-varIds _ = []
+varOccurs :: PrlgInt -> M.Map Int Int
+varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
+varOccurs (VarI idx _) = M.singleton idx 1
+varOccurs _ = M.empty
 
 variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
 variablizePrlg void (StrTable _ _ itos) = go
@@ -26,16 +25,22 @@ variablizePrlg void (StrTable _ _ itos) = go
       | varname (itos M.! i) = VarI i i
       | otherwise = LiteralI i
 
-renumVars :: [(Int, Int)] -> PrlgInt -> PrlgInt
+renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
 renumVars rename = go
   where
     go (CallI id ps) = CallI id $ map go ps
     go (VarI idx i)
-      | Just idx' <- lookup idx rename = VarI idx' i
+      | Just new <- rename idx = new
     go x = x
 
 squashVars :: PrlgInt -> PrlgInt
-squashVars x = renumVars (zip (varIds x) [1 ..]) x
+squashVars x =
+  let occurs = M.assocs (varOccurs x)
+      m' =
+        M.fromList $
+        [(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
+        [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
+   in renumVars (m' M.!?) x
 
 compileGoals :: Id -> Int -> PrlgInt -> [Code]
 compileGoals andop cut = go'
@@ -65,8 +70,7 @@ seqGoals ([Cut]:xs) = [Cut] ++ seqGoals xs
 seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
 
 heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
-heapStructPrlgInt heaperr heap ref =
-  squashVars <$> heapStruct atom struct hrec heap ref
+heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
   where
     atom (Atom s) = pure $ LiteralI s
     atom VoidRef = pure $ VoidI