diff --git a/src/Core.hs b/src/Core.hs index d78f941..34e6a81 100644 --- a/src/Core.hs +++ b/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")) ] diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 2508244..4d920b9 100644 --- a/src/Data/Heap.hs +++ b/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 diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index e022c32..3f30e11 100644 --- a/src/Data/Pretty.hs +++ b/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 diff --git a/src/TI.hs b/src/TI.hs index 319a301..9900da5 100644 --- a/src/TI.hs +++ b/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 - ncStep n as b (TiState s d h g sts) = - TiState s' d h' g sts + scStep :: Name -> [Name] -> Expr -> TiState -> TiState + scStep n as b (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 - prettyPrec a _ = IStr $ show a + pnode :: Node -> Int -> ISeq + 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