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
@@ -72,7 +74,7 @@ data Tail
 data Instr
   = Pop Reg
   | Push Val
-  | Load Reg
+  | Load Reg Int
   | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -95,7 +97,7 @@ instance S.DatumIso Instr where
   datumIso = S.match
     $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged1 "load!" S.datumIso >>>)
+    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
     $ S.End
     where

src/Gyehoek/Stack/VM.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE ViewPatterns, MultilineStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -28,34 +30,51 @@ import Control.DeepSeq (deepseq, ($!!))
 import Gyehoek.Sexp.Print (htmlData, htmlDatum)
 import Control.DeepSeq (deepseq, ($!!))
 import Data.String (fromString)
+import Data.Monoid (First)
+import GHC.Stack (popCallStack)
+import Data.Maybe (fromMaybe)
 
 
 -- | non-essential information maintained only to aide in debugging.
 data DebugVM = MkDebugVM
-  { currentRoutine :: Name
+  { activeRoutine :: Label
   }
   deriving (Show, Generic)
 
 newtype Frame = MkFrame { locals :: List Obj }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-returnAddress :: Traversal' Frame Name
+-- affine
+returnAddress :: Traversal' Frame Label
 returnAddress = #locals . _last . #ObjImm . #ImmLabel
 
+-- affine
+activeProcedure :: Traversal' Frame Label
+activeProcedure = #locals . _init . _last . #ObjImm . #ImmLabel
+
+callStack :: Traversal' Stack Label
+callStack = each . activeProcedure
+
 newtype Stack = MkStack { frames :: NonEmpty Frame }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
 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
   }
   deriving (Show, Generic)
 
+type instance Index Frame = Int
+type instance IxValue Frame = Obj
+
+instance Ixed Frame where
+  ix j = wrappedIso . ix j
+
 instance Cons Frame Frame Obj Obj where
   _Cons = prism'
     (\(x,MkFrame xs) -> MkFrame (x:xs))
@@ -63,6 +82,13 @@ instance Cons Frame Frame Obj Obj where
       MkFrame (x:xs) -> Just (x, MkFrame xs)
       MkFrame [] -> Nothing
 
+instance Each Frame Frame Obj Obj where each = wrappedIso . each
+
+instance Each Stack Stack Frame Frame where each = wrappedIso . each
+
+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 +101,7 @@ activeFrame :: Lens' VM Frame
 activeFrame = #stack . #frames . _NonEmpty . _1
 
 data Env = MkEnv
