diff --git a/src/Core.hs b/src/Core.hs index 34e6a81..e77bedf 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -19,7 +19,8 @@ data Expr = Var Name data Prim = IntP Int | IntAddP - deriving Show + | IntNegP + deriving (Show, Eq) infixl 2 :$ pattern (:$) :: Expr -> Expr -> Expr diff --git a/src/TI.hs b/src/TI.hs index 38c4a90..a39088a 100644 --- a/src/TI.hs +++ b/src/TI.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase, BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module TI where ---------------------------------------------------------------------------------- @@ -26,12 +27,12 @@ type TiHeap = Heap Node data Node = NAp Addr Addr | NSupercomb Name [Name] Expr + | NPrim Name Prim | NNum Int | NInd Addr deriving Show -data Dump = DumpTempDummy - deriving Show +type Dump = [[Addr]] type Stats = Int @@ -49,29 +50,46 @@ compile :: Program -> Maybe TiState compile prog = Just $ TiState s d h g stats where s = [mainAddr] - d = DumpTempDummy + d = [] (h,g) = buildInitialHeap defs - defs = prog -- <> corePrelude + defs = prog <> corePrelude stats = 0 mainAddr = fromJust $ lookup "main" g buildInitialHeap :: Program -> (TiHeap, [(Name, Addr)]) -buildInitialHeap (Program scdefs) = mapAccumL allocateSc mempty scdefs +buildInitialHeap (Program scDefs) = (h'', scAddrs ++ primAddrs) where + h = mempty + + (h', scAddrs) = mapAccumL allocateSc h scDefs + (h'', primAddrs) = mapAccumL allocatePrim h' primitives + allocateSc :: TiHeap -> ScDef -> (TiHeap, (Name, Addr)) allocateSc h (ScDef n a b) = (h', (n, addr)) where (h', addr) = alloc h (NSupercomb n a b) + allocatePrim :: TiHeap -> (Name, Prim) -> (TiHeap, (Name, Addr)) + allocatePrim h (n, p) = (h', (n, addr)) + where (h', addr) = alloc h (NPrim n p) + +primitives :: [(Name, Prim)] +primitives = + [ ("negate#", IntNegP) + , ("+#", IntAddP) + ] + instantiate :: Expr -> TiHeap -> [(Name, Addr)] -> (TiHeap, Addr) instantiate (App f x) h g = alloc h'' (NAp f' x') where (h', f') = instantiate f h g (h'', x') = instantiate x h' g + instantiate (Var k) h g = (h, fromMaybe (error $ "variable `" <> k <> "' not in scope") v) where v = lookup k g + instantiate (Case _ _) _ _ = error "cannot instantiate case expressions" instantiate (Let NonRec bs e) h g = instantiate e h' (g' ++ g) @@ -95,9 +113,42 @@ instantiate (Let Rec bs e) h g = instantiate e h' env in (h',(k,a)) instantiate (Prim (IntP n)) h _ = alloc h (NNum n) +instantiate (Prim p) h _ = alloc h (NPrim n p) + where + n = fromMaybe + (error $ "primitive `" <> show p <> "' has no associated name") + $ lookupV p primitives + + lookupV v d = fmap (\ (a,b) -> (b,a)) d + & lookup v instantiate _ _ _ = error "unimplemented" +-- instantiate and update +instantiateU :: Expr -> Addr -> TiHeap -> [(Name, Addr)] -> TiHeap +instantiateU (App f x) root h g = update h'' root (NAp f' x') + where + (h',f') = instantiate f h g + (h'',x') = instantiate x h' g + +instantiateU (Case _ _) _ _ _ = error "cannot instantiate case expressions" + +instantiateU (Var k) root h g = update h' root (NInd a) + where (h',a) = instantiate (Var k) h g + +-- i don't really know if this is correct tbh i'm gonna cry +instantiateU (Let NonRec bs e) root h g = h'' + where + h'' = instantiateU e root h' (g' ++ g) + (h', g') = mapAccumL instBinder h bs + + instBinder :: TiHeap -> Binding -> (TiHeap, (Name, Addr)) + instBinder h (k := v) = + let (h',a) = instantiate v h g + in (h',(k,a)) + +instantiateU (Prim (IntP n)) root h _ = update h root (NNum n) + ---------------------------------------------------------------------------------- eval :: TiState -> [TiState] @@ -111,10 +162,11 @@ step :: TiState -> TiState step st = let TiState (top:_) _ h _ _ = 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 -> scStep n as b st - NInd a -> indStep a st + NNum n -> numStep n st + NAp f x -> apStep f x st + NSupercomb n as b -> scStep n as b st + NInd a -> indStep a st + NPrim n p -> primStep n p st where numStep :: Int -> TiState -> TiState @@ -140,12 +192,24 @@ step st = indStep a (TiState s d h g sts) = TiState (a:s) d h g sts + primStep :: Name -> Prim -> TiState -> TiState + primStep n IntNegP (TiState (neg:s) d h g sts) = + case s of + [view -> NAp _ (view -> NNum b)] -> + TiState s' d h' g sts + where + h' = update h a1 (NNum (-b)) + s' = [a1] + a1 = head s + + where view = flip hLookupUnsafe h + getArgs :: TiHeap -> [Addr] -> [Addr] -getArgs h (sc:s) = fmap f s +getArgs h (_:s) = fmap f s where - f addr = case hLookup addr h of - Just (NAp _ arg) -> arg - _ -> error "glados yuri" + f addr = case hLookupUnsafe addr h of + NAp _ arg -> arg + _ -> error "glados yuri" isFinal :: TiState -> Bool isFinal (TiState [addr] _ h _ _) = @@ -162,8 +226,15 @@ isDataNode _ = False doAdmin :: TiState -> TiState 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) +dbgProg :: Program -> IO Node +dbgProg p = do + prettyPrint `traverse` p' + let TiState [a] _ h _ _ = last p' + pure res + where + p' = eval (fromJust $ compile p) + TiState [resAddr] _ h _ _ = last p' + res = hLookupUnsafe resAddr h hdbgProg :: Program -> Handle -> IO () hdbgProg p h = (hPutStr h . prettyShow) `traverse_` eval (fromJust $ compile p) @@ -189,6 +260,11 @@ indExample1 = Program indExample2 :: Program indExample2 = Program + [ ScDef "main" [] $ "twice" :$ "twice" :$ "twice" :$ "id" :$ Prim (IntP 3) + ] + +indExample3 :: Program +indExample3 = Program [ ScDef "main" [] $ Let Rec [ "x" := Prim (IntP 2) @@ -199,6 +275,18 @@ indExample2 = Program , ScDef "g" ["a","b"] $ "a" ] +negExample :: Program +negExample = Program + [ ScDef "main" [] $ + Prim IntNegP :$ Prim (IntP 3) + ] + +t :: Program +t = Program + [ ScDef "f" ["x"] $ "+" :$ ("id" :$ "x") :$ "x" + , ScDef "main" [] $ "f" :$ ("id" :$ Prim (IntP 4)) + ] + instance Pretty TiState where prettyPrec (TiState s d h g sts) _ = "==== TiState Stack ====" <> IBreak @@ -225,6 +313,8 @@ instance Pretty TiState where pnode (NSupercomb n _ _) _ = IStr n + pnode (NPrim n _) _ = IStr n + -- pnoderef :: Addr -> Int -> ISeq -- pnoderef a p = bracketPrec 0 p $ -- IStr (show a) <> " -> " <> pnode (hLookupUnsafe a h) 0