From 7085ef06854d243f0a464af929ba6088917dbc61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 28 Aug 2026 09:44:32 -0600 Subject: [PATCH] return, pushcall --- doc/liveness.org | 88 ---------------- doc/make-vm-stackier.org | 118 +++++++++++++-------- src/Gyehoek/CPS/Syntax.hs | 8 +- src/Gyehoek/Stack/Syntax.hs | 8 +- src/Gyehoek/Stack/VM.hs | 187 ++++++++++++++++++++++++---------- test/Gyehoek/Test/Stack/VM.hs | 143 ++++++++++++++++---------- 6 files changed, 307 insertions(+), 245 deletions(-) delete mode 100644 doc/liveness.org diff --git a/doc/liveness.org b/doc/liveness.org deleted file mode 100644 index 655ee37..0000000 --- a/doc/liveness.org +++ /dev/null @@ -1,88 +0,0 @@ -* 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 - diff --git a/doc/make-vm-stackier.org b/doc/make-vm-stackier.org index 80cc10b..cebd8a4 100644 --- a/doc/make-vm-stackier.org +++ b/doc/make-vm-stackier.org @@ -7,62 +7,94 @@ 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. +- new instructions: + + ~(tail-call /n/)~ + + ~(call /n/)~ + + ~(load /r/ /n/)~ + + ~(return /n/)~ * scratchpad -** Scheme source - #+begin_src scheme -(* 2 (call/cc - (λ (cc) - (begin (cc 6) - 3)))) + (letrec ((fac (λ (n) + (if (zero? n) + 1 + (* n (fac (- n 1))))))) + (fac 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))))))) + (λ (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 -** stack VM +#+begin_example +n ktail1 +| | +| | x0 +| | | +| | ^ +| | +| | x1 +| | | +| | ^ +| | +| | x2 +| | | +^ ^ ^ +#+end_example #+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 $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 (push! 1) ; [ $fac-c0 n $fac ktail1 ] + (return 1)) ; [ 1 $fac-c0 n $fac 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 $k0 - (pop! %_) ; [ _ ret ] - (push! 3) ; [ ret ] - (tail-call 1) ; [ 3 ret ] - ) + (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 $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 $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 $main - (pop! %ktail0) ; [ ret ] - (prim %x1 (call/cc $with-cc)) ; [] - (prim %x2 (* 2 %x1)) ; [] - (push! %ktail0) ; [] - (push! %x2) ; [ ret ] - (tail-call 1) ; [ %x2 ret ] - ) + (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 diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e5bdfbf..e7137e5 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/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 "#" :- t) (const . Left $ mempty) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 28badd9..9aa7fd9 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/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 diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index c30db67..8c2f695 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/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 = "" + { activeRoutine = "" } } @@ -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)) +|] diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index 205f047..6b1426a 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -7,6 +7,7 @@ import Gyehoek.Stack.Syntax import Gyehoek.Stack.VM qualified as Sut import Data.List (List) import Gyehoek.Jalmot +import Gyehoek.Prelude (i) evalsTo :: List Obj -> Program -> Assertion @@ -14,7 +15,7 @@ evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs test_root = testGroup "stack machine" [ testCase "immediate halt" do - evalsTo [ObjImm (ImmInt 3)] [stkP| + evalsTo [] [stkP| (define $start (return 0)) |] @@ -24,59 +25,89 @@ test_root = testGroup "stack machine" (push! 3) (return 1)) |] - -- , 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 + , testCase "non-tail identity function" do + evalsTo [ObjImm (ImmInt 123)] [stkP| + (define $id + (return 1)) + (define $c + (return 1)) + (define $start + (push! $c) + (push! $id) + (push! 123) + (call 1)) + |] + , testCase "tail identity function" do + evalsTo [ObjImm (ImmInt 123)] [stkP| + (define $id + (return 1)) + (define $start + (push! $id) + (push! 123) + (tail-call 1)) + |] + , testCase "return constant" do + evalsTo [ObjImm (ImmInt 123)] [stkP| + (define $start + (push! $silly) + (tail-call 1)) + (define $silly + (push! 123) + (return 1)) + |] + , testCase "return multiple" do + evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP| + (define $start + (push! 3) + (push! 2) + (push! 1) + (return 3)) + |] + , testCase "return none" do + evalsTo [] [stkP| + (define $start + (return 0)) + |] + , testCase "square" do + evalsTo [ObjImm (ImmInt 16)] [stkP| + (define $start + (push! $square) + (push! 4) + (tail-call 1)) + (define $square + (pop! %x) + (prim %x2 (* %x %x)) + (push! %x2) + (return 1)) + |] + , testGroup "factorial" + let + hsfac (n :: Int) = foldr @List (*) (1) [1..n] + 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)) + |] + mkcase n = testCase [i|#{n}|] do + evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n + -- 20 is the greatest `n` for which n! ≤ maxBount @Int + in [ mkcase n | n <- [0,1,6,20] ] ]