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
|
||||
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
|
||||
|
||||
@@ -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
@@ -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))
|
||||
|]
|
||||
|
||||
@@ -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
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user