-  { labels :: HashMap Name Routine
+  { labels :: HashMap Label Routine
   }
   deriving (Show, Generic)
 
@@ -89,6 +115,10 @@ vmerror = throwError . VMError
 
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
+stepI e vm (Load r j) = do
+  x <- expectOf [i|object at index #{j}|] (activeFrame . ix j) vm
+  pure $ vm & #registers . at r ?~ x
+
 stepI e vm (Push v) = traverseOf activeFrame push vm
   where push xs = cons <$> evalVal e vm v <*> pure xs
 
@@ -135,58 +165,84 @@ stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
 
 stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
 
-stepT g vm (Return nret) =
-  case splitAtExact nret (vm ^. activeFrame . #locals) of
-    Nothing -> _
-    Just (_,_) -> _
+stepT g vm tc@(Call nargs) = do
+  (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
+    & expectOf [i|#{show tc}|] _Just 
+  rt <- getRoutine g f
+  let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
+  pure $ vm
+    & jumpToRoutine rt
+    & activeFrame .~ frm
+    & #stack %~ pushFrame 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 parseTailCall nargs (vm ^. activeFrame) of
-    Nothing -> vmerror [i|bad stack at #{tc}|]
-    Just (args,"halt",_) -> pure $ vm & #result ?~ args
-    Just (args,f,ra) -> do
+stepT g vm tc@(Return nret) = do
+  (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
+    & expectOf [i|"#{show tc}"|] _Just
+  expectOf [i||] (activeFrame . returnAddress) vm >>= \case
+    "halt" -> pure $ vm & #result ?~ xs
+    ra -> do
+      rt <- getRoutine g ra
+      vm & traverseOf #stack (fmap snd . popFrame)
+         & mapped . activeFrame %~ pushes xs
+         & mapped %~ jumpToRoutine rt
+
+stepT g vm tc@(TailCall nargs) = do
+  (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
+    & expectOf [i|#{show tc}|] _Just
+  case f of
+    "halt" -> pure $ vm & #result ?~ args
+    _ -> 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
+        & jumpToRoutine rt
         -- 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
       ObjImm (ImmBool False) -> f
       _ -> t
-  pure $ vm & #code .~ branch.code & #tail .~ branch.tail
+  pure $ jumpToBlock branch vm
 
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Name
+
+
+popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack)
+popFrame stk = case stk ^. #frames . to NE.uncons of
+  (_, Nothing) -> vmerror "no frame to pop"
+  (f, Just fs) -> pure (f, stk & #frames .~ fs)
+
+jumpToBlock :: Block -> VM -> VM
+jumpToBlock b vm = vm
+  & #code .~ b.code
+  & #tail .~ b.tail
+
+jumpToRoutine :: Routine -> VM -> VM
+jumpToRoutine rt vm = vm
+  & jumpToBlock rt.start
+  & #debug . #activeRoutine .~ rt.label
+
+getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Label -> Eff es Routine
+getRoutine g l = case g ^. #labels . at l of
+  Just rt -> pure rt
+  Nothing -> vmerror [i|undefined label #{l}|]
+
+expectOf
+  :: (HasCallStack, Jalmot :> es)
+  => Text -> Getting (First a) s a -> s -> Eff es a
+expectOf msg l s = case s ^? l of
+  Just x -> pure x
+  Nothing -> vmerror [i|bad stack, expecting #{msg}|]
+
+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 +265,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
@@ -229,7 +293,7 @@ initialVM = MkVM
   , stdout = ""
   , result = Nothing
   , debug = MkDebugVM
-    { currentRoutine = "<nowhere>"
+    { activeRoutine = "<nowhere>"
     }
   }
 
@@ -329,7 +393,7 @@ ppTrace trace =
   table_ do
     thead_ $ tr_ do
       traverse_ (th_ [scope_ "col"])
-        ["location","instruction","stack"]
+        ["routine","next instruction","stack frame"]
     tbody_ do
       go trace
   where
@@ -361,14 +425,14 @@ ppVM vm = do
     td_ do
       details_ do
         summary_ do
-          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
-            . re (_Unwrapped' . prefixed "$")
+          var_ [class_ "loc"] do
+            vm ^. #debug . #activeRoutine . to ppDatum
         pre_ do
           code_ . toHtml . pShowNoColor $ vm
     td_ do
       code_ curi
     td_ do
-      let xs = _
+      let xs = vm ^.. activeFrame . each . to ppDatum
       sequence_ $ intersperse " | " xs
   where
     curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
@@ -376,7 +440,28 @@ ppVM vm = do
 ppDatum :: S.DatumIso a => a -> Html ()
 ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
 
-blah = [stkP|
-        (define $start
-          (return 0))
-      |]
+fac (n :: Int) = [stkP|
+(define $start
+  (push! $fac)
+  (push! #{n})
+  (tail-call 1))
+
+(define $fac
+  (load %n 0)
+  (prim %x0 (zero? %n))
+  (if %x0
+      (then (push! 1)
+            (return 1))
+      (else (prim %x1 (- %n 1))
+            (push! $fac-c0)
+            (push! $fac)
+            (push! %x1)
+            (call 1))))
+
+(define $fac-c0
+  (pop! %x2)
+  (pop! %n)
+  (prim %x3 (* %n %x2))
+  (push! %x3)
+  (return 1))
+|]