return, pushcall

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 "#<procedure>" :- t)
         (const . Left $ mempty)

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

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))
       |]

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)