wip: stack frames
This commit is contained in:
@@ -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
|
||||||
|
|
||||||
@@ -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
@@ -63,31 +63,22 @@ stackify g (ExpIf c t f) = do
|
|||||||
f' <- buildBlock <$> stackify g f
|
f' <- buildBlock <$> stackify g f
|
||||||
pure . Tail $ Stk.If c' t' f'
|
pure . Tail $ Stk.If c' t' f'
|
||||||
|
|
||||||
stackify g (ExpApply f xs ktail) = pure $
|
-- stackify g (ExpApply f xs ktail) = pure $
|
||||||
Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
|
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
|
||||||
Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
|
-- Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
|
||||||
where
|
-- where
|
||||||
k = var g ktail
|
-- k = var g ktail
|
||||||
ls = fold $ (k ^? #ValImm . #ImmLabel)
|
-- ls = fold $ (k ^? #ValImm . #ImmLabel)
|
||||||
>>= \klbl -> g ^. #liveness . at klbl
|
-- >>= \klbl -> g ^. #liveness . at klbl
|
||||||
|
|
||||||
stackify g e@(ExpContinue k xs) = do
|
-- stackify g e@(ExpContinue k xs) = do
|
||||||
pure $
|
-- pure $
|
||||||
Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
|
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
|
||||||
Tail (Stk.TailCall k' (stackifyVal g <$> xs))
|
-- Tail (Stk.TailCall k' (stackifyVal g <$> xs))
|
||||||
where
|
-- where
|
||||||
k' = stackifyVal g k
|
-- k' = stackifyVal g k
|
||||||
ls = fold $ (k' ^? #ValImm . #ImmLabel)
|
-- ls = fold $ (k' ^? #ValImm . #ImmLabel)
|
||||||
>>= \klbl -> g ^. #liveness . at klbl
|
-- >>= \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 (ExpPrim p (MkKappa [x] e)) = do
|
stackify g (ExpPrim p (MkKappa [x] e)) = do
|
||||||
e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
|
e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
|
||||||
@@ -105,16 +96,17 @@ stackifyKappa
|
|||||||
=> Env -> Name -> Kappa
|
=> Env -> Name -> Kappa
|
||||||
-> (Env -> Stk.Routine -> Eff es r)
|
-> (Env -> Stk.Routine -> Eff es r)
|
||||||
-> Eff es r
|
-> Eff es r
|
||||||
stackifyKappa g name kap@(MkKappa xs m) w = do
|
stackifyKappa g name kap@(MkKappa xs m) w = _
|
||||||
let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
|
-- stackifyKappa g name kap@(MkKappa xs m) w = do
|
||||||
let ls = live g kap
|
-- let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
|
||||||
m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
|
-- let ls = live g kap
|
||||||
let g' = g & #bound . at name ?~ Stk.ValLabel name
|
-- m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
|
||||||
& #liveness . at name ?~ live g kap
|
-- let g' = g & #bound . at name ?~ Stk.ValLabel name
|
||||||
let rt = Stk.MkRoutine name xs . buildBlock $
|
-- & #liveness . at name ?~ live g kap
|
||||||
-- pop in the opposite order we push
|
-- let rt = Stk.MkRoutine name xs . buildBlock $
|
||||||
Code [Stk.Pop x | x <- reverse ls] m'
|
-- -- pop in the opposite order we push
|
||||||
w g' rt
|
-- Code [Stk.Pop x | x <- reverse ls] m'
|
||||||
|
-- w g' rt
|
||||||
|
|
||||||
stackifyLambda
|
stackifyLambda
|
||||||
:: (Stackify :> es, GenSym :> es)
|
:: (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 ]
|
let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
|
||||||
m' <- stackify (g & #bound <>~ H.fromList vs) m
|
m' <- stackify (g & #bound <>~ H.fromList vs) m
|
||||||
let g' = g & #bound . at name ?~ Stk.ValLabel name
|
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 :: Env -> Val -> Stk.Val
|
||||||
stackifyVal g = \case
|
stackifyVal g = \case
|
||||||
|
|||||||
@@ -45,7 +45,6 @@ instance IsList Program where
|
|||||||
|
|
||||||
data Routine = MkRoutine
|
data Routine = MkRoutine
|
||||||
{ label :: Name
|
{ label :: Name
|
||||||
, params :: List Name
|
|
||||||
, start :: Block
|
, start :: Block
|
||||||
}
|
}
|
||||||
deriving stock (Show, Generic, Data)
|
deriving stock (Show, Generic, Data)
|
||||||
@@ -59,10 +58,12 @@ data Block = MkBlock
|
|||||||
deriving anyclass (NFData)
|
deriving anyclass (NFData)
|
||||||
|
|
||||||
data Tail
|
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
|
| If Val Block Block
|
||||||
-- | Invoke a reified continuation.
|
| Return
|
||||||
| InvokeC Val
|
|
||||||
deriving stock (Show, Generic, Data)
|
deriving stock (Show, Generic, Data)
|
||||||
deriving anyclass (NFData)
|
deriving anyclass (NFData)
|
||||||
|
|
||||||
@@ -105,11 +106,12 @@ instance S.DataIso Block where
|
|||||||
|
|
||||||
instance S.DatumIso Tail where
|
instance S.DatumIso Tail where
|
||||||
datumIso = S.match
|
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 (if_ >>>)
|
||||||
$ S.With (S.headTagged1 "invoke/c" S.datumIso >>>)
|
$ S.With (S.headTagged0 "return" >>>)
|
||||||
$ S.End
|
$ S.End
|
||||||
where
|
where
|
||||||
|
-- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
|
||||||
if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
|
if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
|
||||||
branch :: Text -> S.DatumGrammar Block
|
branch :: Text -> S.DatumGrammar Block
|
||||||
branch s =
|
branch s =
|
||||||
@@ -127,7 +129,7 @@ instance S.DatumIso Routine where
|
|||||||
datumIso = S.with \rout ->
|
datumIso = S.with \rout ->
|
||||||
S.listWithIndentation (S.NSpecial 1)
|
S.listWithIndentation (S.NSpecial 1)
|
||||||
( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
|
( 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)
|
>>> S.restData (S.dataIso @Block)
|
||||||
)
|
)
|
||||||
>>> rout
|
>>> rout
|
||||||
|
|||||||
+94
-18
@@ -12,7 +12,7 @@ module Gyehoek.Stack.VM
|
|||||||
import Gyehoek.Stack.Syntax
|
import Gyehoek.Stack.Syntax
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import qualified Data.HashMap.Strict as H
|
import qualified Data.HashMap.Strict as H
|
||||||
import Data.List (unfoldr, intersperse)
|
import Data.List (unfoldr, intersperse, compareLength)
|
||||||
import Gyehoek.Prelude
|
import Gyehoek.Prelude
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
import Lucid
|
import Lucid
|
||||||
@@ -36,8 +36,18 @@ data DebugVM = MkDebugVM
|
|||||||
}
|
}
|
||||||
deriving (Show, Generic)
|
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
|
data VM = MkVM
|
||||||
{ stack :: List Obj
|
{ frames :: NonEmpty Frame
|
||||||
, code :: List Instr
|
, code :: List Instr
|
||||||
, tail :: Tail
|
, tail :: Tail
|
||||||
, registers :: HashMap Name Obj
|
, registers :: HashMap Name Obj
|
||||||
@@ -47,6 +57,14 @@ data VM = MkVM
|
|||||||
}
|
}
|
||||||
deriving (Show, Generic)
|
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
|
data Env = MkEnv
|
||||||
{ labels :: HashMap Name Routine
|
{ labels :: HashMap Name Routine
|
||||||
}
|
}
|
||||||
@@ -62,7 +80,7 @@ vmerror = throwError . VMError
|
|||||||
|
|
||||||
stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
|
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
|
where push xs = (:) <$> evalVal e vm v <*> pure xs
|
||||||
|
|
||||||
stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
|
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))
|
ret $ ObjImm (ImmInt (op x y))
|
||||||
arith_binop _ x y = vmerror [i|bad arith: #{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"
|
[] -> vmerror "empty stack"
|
||||||
(x:xs) -> pure $ vm & #registers . at r ?~ x
|
(x:xs) -> pure $ vm & #registers . at r ?~ x
|
||||||
& #stack .~ xs
|
& stack .~ xs
|
||||||
|
|
||||||
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
|
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
|
||||||
|
|
||||||
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
|
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
|
||||||
|
|
||||||
stepT g vm (TailCall f xs) = do
|
stepT g vm Return = vmerror "aajak"
|
||||||
xs' <- traverse (evalVal g vm) xs
|
|
||||||
evalToLabel g vm f >>= \case
|
stepT g vm tc@(TailCall nargs) =
|
||||||
"halt" -> pure $ vm & #result ?~ xs'
|
case setupCall nargs (vm ^. stack) of
|
||||||
l -> do
|
Nothing -> vmerror [i|bad stack at #{tc}|]
|
||||||
rt <- case g ^. #labels . at l of
|
Just (xs,f,rest) ->
|
||||||
Nothing -> vmerror [i|undefined label: #{l}|]
|
case f of
|
||||||
Just x -> pure x
|
"halt" -> pure $ vm & #result ?~ xs
|
||||||
pure $ vm & #code .~ rt.start.code
|
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
|
& #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
|
& #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
|
stepT g vm (If c t f) = do
|
||||||
branch <- evalVal g vm c <&> \case
|
branch <- evalVal g vm c <&> \case
|
||||||
@@ -140,11 +183,39 @@ evalVal e vm = \case
|
|||||||
Just x -> pure x
|
Just x -> pure x
|
||||||
Nothing -> vmerror [i|undefined register: #{r}|]
|
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 :: VM
|
||||||
initialVM = MkVM
|
initialVM = MkVM
|
||||||
{ stack = []
|
{ frames = NE.singleton $ MkFrame
|
||||||
|
{ returnAddress = "halt"
|
||||||
|
, procedure = "<nowhere at all>"
|
||||||
|
, locals = [ ObjImm (ImmLabel "start")
|
||||||
|
]
|
||||||
|
}
|
||||||
|
, tail = TailCall 0
|
||||||
, code = []
|
, code = []
|
||||||
, tail = TailCall (ValLabel "start") [ValLabel "halt"]
|
|
||||||
, registers = mempty
|
, registers = mempty
|
||||||
, stdout = ""
|
, stdout = ""
|
||||||
, result = Nothing
|
, result = Nothing
|
||||||
@@ -288,10 +359,15 @@ ppVM vm = do
|
|||||||
td_ do
|
td_ do
|
||||||
code_ curi
|
code_ curi
|
||||||
td_ do
|
td_ do
|
||||||
let xs = code_ . ppDatum <$> (vm ^. #stack)
|
let xs = code_ . ppDatum <$> (vm ^. stack)
|
||||||
sequence_ $ intersperse " | " xs
|
sequence_ $ intersperse " | " xs
|
||||||
where
|
where
|
||||||
curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
|
curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
|
||||||
|
|
||||||
ppDatum :: S.DatumIso a => a -> Html ()
|
ppDatum :: S.DatumIso a => a -> Html ()
|
||||||
ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
|
ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
|
||||||
|
|
||||||
|
blah = [stkP|
|
||||||
|
(define $start
|
||||||
|
(return))
|
||||||
|
|]
|
||||||
|
|||||||
@@ -13,64 +13,70 @@ evalsTo :: List Obj -> Program -> Assertion
|
|||||||
evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
|
evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
|
||||||
|
|
||||||
test_root = testGroup "stack machine"
|
test_root = testGroup "stack machine"
|
||||||
[ testCase "lit int" do
|
[ testCase "immediate halt" do
|
||||||
evalsTo [ObjImm (ImmInt 3)] [stkP|
|
evalsTo [ObjImm (ImmInt 3)] [stkP|
|
||||||
(define ($start %ktail)
|
(define $start
|
||||||
(tail-call %ktail 3))
|
(tail-call 0))
|
||||||
|]
|
|]
|
||||||
, testCase "return constant" do
|
, testCase "lit int" do
|
||||||
evalsTo [ObjImm (ImmInt 123)] [stkP|
|
evalsTo [ObjImm (ImmInt 3)] [stkP|
|
||||||
(define ($start %ktail)
|
(define $start
|
||||||
(tail-call $silly %ktail))
|
(push! 3)
|
||||||
(define ($silly %ktail)
|
(tail-call 1))
|
||||||
(tail-call %ktail 123))
|
|
||||||
|]
|
|]
|
||||||
, testCase "identity continuation" do
|
-- , testCase "return constant" do
|
||||||
evalsTo [ObjImm (ImmInt 45)] [stkP|
|
-- evalsTo [ObjImm (ImmInt 123)] [stkP|
|
||||||
(define ($start %ktail)
|
-- (define ($start %ktail)
|
||||||
(push! %ktail)
|
-- (tail-call $silly %ktail))
|
||||||
(tail-call $id 45))
|
-- (define ($silly %ktail)
|
||||||
(define ($id %x)
|
-- (tail-call %ktail 123))
|
||||||
(pop! %ktail)
|
-- |]
|
||||||
(tail-call %ktail %x))
|
-- , testCase "identity continuation" do
|
||||||
|]
|
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
|
||||||
, testCase "identity function" do
|
-- (define ($start %ktail)
|
||||||
evalsTo [ObjImm (ImmInt 45)] [stkP|
|
-- (push! %ktail)
|
||||||
(define ($start %ktail)
|
-- (tail-call $id 45))
|
||||||
(tail-call $id 45 %ktail))
|
-- (define ($id %x)
|
||||||
(define ($id %x %ktail)
|
-- (pop! %ktail)
|
||||||
(tail-call %ktail %x))
|
-- (tail-call %ktail %x))
|
||||||
|]
|
-- |]
|
||||||
, testCase "square" do
|
-- , testCase "identity function" do
|
||||||
evalsTo [ObjImm (ImmInt 16)] [stkP|
|
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
|
||||||
(define ($start %ktail)
|
-- (define ($start %ktail)
|
||||||
(tail-call $square 4 %ktail))
|
-- (tail-call $id 45 %ktail))
|
||||||
(define ($square %x %ktail)
|
-- (define ($id %x %ktail)
|
||||||
(prim %x2 (* %x %x))
|
-- (tail-call %ktail %x))
|
||||||
(tail-call %ktail %x2))
|
-- |]
|
||||||
|]
|
-- , testCase "square" do
|
||||||
, testCase "factorial" do
|
-- evalsTo [ObjImm (ImmInt 16)] [stkP|
|
||||||
let hsfac (n :: Int) = foldr (*) (1) [1..n]
|
-- (define ($start %ktail)
|
||||||
let fac (n :: Int) = [stkP|
|
-- (tail-call $square 4 %ktail))
|
||||||
(define ($fac %n %ktail)
|
-- (define ($square %x %ktail)
|
||||||
(prim %x0 (zero? %n))
|
-- (prim %x2 (* %x %x))
|
||||||
(if %x0
|
-- (tail-call %ktail %x2))
|
||||||
(then (tail-call %ktail 1))
|
-- |]
|
||||||
(else (push! %n)
|
-- , testCase "factorial" do
|
||||||
(push! %ktail)
|
-- let hsfac (n :: Int) = foldr (*) (1) [1..n]
|
||||||
(prim %x1 (- %n 1))
|
-- let fac (n :: Int) = [stkP|
|
||||||
(tail-call $fac %x1 $fac-k0))))
|
-- (define ($fac %n %ktail)
|
||||||
(define ($fac-k0 %x2)
|
-- (prim %x0 (zero? %n))
|
||||||
(pop! %ktail)
|
-- (if %x0
|
||||||
(pop! %n)
|
-- (then (tail-call %ktail 1))
|
||||||
(prim %x3 (* %x2 %n))
|
-- (else (push! %n)
|
||||||
(tail-call %ktail %x3))
|
-- (push! %ktail)
|
||||||
(define ($start %ktail)
|
-- (prim %x1 (- %n 1))
|
||||||
(tail-call $fac #{n} %ktail))
|
-- (tail-call $fac %x1 $fac-k0))))
|
||||||
|]
|
-- (define ($fac-k0 %x2)
|
||||||
evalsTo [ObjImm (ImmInt 1)] $ fac 0
|
-- (pop! %ktail)
|
||||||
evalsTo [ObjImm (ImmInt 1)] $ fac 1
|
-- (pop! %n)
|
||||||
evalsTo [ObjImm (ImmInt 720)] $ fac 6
|
-- (prim %x3 (* %x2 %n))
|
||||||
-- 20 is the greatest `n` for which n! ≤ maxBount @Int
|
-- (tail-call %ktail %x3))
|
||||||
evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
|
-- (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
|
||||||
]
|
]
|
||||||
|
|||||||
Reference in New Issue
Block a user