diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e5bdfbf..e7137e5 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -70,12 +70,12 @@ pattern ValLabel x = ValImm (ImmLabel x) newtype Label = MkLabel { inner :: Name } deriving stock (Generic, Data) deriving newtype (Show, Eq, Gen, IsString, Hashable) - deriving anyclass (NFData) + deriving anyclass (NFData, Wrapped) newtype Reg = MkReg { inner :: Name } deriving stock (Generic, Data) deriving newtype (Show, Eq, Gen, IsString, Hashable) - deriving anyclass (NFData) + deriving anyclass (NFData, Wrapped) data Imm = ImmInt Int @@ -95,7 +95,7 @@ pattern ObjLabel l = ObjImm (ImmLabel l) -- | a heap object. data Hob - = HobClosure { label :: Name, env :: List Obj } + = HobClosure { label :: Label, env :: List Obj } | HobPair Obj Obj deriving stock (Show, Generic, Data, Eq) deriving anyclass (NFData) @@ -213,7 +213,7 @@ instance S.DatumIso Hob where where conspair = S.dottedList (S.el S.datumIso) S.datumIso -- closures can be printed, but not parsed. - closure :: G (Datum :- t) (List Obj :- Name :- t) + closure :: G (Datum :- t) (List Obj :- Label :- t) closure = IG.Flip $ IG.PartialIso (\(env:-code:-t) -> S.Unreadable "#" :- t) (const . Left $ mempty) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 28badd9..f5cb75e 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -14,7 +14,9 @@ module Gyehoek.Stack.Syntax , Imm(..) , Hob(..) , Prim(..) - , Name + , Name(..) + , Reg(..) + , Label(..) , pattern ValLabel , pattern ObjLabel , stkP diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index c30db67..5814b5a 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -32,14 +32,14 @@ import Data.String (fromString) -- | non-essential information maintained only to aide in debugging. data DebugVM = MkDebugVM - { currentRoutine :: Name + { currentRoutine :: Label } deriving (Show, Generic) newtype Frame = MkFrame { locals :: List Obj } deriving (Show, Generic) -returnAddress :: Traversal' Frame Name +returnAddress :: Traversal' Frame Label returnAddress = #locals . _last . #ObjImm . #ImmLabel newtype Stack = MkStack { frames :: NonEmpty Frame } @@ -49,7 +49,7 @@ data VM = MkVM { stack :: Stack , code :: List Instr , tail :: Tail - , registers :: HashMap Name Obj + , registers :: HashMap Reg Obj , stdout :: Text , result :: Maybe (List Obj) , debug :: DebugVM @@ -63,6 +63,9 @@ instance Cons Frame Frame Obj Obj where MkFrame (x:xs) -> Just (x, MkFrame xs) MkFrame [] -> Nothing +pushes :: Foldable f => f Obj -> Frame -> Frame +pushes = flip $ foldr cons + _NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b) _NonEmpty = iso (\(x:|xs) -> (x,xs)) @@ -75,7 +78,7 @@ activeFrame :: Lens' VM Frame activeFrame = #stack . #frames . _NonEmpty . _1 data Env = MkEnv - { labels :: HashMap Name Routine + { labels :: HashMap Label Routine } deriving (Show, Generic) @@ -135,10 +138,35 @@ stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|] stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM -stepT g vm (Return nret) = +stepT g vm tc@(Call nargs) = + case parseCall nargs (vm ^. activeFrame) of + Nothing -> vmerror "bla" + Just (args,f,ret,frm) -> + case g ^. #labels . at ret of + Nothing -> vmerror [i|undefined label #{ret}|] + Just rt -> do + let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret] + pure $ vm + & #code .~ rt.start.code + & #tail .~ rt.start.tail + & activeFrame .~ frm + & #stack %~ pushFrame newFrame + & #registers .~ mempty + +stepT g vm tc@(Return nret) = case splitAtExact nret (vm ^. activeFrame . #locals) of - Nothing -> _ - Just (_,_) -> _ + Nothing -> vmerror [i|bad stack at #{tc}|] + Just (xs,_) -> + case vm ^? activeFrame . returnAddress of + Nothing -> vmerror [i|bad stack #{tc}|] + Just "halt" -> pure $ vm & #result ?~ xs + Just ra -> + case g ^. #labels . at ra of + Nothing -> vmerror [i|undefined label #{ra}|] + Just rt -> vm + & traverseOf (#stack . #frames) \st -> case NE.uncons st of + (_, Nothing) -> vmerror "explode" + (f, Just fs) -> pure $ fs & _NonEmpty . _1 %~ pushes xs stepT g vm tc@(TailCall nargs) = case parseTailCall nargs (vm ^. activeFrame) of @@ -186,7 +214,7 @@ stepT g vm (If c t f) = do _ -> t pure $ vm & #code .~ branch.code & #tail .~ branch.tail -evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Name +evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label evalToLabel e vm v = evalVal e vm v >>= \case ObjImm (ImmLabel x) -> pure x @@ -209,7 +237,15 @@ takeExact n xs = case compareLength xs n of (EQ;GT) -> Just $ take n xs LT -> Nothing -parseTailCall :: Int -> Frame -> Maybe (List Obj, Name, Name) +parseCall :: Int -> Frame -> Maybe (List Obj, Label, Label, Frame) +parseCall nargs frm = do + (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals) + let (xs',[f,ret]) = splitAt nargs xs + f' <- f ^? #ObjImm . #ImmLabel + ret' <- ret ^? #ObjImm . #ImmLabel + pure (xs',f',ret',MkFrame ys) + +parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label) parseTailCall nargs frm = do (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals) let (xs',f) = xs ^?! _Snoc @@ -362,7 +398,7 @@ ppVM vm = do details_ do summary_ do var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine - . re (_Unwrapped' . prefixed "$") + . re (prefixed "$" . _Unwrapped' . _Unwrapped') pre_ do code_ . toHtml . pShowNoColor $ vm td_ do @@ -377,6 +413,13 @@ ppDatum :: S.DatumIso a => a -> Html () ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso blah = [stkP| + (define $id + (return 1)) + (define $c + (return 1)) (define $start - (return 0)) + (push! $c) + (push! $id) + (push! 123) + (call 1)) |] diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index 205f047..aff9366 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -14,7 +14,7 @@ evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs test_root = testGroup "stack machine" [ testCase "immediate halt" do - evalsTo [ObjImm (ImmInt 3)] [stkP| + evalsTo [] [stkP| (define $start (return 0)) |] @@ -24,6 +24,18 @@ test_root = testGroup "stack machine" (push! 3) (return 1)) |] + , testCase "non-tail identity function" do + evalsTo [ObjImm (ImmInt 123)] [stkP| + (define $id + (return 1)) + (define $c + (return 1)) + (define $start + (push! $c) + (push! $id) + (push! 123) + (call 1)) + |] -- , testCase "return constant" do -- evalsTo [ObjImm (ImmInt 123)] [stkP| -- (define ($start %ktail)