ragh!
This commit is contained in:
crumbtoo
@@ -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"))
|
||||
]
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
96
src/TI.hs
96
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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user