diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 955ae80..ed8c402 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -36,6 +36,7 @@ module Gyehoek.CPS.Syntax , Abs(..) , Free(..) , pattern ValLabel + , pattern ObjLabel , labelName -- don't like that this is part of the api ) where @@ -77,6 +78,8 @@ data Obj deriving stock (Show, Generic, Data, Eq) deriving anyclass (NFData) +pattern ObjLabel l = ObjImm (ImmLabel l) + -- | a heap object. data Hob = HobClosure { label :: Name, env :: List Obj } diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 25e85f8..e62816c 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -16,6 +16,7 @@ module Gyehoek.Stack.Syntax , Prim(..) , Name , pattern ValLabel + , pattern ObjLabel , stkP ) where @@ -24,7 +25,7 @@ import qualified Gyehoek.Sexp as S import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..)) import GHC.Exts (IsList(..)) import Data.List (intersperse) -import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName) +import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName, pattern ObjLabel) import Gyehoek.Prelude import Gyehoek.Sexp ((:-)((:-))) @@ -62,14 +63,16 @@ data Tail -- arguments on top of the stack, then return by calling the -- continuation at stack index `n+1`. = TailCall Int + | Call Int | If Val Block Block - | Return + | Return Int deriving stock (Show, Generic, Data) deriving anyclass (NFData) data Instr = Pop Name | Push Val + | Load Name | Prim Name (Prim Val) deriving stock (Show, Generic, Data) deriving anyclass (NFData) @@ -92,6 +95,7 @@ instance S.DatumIso Instr where datumIso = S.match $ S.With (S.headTagged1 "pop!" regName >>>) $ S.With (S.headTagged1 "push!" S.datumIso >>>) + $ S.With (S.headTagged1 "load!" regName >>>) $ S.With (S.headTagged2 "prim" regName S.datumIso >>>) $ S.End where @@ -107,8 +111,9 @@ instance S.DataIso Block where instance S.DatumIso Tail where datumIso = S.match $ S.With (S.headTagged1 "tail-call" S.datumIso >>>) + $ S.With (S.headTagged1 "call" S.datumIso >>>) $ S.With (if_ >>>) - $ S.With (S.headTagged0 "return" >>>) + $ S.With (S.headTagged1 "return" S.datumIso >>>) $ S.End where -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index f09871c..c30db67 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -30,24 +30,23 @@ import Control.DeepSeq (deepseq, ($!!)) import Data.String (fromString) --- | inessential information maintained only to aide in debugging. +-- | non-essential information maintained only to aide in debugging. data DebugVM = MkDebugVM { currentRoutine :: Name } deriving (Show, Generic) -data Frame = MkFrame - { returnAddress :: Name - , procedure :: Name - , locals :: List Obj - } +newtype Frame = MkFrame { locals :: List Obj } deriving (Show, Generic) -newtype Stack = MkStack (NonEmpty Frame) +returnAddress :: Traversal' Frame Name +returnAddress = #locals . _last . #ObjImm . #ImmLabel + +newtype Stack = MkStack { frames :: NonEmpty Frame } deriving (Show, Generic) data VM = MkVM - { frames :: NonEmpty Frame + { stack :: Stack , code :: List Instr , tail :: Tail , registers :: HashMap Name Obj @@ -57,13 +56,23 @@ data VM = MkVM } deriving (Show, Generic) +instance Cons Frame Frame Obj Obj where + _Cons = prism' + (\(x,MkFrame xs) -> MkFrame (x:xs)) + \case + MkFrame (x:xs) -> Just (x, MkFrame xs) + MkFrame [] -> Nothing + _NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b) _NonEmpty = iso (\(x:|xs) -> (x,xs)) (\(x,xs) -> x:|xs) -stack :: Lens' VM (List Obj) -stack = #frames . _NonEmpty . _1 . #locals +pushFrame :: Frame -> Stack -> Stack +pushFrame f (MkStack xs) = MkStack $ NE.cons f xs + +activeFrame :: Lens' VM Frame +activeFrame = #stack . #frames . _NonEmpty . _1 data Env = MkEnv { labels :: HashMap Name Routine @@ -80,8 +89,8 @@ vmerror = throwError . VMError stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM -stepI e vm (Push v) = traverseOf stack push vm - where push xs = (:) <$> evalVal e vm v <*> pure xs +stepI e vm (Push v) = traverseOf activeFrame push vm + where push xs = cons <$> evalVal e vm v <*> pure xs stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case PrimZeroP x -> case x of @@ -117,52 +126,59 @@ stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case ret $ ObjImm (ImmInt (op x y)) arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|] -stepI e vm (Pop r) = case vm ^. stack of - [] -> vmerror "empty stack" - (x:xs) -> pure $ vm & #registers . at r ?~ x - & stack .~ xs +stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of + Nothing -> vmerror "empty stack" + Just (x,xs) -> pure $ vm & #registers . at r ?~ x + & activeFrame .~ xs stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|] stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM -stepT g vm Return = vmerror "aajak" +stepT g vm (Return nret) = + case splitAtExact nret (vm ^. activeFrame . #locals) of + Nothing -> _ + Just (_,_) -> _ stepT g vm tc@(TailCall nargs) = - case setupCall nargs (vm ^. stack) of + case parseTailCall nargs (vm ^. activeFrame) of Nothing -> vmerror [i|bad stack at #{tc}|] - Just (xs,f,rest) -> - case f of - "halt" -> pure $ vm & #result ?~ xs - l -> do - rt <- case g ^. #labels . at l of - Nothing -> vmerror [i|undefined label: #{l}|] - Just x -> pure x - let newFrame = MkFrame - { returnAddress = - vm ^. #frames . _NonEmpty . _1 . #returnAddress - , procedure = f - , locals = xs - } - pure $ vm - & #code .~ rt.start.code - & #tail .~ rt.start.tail - & stack .~ rest - & #frames %~ NE.cons newFrame - -- it is not essential we clear the registers, but it'll - -- make bugs more obvious. - & #registers .~ mempty - & #debug . #currentRoutine .~ rt.label - -- evalToLabel g vm f >>= \case - -- "halt" -> pure $ vm & #result ?~ xs' - -- l -> do - -- rt <- case g ^. #labels . at l of - -- Nothing -> vmerror [i|undefined label: #{l}|] - -- Just x -> pure x - -- pure $ vm & #code .~ rt.start.code - -- & #tail .~ rt.start.tail - -- & #registers .~ H.fromList (rt.params `zip` xs') - -- & #debug . #currentRoutine .~ rt.label + Just (args,"halt",_) -> pure $ vm & #result ?~ args + Just (args,f,ra) -> do + rt <- case g ^. #labels . at f of + Nothing -> vmerror [i|undefined label #{f}|] + Just x -> pure x + let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel ra] + pure $ vm + & #code .~ rt.start.code + & #tail .~ rt.start.tail + -- replace the active frame; don't push a new one. + & activeFrame .~ newFrame + -- it is not essential we clear the registers, but it'll + -- make bugs more obvious. + & #registers .~ mempty + +-- stepT g vm tc@(TailCall nargs) = +-- case setupCall nargs (vm ^. stack) of +-- Nothing -> vmerror [i|bad stack at #{tc}|] +-- Just (xs,f,rest) -> +-- case f of +-- "halt" -> pure $ vm & #result ?~ xs +-- l -> do +-- rt <- case g ^. #labels . at l of +-- Nothing -> vmerror [i|undefined label: #{l}|] +-- Just x -> pure x +-- let ra = vm ^. #activeFrame . #returnAddress +-- let newFrame = MkFrame $ xs ++ [ObjLabel f, ra] +-- pure $ vm +-- & #code .~ rt.start.code +-- & #tail .~ rt.start.tail +-- & stack .~ rest +-- & #frames %~ NE.cons newFrame +-- -- it is not essential we clear the registers, but it'll +-- -- make bugs more obvious. +-- & #registers .~ mempty +-- & #debug . #currentRoutine .~ rt.label stepT g vm (If c t f) = do branch <- evalVal g vm c <&> \case @@ -188,32 +204,25 @@ splitAtExact n xs = case compareLength xs n of (EQ;GT) -> Just $ splitAt n xs LT -> Nothing -setupCall :: Int -> List Obj -> Maybe (List Obj, Name, Name, List Obj) -setupCall n stk = do - (xs,stk') <- splitAtExact (n+2) stk - case splitAtExact n xs of - Just (args, [p,ret]) -> case (p,ret) of - (ObjImm (ImmLabel p'),ObjImm (ImmLabel ret')) -> Just (args,p',ret',stk') - _ -> Nothing - _ -> error "unreachable" +takeExact :: Int -> List a -> Maybe (List a) +takeExact n xs = case compareLength xs n of + (EQ;GT) -> Just $ take n xs + LT -> Nothing -setupTailCall :: Int -> List Obj -> Maybe (List Obj, Name, List Obj) -setupTailCall n stk = do - (xs,stk') <- splitAtExact (n+1) stk - case xs ^? _Snoc of - Just (args, [p,ret]) -> case (p,ret) of - (ObjImm (ImmLabel p'),ObjImm (ImmLabel ret')) -> Just (args,p',stk') - _ -> Nothing - _ -> error "unreachable" +parseTailCall :: Int -> Frame -> Maybe (List Obj, Name, Name) +parseTailCall nargs frm = do + (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals) + let (xs',f) = xs ^?! _Snoc + f' <- f ^? #ObjImm . #ImmLabel + pure (xs',f',frm ^?! returnAddress) initialVM :: VM initialVM = MkVM - { frames = NE.singleton $ MkFrame - { returnAddress = "halt" - , procedure = "" - , locals = [ ObjImm (ImmLabel "start") - ] - } + { stack = MkStack . NE.singleton . MkFrame $ + [ ObjLabel "start" + , ObjLabel "" + , ObjLabel "halt" + ] , tail = TailCall 0 , code = [] , registers = mempty @@ -359,7 +368,7 @@ ppVM vm = do td_ do code_ curi td_ do - let xs = code_ . ppDatum <$> (vm ^. stack) + let xs = _ sequence_ $ intersperse " | " xs where curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum) @@ -369,5 +378,5 @@ ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso blah = [stkP| (define $start - (return)) + (return 0)) |] diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index 1277f67..205f047 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -16,13 +16,13 @@ test_root = testGroup "stack machine" [ testCase "immediate halt" do evalsTo [ObjImm (ImmInt 3)] [stkP| (define $start - (tail-call 0)) + (return 0)) |] , testCase "lit int" do evalsTo [ObjImm (ImmInt 3)] [stkP| (define $start (push! 3) - (tail-call 1)) + (return 1)) |] -- , testCase "return constant" do -- evalsTo [ObjImm (ImmInt 123)] [stkP|