msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

new instrs, tail-call

Browse Source
This commit is contained in:
msyds
2026-08-28 11:39:37 -06:00
parent c0a44c89b4
commit 9cb169f9b8
4 changed files with 96 additions and 79 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Gyehoek/CPS/Syntax.hs
+3
View File
@@ -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
+8 -3
View File
@@ -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
+83 -74
View File
@@ -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 = "<nowhere at all>"
, locals = [ ObjImm (ImmLabel "start")
]
}
{ stack = MkStack . NE.singleton . MkFrame $
[ ObjLabel "start"
, ObjLabel "<nowhere at all>"
, 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
+2 -2
View File
@@ -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|