new instrs, tail-call

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 }

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

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
+newtype Frame = MkFrame { locals :: List Obj }
-  { returnAddress :: Name
-  , procedure :: Name
-  , 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)
+pushFrame :: Frame -> Stack -> Stack
-stack = #frames . _NonEmpty . _1 . #locals
+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
+stepI e vm (Push v) = traverseOf activeFrame push vm
-  where push xs = (:) <$> evalVal e vm v <*> pure xs
+  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
+stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of
-  [] -> vmerror "empty stack"
+  Nothing -> vmerror "empty stack"
-  (x:xs) -> pure $ vm & #registers . at r ?~ x
+  Just (x,xs) -> pure $ vm & #registers . at r ?~ x
-               & stack .~ xs
+               & 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) ->
+    Just (args,"halt",_) -> pure $ vm & #result ?~ args
-      case f of
+    Just (args,f,ra) -> do
-        "halt" -> pure $ vm & #result ?~ xs
+      rt <- case g ^. #labels . at f of
-        l -> do
+        Nothing -> vmerror [i|undefined label #{f}|]
-          rt <- case g ^. #labels . at l of
+        Just x -> pure x
-            Nothing -> vmerror [i|undefined label: #{l}|]
+      let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel ra]
-            Just x -> pure x
+      pure $ vm
-          let newFrame = MkFrame
+        & #code .~ rt.start.code
-                { returnAddress =
+        & #tail .~ rt.start.tail
-                  vm ^. #frames . _NonEmpty . _1 . #returnAddress
+        -- replace the active frame; don't push a new one.
-                , procedure = f
+        & activeFrame .~ newFrame
-                , locals = xs
+        -- it is not essential we clear the registers, but it'll
-                }
+        -- make bugs more obvious.
-          pure $ vm
+        & #registers .~ mempty
-            & #code .~ rt.start.code
+
-            & #tail .~ rt.start.tail
+-- stepT g vm tc@(TailCall nargs) =
-            & stack .~ rest
+--   case setupCall nargs (vm ^. stack) of
-            & #frames %~ NE.cons newFrame
+--     Nothing -> vmerror [i|bad stack at #{tc}|]
-            -- it is not essential we clear the registers, but it'll
+--     Just (xs,f,rest) ->
-            -- make bugs more obvious.
+--       case f of
-            & #registers .~ mempty
+--         "halt" -> pure $ vm & #result ?~ xs
-            & #debug . #currentRoutine .~ rt.label
+--         l -> do
-  -- evalToLabel g vm f >>= \case
+--           rt <- case g ^. #labels . at l of
-  --   "halt" -> pure $ vm & #result ?~ xs'
+--             Nothing -> vmerror [i|undefined label: #{l}|]
-  --   l -> do
+--             Just x -> pure x
-  --     rt <- case g ^. #labels . at l of
+--           let ra = vm ^. #activeFrame . #returnAddress
-  --         Nothing -> vmerror [i|undefined label: #{l}|]
+--           let newFrame = MkFrame $ xs ++ [ObjLabel f, ra]
-  --         Just x -> pure x
+--           pure $ vm
-  --     pure $ vm & #code .~ rt.start.code
+--             & #code .~ rt.start.code
-  --           & #tail .~ rt.start.tail
+--             & #tail .~ rt.start.tail
-  --           & #registers .~ H.fromList (rt.params `zip` xs')
+--             & stack .~ rest
-  --           & #debug . #currentRoutine .~ rt.label
+--             & #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)
+takeExact :: Int -> List a -> Maybe (List a)
-setupCall n stk = do
+takeExact n xs = case compareLength xs n of
-  (xs,stk') <- splitAtExact (n+2) stk
+  (EQ;GT) -> Just $ take n xs
-  case splitAtExact n xs of
+  LT -> Nothing
-    Just (args, [p,ret]) -> case (p,ret) of
-      (ObjImm (ImmLabel p'),ObjImm (ImmLabel ret')) -> Just (args,p',ret',stk')
-      _ -> Nothing
-    _ -> error "unreachable"
 
-setupTailCall :: Int -> List Obj -> Maybe (List Obj, Name, List Obj)
+parseTailCall :: Int -> Frame -> Maybe (List Obj, Name, Name)
-setupTailCall n stk = do
+parseTailCall nargs frm = do
-  (xs,stk') <- splitAtExact (n+1) stk
+  (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
-  case xs ^? _Snoc of
+  let (xs',f) = xs ^?! _Snoc
-    Just (args, [p,ret]) -> case (p,ret) of
+  f' <- f ^? #ObjImm . #ImmLabel
-      (ObjImm (ImmLabel p'),ObjImm (ImmLabel ret')) -> Just (args,p',stk')
+  pure (xs',f',frm ^?! returnAddress)
-      _ -> Nothing
-    _ -> error "unreachable"
 
 initialVM :: VM
 initialVM = MkVM
-  { frames = NE.singleton $ MkFrame
+  { stack = MkStack . NE.singleton . MkFrame $
-    { returnAddress = "halt"
+    [ ObjLabel "start"
-    , procedure = "<nowhere at all>"
+    , ObjLabel "<nowhere at all>"
-    , locals = [ ObjImm (ImmLabel "start")
+    , 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))
       |]

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|