wip: stack frames

This commit is contained in:
2026-08-28 11:39:37 -06:00
parent 49292d5d01
commit c0a44c89b4
6 changed files with 349 additions and 117 deletions
+88
View File
@@ -0,0 +1,88 @@
* example
#+begin_src scheme
(letrec ((fac (λ (n)
(if (zero? n)
1
(* n (fac (- n 1)))))))
(fac 3))
#+end_src
#+begin_src scheme
(λ (ktail0)
(letrec ((fac
(λ (n ktail1)
(zero?
n
(κ (x0)
(if x0
(continue ktail1 1)
(- n 1
(κ (x1)
(fac x1
(κ (x2)
(* n x2 ktail1)))))))))))
(fac 3)))
#+end_src
#+begin_example
n ktail1
| |
| | x0
| | |
| | ^
| |
| | x1
| | |
| | ^
| |
| | x2
| | |
^ ^ ^
#+end_example
#+begin_src scheme
(define $fac-c0
(pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
(if %x0 ; [ $fac-c0 n $fac ktail1 ]
;; every variable but `ktail1' is dead so we pop them all.
;; this probably means that `if' should take two continuations
;; rather than two blocks.
(then (pop! %_) ; [ $fac-c0 n $fac ktail1 ]
(pop! %_) ; [ n $fac ktail1 ]
(pop! %_) ; [ $fac ktail1 ]
(push! 1) ; [ ktail1 ]
(return 1)) ; [ 1 ktail1 ]
(else (load! %n 1) ; [ $fac-c0 n $fac ktail1 ]
(prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
(call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
)))
(define $fac-c1
(pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
(load! %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(prim %x3 (* %n %x2))
(push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
)
(define $fac
(load! %ktail1 2) ; [ n $fac ktail1 ]
(load! %n 0) ; [ n $fac ktail1 ]
(push! $fac-c0) ; [ n $fac ktail1 ]
(push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
(push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
(call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
)
(define $start
(push! $fac) ; [ $start ktail0 ]
(push! 3) ; [ $fac $start ktail0 ]
(tail-call 1) ; [ 3 $fac $start ktail0 ]
;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
)
#+end_src
+68
View File
@@ -0,0 +1,68 @@
* rationale?
previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
this worked quite well until it became time to implement ~call/cc~.
we are considering making the following alterations to the VM:
- explicitly segment the stack into frames.
- passing procedures and return addresses on the stack.
* scratchpad
** Scheme source
#+begin_src scheme
(* 2 (call/cc
(λ (cc)
(begin (cc 6)
3))))
#+end_src
** CPS
#+begin_src scheme
(λ (ktail0)
(letrec ((with-cc
(λ (cc ktail1)
(letrec ((k0 (κ (_)
(continue ktail1 3))))
(cc 6 k0)))))
(prim (call/cc with-cc)
(κ (x1)
(prim (* 2 x1)
(κ (x2) (continue ktail0 x2)))))))
#+end_src
** stack VM
#+begin_src scheme
;; (call n) expects `n' values on the stack as arguments. then the
;; procedure is expected at index `n', and the return continuation
;; should be at `n+1'.
(define $k0
(pop! %_) ; [ _ ret ]
(push! 3) ; [ ret ]
(tail-call 1) ; [ 3 ret ]
)
(define $with-cc
(pop! %cc) ; [ cc ret ]
(push! $k0) ; [ ret ]
(push! %cc) ; [ $k0 ret ]
(push! 6) ; [ cc $k0 ret ]
;; call a procedure with one argument.
(call 1) ; [ 6 cc $k0 ret ]
)
(define $main
(pop! %ktail0) ; [ ret ]
(prim %x1 (call/cc $with-cc)) ; []
(prim %x2 (* 2 %x1)) ; []
(push! %ktail0) ; []
(push! %x2) ; [ ret ]
(tail-call 1) ; [ %x2 ret ]
)
#+end_src
+27 -35
View File
@@ -63,31 +63,22 @@ stackify g (ExpIf c t f) = do
f' <- buildBlock <$> stackify g f
pure . Tail $ Stk.If c' t' f'
stackify g (ExpApply f xs ktail) = pure $
Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
where
k = var g ktail
ls = fold $ (k ^? #ValImm . #ImmLabel)
>>= \klbl -> g ^. #liveness . at klbl
-- stackify g (ExpApply f xs ktail) = pure $
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-- Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
-- where
-- k = var g ktail
-- ls = fold $ (k ^? #ValImm . #ImmLabel)
-- >>= \klbl -> g ^. #liveness . at klbl
stackify g e@(ExpContinue k xs) = do
pure $
Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
Tail (Stk.TailCall k' (stackifyVal g <$> xs))
where
k' = stackifyVal g k
ls = fold $ (k' ^? #ValImm . #ImmLabel)
>>= \klbl -> g ^. #liveness . at klbl
-- stackify g (ExpPrim (PrimCallCC withcc) cc) = do
-- cc_l <- gensym' "cc"
-- rcc_l <- gensym' "reified-cc"
-- stackifyKappa g cc_l cc \g' rt -> do
-- emitRoutine rt
-- pure $
-- Code [ Stk.Prim rcc_l PrimCaptureCC ] $
-- Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
-- stackify g e@(ExpContinue k xs) = do
-- pure $
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-- Tail (Stk.TailCall k' (stackifyVal g <$> xs))
-- where
-- k' = stackifyVal g k
-- ls = fold $ (k' ^? #ValImm . #ImmLabel)
-- >>= \klbl -> g ^. #liveness . at klbl
stackify g (ExpPrim p (MkKappa [x] e)) = do
e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
@@ -105,16 +96,17 @@ stackifyKappa
=> Env -> Name -> Kappa
-> (Env -> Stk.Routine -> Eff es r)
-> Eff es r
stackifyKappa g name kap@(MkKappa xs m) w = do
let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
let ls = live g kap
m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
let g' = g & #bound . at name ?~ Stk.ValLabel name
& #liveness . at name ?~ live g kap
let rt = Stk.MkRoutine name xs . buildBlock $
-- pop in the opposite order we push
Code [Stk.Pop x | x <- reverse ls] m'
w g' rt
stackifyKappa g name kap@(MkKappa xs m) w = _
-- stackifyKappa g name kap@(MkKappa xs m) w = do
-- let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
-- let ls = live g kap
-- m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
-- let g' = g & #bound . at name ?~ Stk.ValLabel name
-- & #liveness . at name ?~ live g kap
-- let rt = Stk.MkRoutine name xs . buildBlock $
-- -- pop in the opposite order we push
-- Code [Stk.Pop x | x <- reverse ls] m'
-- w g' rt
stackifyLambda
:: (Stackify :> es, GenSym :> es)
@@ -125,7 +117,7 @@ stackifyLambda g name (MkLambda xs k m) w = do
let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
m' <- stackify (g & #bound <>~ H.fromList vs) m
let g' = g & #bound . at name ?~ Stk.ValLabel name
w g' $ Stk.MkRoutine name (k:xs) (buildBlock m')
w g' $ Stk.MkRoutine name (buildBlock m')
stackifyVal :: Env -> Val -> Stk.Val
stackifyVal g = \case
+9 -7
View File
@@ -45,7 +45,6 @@ instance IsList Program where
data Routine = MkRoutine
{ label :: Name
, params :: List Name
, start :: Block
}
deriving stock (Show, Generic, Data)
@@ -59,10 +58,12 @@ data Block = MkBlock
deriving anyclass (NFData)
data Tail
= TailCall Val (List Val)
-- | call the procedure at stack index `n` supplied with `n`
-- arguments on top of the stack, then return by calling the
-- continuation at stack index `n+1`.
= TailCall Int
| If Val Block Block
-- | Invoke a reified continuation.
| InvokeC Val
| Return
deriving stock (Show, Generic, Data)
deriving anyclass (NFData)
@@ -105,11 +106,12 @@ instance S.DataIso Block where
instance S.DatumIso Tail where
datumIso = S.match
$ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
$ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
$ S.With (if_ >>>)
$ S.With (S.headTagged1 "invoke/c" S.datumIso >>>)
$ S.With (S.headTagged0 "return" >>>)
$ S.End
where
-- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
branch :: Text -> S.DatumGrammar Block
branch s =
@@ -127,7 +129,7 @@ instance S.DatumIso Routine where
datumIso = S.with \rout ->
S.listWithIndentation (S.NSpecial 1)
( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
>>> S.el (S.list $ S.el labelName >>> S.rest regName)
>>> S.el labelName
>>> S.restData (S.dataIso @Block)
)
>>> rout
+94 -18
View File
@@ -12,7 +12,7 @@ module Gyehoek.Stack.VM
import Gyehoek.Stack.Syntax
import Control.Lens
import qualified Data.HashMap.Strict as H
import Data.List (unfoldr, intersperse)
import Data.List (unfoldr, intersperse, compareLength)
import Gyehoek.Prelude
import qualified Data.List.NonEmpty as NE
import Lucid
@@ -36,8 +36,18 @@ data DebugVM = MkDebugVM
}
deriving (Show, Generic)
data Frame = MkFrame
{ returnAddress :: Name
, procedure :: Name
, locals :: List Obj
}
deriving (Show, Generic)
newtype Stack = MkStack (NonEmpty Frame)
deriving (Show, Generic)
data VM = MkVM
{ stack :: List Obj
{ frames :: NonEmpty Frame
, code :: List Instr
, tail :: Tail
, registers :: HashMap Name Obj
@@ -47,6 +57,14 @@ data VM = MkVM
}
deriving (Show, Generic)
_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
data Env = MkEnv
{ labels :: HashMap Name Routine
}
@@ -62,7 +80,7 @@ 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 stack push vm
where push xs = (:) <$> evalVal e vm v <*> pure xs
stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
@@ -99,27 +117,52 @@ 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 ^. stack of
[] -> vmerror "empty stack"
(x:xs) -> pure $ vm & #registers . at r ?~ x
& #stack .~ xs
& stack .~ xs
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
stepT g vm (TailCall f xs) = do
xs' <- traverse (evalVal g vm) xs
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
stepT g vm Return = vmerror "aajak"
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 newFrame = MkFrame
{ returnAddress =
vm ^. #frames . _NonEmpty . _1 . #returnAddress
, procedure = f
, locals = xs
}
pure $ vm
& #code .~ rt.start.code
& #tail .~ rt.start.tail
& #registers .~ H.fromList (rt.params `zip` xs')
& 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
stepT g vm (If c t f) = do
branch <- evalVal g vm c <&> \case
@@ -140,11 +183,39 @@ evalVal e vm = \case
Just x -> pure x
Nothing -> vmerror [i|undefined register: #{r}|]
splitAtExact :: Int -> List a -> Maybe (List a, List a)
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"
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"
initialVM :: VM
initialVM = MkVM
{ stack = []
{ frames = NE.singleton $ MkFrame
{ returnAddress = "halt"
, procedure = "<nowhere at all>"
, locals = [ ObjImm (ImmLabel "start")
]
}
, tail = TailCall 0
, code = []
, tail = TailCall (ValLabel "start") [ValLabel "halt"]
, registers = mempty
, stdout = ""
, result = Nothing
@@ -288,10 +359,15 @@ ppVM vm = do
td_ do
code_ curi
td_ do
let xs = code_ . ppDatum <$> (vm ^. #stack)
let xs = code_ . ppDatum <$> (vm ^. stack)
sequence_ $ intersperse " | " xs
where
curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
ppDatum :: S.DatumIso a => a -> Html ()
ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
blah = [stkP|
(define $start
(return))
|]
+63 -57
View File
@@ -13,64 +13,70 @@ evalsTo :: List Obj -> Program -> Assertion
evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
test_root = testGroup "stack machine"
[ testCase "lit int" do
[ testCase "immediate halt" do
evalsTo [ObjImm (ImmInt 3)] [stkP|
(define ($start %ktail)
(tail-call %ktail 3))
(define $start
(tail-call 0))
|]
, testCase "return constant" do
evalsTo [ObjImm (ImmInt 123)] [stkP|
(define ($start %ktail)
(tail-call $silly %ktail))
(define ($silly %ktail)
(tail-call %ktail 123))
, testCase "lit int" do
evalsTo [ObjImm (ImmInt 3)] [stkP|
(define $start
(push! 3)
(tail-call 1))
|]
, testCase "identity continuation" do
evalsTo [ObjImm (ImmInt 45)] [stkP|
(define ($start %ktail)
(push! %ktail)
(tail-call $id 45))
(define ($id %x)
(pop! %ktail)
(tail-call %ktail %x))
|]
, testCase "identity function" do
evalsTo [ObjImm (ImmInt 45)] [stkP|
(define ($start %ktail)
(tail-call $id 45 %ktail))
(define ($id %x %ktail)
(tail-call %ktail %x))
|]
, testCase "square" do
evalsTo [ObjImm (ImmInt 16)] [stkP|
(define ($start %ktail)
(tail-call $square 4 %ktail))
(define ($square %x %ktail)
(prim %x2 (* %x %x))
(tail-call %ktail %x2))
|]
, testCase "factorial" do
let hsfac (n :: Int) = foldr (*) (1) [1..n]
let fac (n :: Int) = [stkP|
(define ($fac %n %ktail)
(prim %x0 (zero? %n))
(if %x0
(then (tail-call %ktail 1))
(else (push! %n)
(push! %ktail)
(prim %x1 (- %n 1))
(tail-call $fac %x1 $fac-k0))))
(define ($fac-k0 %x2)
(pop! %ktail)
(pop! %n)
(prim %x3 (* %x2 %n))
(tail-call %ktail %x3))
(define ($start %ktail)
(tail-call $fac #{n} %ktail))
|]
evalsTo [ObjImm (ImmInt 1)] $ fac 0
evalsTo [ObjImm (ImmInt 1)] $ fac 1
evalsTo [ObjImm (ImmInt 720)] $ fac 6
-- 20 is the greatest `n` for which n! ≤ maxBount @Int
evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
-- , testCase "return constant" do
-- evalsTo [ObjImm (ImmInt 123)] [stkP|
-- (define ($start %ktail)
-- (tail-call $silly %ktail))
-- (define ($silly %ktail)
-- (tail-call %ktail 123))
-- |]
-- , testCase "identity continuation" do
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
-- (define ($start %ktail)
-- (push! %ktail)
-- (tail-call $id 45))
-- (define ($id %x)
-- (pop! %ktail)
-- (tail-call %ktail %x))
-- |]
-- , testCase "identity function" do
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
-- (define ($start %ktail)
-- (tail-call $id 45 %ktail))
-- (define ($id %x %ktail)
-- (tail-call %ktail %x))
-- |]
-- , testCase "square" do
-- evalsTo [ObjImm (ImmInt 16)] [stkP|
-- (define ($start %ktail)
-- (tail-call $square 4 %ktail))
-- (define ($square %x %ktail)
-- (prim %x2 (* %x %x))
-- (tail-call %ktail %x2))
-- |]
-- , testCase "factorial" do
-- let hsfac (n :: Int) = foldr (*) (1) [1..n]
-- let fac (n :: Int) = [stkP|
-- (define ($fac %n %ktail)
-- (prim %x0 (zero? %n))
-- (if %x0
-- (then (tail-call %ktail 1))
-- (else (push! %n)
-- (push! %ktail)
-- (prim %x1 (- %n 1))
-- (tail-call $fac %x1 $fac-k0))))
-- (define ($fac-k0 %x2)
-- (pop! %ktail)
-- (pop! %n)
-- (prim %x3 (* %x2 %n))
-- (tail-call %ktail %x3))
-- (define ($start %ktail)
-- (tail-call $fac #{n} %ktail))
-- |]
-- evalsTo [ObjImm (ImmInt 1)] $ fac 0
-- evalsTo [ObjImm (ImmInt 1)] $ fac 1
-- evalsTo [ObjImm (ImmInt 720)] $ fac 6
-- -- 20 is the greatest `n` for which n! ≤ maxBount @Int
-- evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
]