ragh!

src/Core.hs

@@ -121,6 +121,6 @@ corePrelude = Program
     , ScDef "K1" ["x", "y"] (Var "y")
     , ScDef "S" ["f", "g", "x"] (Var "f" :$ Var "x" :$ (Var "g" :$ Var "x"))
     , ScDef "compose" ["f", "g", "x"] (Var "f" :$ (Var "g" :$ Var "x"))
-    , ScDef "twice" ["f", "g", "x"] (Var "f" :$ (Var "g" :$ Var "x"))
+    , ScDef "twice" ["f", "x"] (Var "f" :$ (Var "f" :$ Var "x"))
     ]
 

src/Data/Heap.hs

@@ -5,6 +5,7 @@ module Data.Heap
     , update
     , free
     , hLookup
+    , hLookupUnsafe
     , addresses
     , hSize
     )
@@ -55,6 +56,11 @@ free (Heap u m) k = Heap (k:u) (M.delete k m)
 hLookup :: Addr -> Heap a -> Maybe a
 hLookup k (Heap _ m) = m !? k
 
+hLookupUnsafe :: Addr -> Heap a -> a
+hLookupUnsafe k (Heap _ m) = case m !? k of
+    Just a  -> a
+    Nothing -> error "erm... segfault much?"
+
 addresses :: Heap a -> [Addr]
 addresses (Heap _ m) = M.keys m
 

src/Data/Pretty.hs

@@ -4,6 +4,7 @@ module Data.Pretty
     , ISeq(..)
     , precPretty
     , prettyPrint
+    , prettyShow
     , iBracket
     , withPrec
     , bracketPrec
@@ -27,6 +28,9 @@ precPretty = flip prettyPrec
 prettyPrint :: (Pretty a) => a -> IO ()
 prettyPrint = putStr . squash . pretty
 
+prettyShow :: (Pretty a) => a -> String
+prettyShow = squash . pretty
+
 data ISeq where
     INil :: ISeq
     IStr :: String -> ISeq

src/TI.hs

@@ -12,6 +12,7 @@ import Data.List                (mapAccumL)
 import Control.Monad            (guard)
 import Data.Foldable            (traverse_)
 import Data.Function            ((&))
+import System.IO                (Handle, hPutStr)
 import Data.Pretty
 import Data.Heap
 import Control.DFA
@@ -26,6 +27,7 @@ type TiHeap = Heap Node
 data Node = NAp Addr Addr
           | NSupercomb Name [Name] Expr
           | NNum Int
+          | NInd Addr
           deriving Show
 
 data Dump = DumpTempDummy
@@ -49,7 +51,7 @@ compile prog = Just $ TiState s d h g stats
         s = [mainAddr]
         d = DumpTempDummy
         (h,g) = buildInitialHeap defs
-        defs = prog <> corePrelude
+        defs = prog -- <> corePrelude
         stats = 0
 
         mainAddr = fromJust $ lookup "main" g
