@@ -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
|
||||
|
||||
+75
-43
@@ -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
|
||||
|
||||
|
||||
@@ -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 "#<procedure>" :- t)
|
||||
(const . Left $ mempty)
|
||||
|
||||
@@ -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
|
||||
|
||||
+136
-51
@@ -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 = "<nowhere>"
|
||||
{ activeRoutine = "<nowhere>"
|
||||
}
|
||||
}
|
||||
|
||||
@@ -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))
|
||||
|]
|
||||
|
||||
@@ -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] ]
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user