@@ -62,13 +64,6 @@ buildInitialHeap (Program scdefs) = mapAccumL allocateSc mempty scdefs
             where
                 (h', addr) = alloc h (NSupercomb n a b)
 
-getArgs :: TiHeap -> [Addr] -> [Addr]
-getArgs h (sc:s) = fmap f s
-    where
-        f addr = case hLookup addr h of
-            Just (NAp _ arg) -> arg
-            _                -> error "glados yuri"
-
 instantiate :: Expr -> TiHeap -> [(Name, Addr)] -> (TiHeap, Addr)
 instantiate (App f x)    h g = alloc h'' (NAp f' x')
     where
@@ -118,7 +113,8 @@ step st =
     in case fromMaybe (error "segfault!") (hLookup top h) of
         NNum n            -> numStep n      st
         NAp f x           -> apStep  f x    st
-        NSupercomb n as b -> ncStep  n as b st
+        NSupercomb n as b -> scStep  n as b st
+        NInd a            -> indStep a      st
 
     where
         numStep :: Int -> TiState -> TiState
@@ -128,14 +124,28 @@ step st =
         apStep f _ (TiState s d h g sts) =
             TiState (f:s) d h g sts
 
-        ncStep :: Name -> [Name] -> Expr -> TiState -> TiState
+        scStep :: Name -> [Name] -> Expr -> TiState -> TiState
-        ncStep n as b (TiState s d h g sts) =
+        scStep n as b (TiState s d h g sts) =
-            TiState s' d h' g sts
+            TiState s' d h'' g sts
             where
+                h'' = update h' (s !! length as) (NInd resAddr)
                 s' = resAddr : drop (length as + 1) s
                 (h', resAddr) = instantiate b h env
                 env = argBinds ++ g
-                argBinds = as `zip` getArgs h s
+                argBinds = as `zip` argAddrs
+                argAddrs = getArgs h s
+
+        -- dereference indirections
+        indStep :: Addr -> TiState -> TiState
+        indStep a (TiState s d h g sts) =
+            TiState (a:s) d h g sts
+
+getArgs :: TiHeap -> [Addr] -> [Addr]
+getArgs h (sc:s) = fmap f s
+    where
+        f addr = case hLookup addr h of
+            Just (NAp _ arg) -> arg
+            _                -> error "glados yuri"
 
 isFinal :: TiState -> Bool
 isFinal (TiState [addr] _ h _ _) =
@@ -155,9 +165,11 @@ doAdmin (TiState s d h g sts) = TiState s d h g (sts+1)
 dbgProg :: Program -> IO ()
 dbgProg p = prettyPrint `traverse_` eval (fromJust $ compile p)
 
+hdbgProg :: Program -> Handle -> IO ()
+hdbgProg p h = (hPutStr h . prettyShow) `traverse_` eval (fromJust $ compile p)
+
 letrecExample :: Program
 letrecExample = Program
-    -- [ ScDef "main" [] $ Prim IntAddP :$ Prim (IntP 2) :$ Prim (IntP 3)
     [ ScDef "pair" ["x","y","f"] $ "f" :$ "x" :$ "y"
     , ScDef "fst" ["p"] $ "p" :$ "K"
     , ScDef "snd" ["p"] $ "p" :$ "K1"
@@ -170,13 +182,63 @@ letrecExample = Program
     , ScDef "main" [] $ "f" :$ Prim (IntP 3) :$ Prim (IntP 4)
     ]
 
+indExample1 :: Program
+indExample1 = Program
+    [ ScDef "main" [] $ "twice" :$ "twice" :$ "id" :$ Prim (IntP 3)
+    ]
+
+indExample2 :: Program
+indExample2 = Program
+    [ ScDef "main" [] $
+        Let Rec
+            [ "x" := Prim (IntP 2)
+            , "y" := "f" :$ "x" :$ "x"
+            ]
+            ("g" :$ "y" :$ "y")
+    , ScDef "f" ["a","b"] $ "b"
+    , ScDef "g" ["a","b"] $ "a"
+    ]
+
 instance Pretty TiState where
     prettyPrec (TiState s d h g sts) _ =
         "==== TiState Stack ====" <> IBreak
         <> mconcat (fmap ((<>IBreak) . showAddr) s)
+        <> "==== TiState Heap ====" <> IBreak
+        <> sheap
         where
-            showAddr a = IStr (show a) <> ": " <> precPretty 0 (hLookup a h)
+            showAddr a = IStr (show a) <> ": " <> pnode (hLookupUnsafe a h) 0
+            sheap = mconcat $ ((<>IBreak) . showAddr) <$> addresses h
 
-instance Pretty Node where
+            pnode :: Node -> Int -> ISeq
-    prettyPrec a _ = IStr $ show a
+            pnode (NAp f x) p = bracketPrec 0 p $
+                f' <> " " <> pnode (hLookupUnsafe x h) (succ p)
+                where
+                    f' = case hLookupUnsafe f h of
+                        x@(NAp _ _) -> pnode x       0
+                        x           -> pnode x (succ p) 
+
+            pnode (NInd a) p = bracketPrec 0 p $
+                "NInd -> " <> pnode (hLookupUnsafe a h) 0
+
+            pnode (NNum n) _ =
+                IStr (show n) <> IStr "#"
+
+            pnode (NSupercomb n _ _) _ = IStr n
+
+            pnodeRef :: Addr -> Int -> ISeq
+            pnodeRef a p = IStr (show a) <> "@" <> pnode (hLookupUnsafe a h) p
+
+            -- pnoderef :: Addr -> Int -> ISeq
+            -- pnoderef a p = bracketPrec 0 p $
+            --     IStr (show a) <> " -> " <> pnode (hLookupUnsafe a h) 0
+
+            -- pnode :: Node -> Int -> ISeq
+            -- pnode (NAp f x) p = bracketPrec 0 p $
+            --     "NAp " <> pnoderef f (succ p) <> pnoderef x (succ p)
+            -- pnode (NSupercomb n _ _) p = bracketPrec 0 p $
+            --     "NSupercomb " <> IStr n
+            -- pnode (NNum n) p = bracketPrec 0 p $
+            --     "NNum " <> IStr (show n)
+            -- pnode (NInd a) p = bracketPrec 0 p $
+            --     "NInd " <> pnoderef a p