msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

ughhh evaluate cps

Browse Source
This commit is contained in:
msyds
2026-09-05 20:22:07 -06:00
parent ba5dc401d9
commit 9f37d10e4f
12 changed files with 340 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files
golden/exec/lit-int/exec
+2
View File
@@ -0,0 +1,2 @@
ret > ExitSuccess
out > 123
golden/exec/lit-int/source.scm
+1
View File
@@ -0,0 +1 @@
123
src/Gyehoek/CPS/Eval.hs
+124 -10
View File
@@ -1,33 +1,147 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
module Gyehoek.CPS.Eval
( evalProgram
, module Gyehoek.CPS.Syntax
, evalExp
) where
import Gyehoek.CPS.Syntax
import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
import Control.Lens
import Data.Maybe (fromMaybe)
import Text.Show.Functions ()
import qualified Data.HashMap.Strict as H
import Gyehoek.Prelude
import Debug.Pretty.Simple
import Gyehoek.Jalmot
import Control.Monad.Cont qualified as Cont
import Gyehoek.Sexp qualified as S
import GHC.Generics (Generically(..))
import Gyehoek.Sexp ((:-)(..))
data Env = MkEnv
{ vars :: HashMap Name Obj
, labels :: HashMap Name (Env, Abs)
{ store :: HashMap Name Obj
}
deriving (Show, Generic)
deriving stock (Show, Generic, Data, Eq)
deriving (Semigroup, Monoid)
via Generically Env
eval :: Env -> Exp -> List Obj
eval = _
emptyEnv = MkEnv
{ store = mempty
}
evalExp :: Exp -> List Obj
evalExp = _
evalProgram :: Program -> List Obj
evalProgram (MkProgram lam) = eval emptyEnv [cps|
data Obj
= ObjImm Imm
| ObjHob Hob
deriving stock (Show, Generic, Data, Eq)
-- | a heap object.
data Hob
= HobClosure { code :: Abs, env :: Env}
-- should a continuation have a label, or an Obj?
| HobPair Obj Obj
deriving stock (Show, Generic, Data, Eq)
instance S.DatumIso Obj where
datumIso = S.match
$ S.With (S.datumIso @Imm >>>)
$ S.With (S.datumIso @Hob >>>)
$ S.End
instance S.DatumIso Hob where
datumIso = S.match
$ S.With (closure >>>)
$ S.With (conspair >>>)
$ S.End
where
conspair = S.dottedList (S.el S.datumIso) S.datumIso
-- closures can be printed, but not parsed.
closure :: S.G (S.Datum :- t) (Env :- Abs :- t)
closure = S.Flip $ S.PartialIso
(\(_:-_:-t) -> S.Unreadable [i|\#<procedure>|] :- t)
(const . Left $ mempty)
err :: Jalmot :> es => Text -> Eff es a
err = throwError . VMError
eval1 :: Jalmot :> es => Env -> Exp -> Eff es Obj
eval1 g e = eval g e >>= \case
[r] -> pure r
rs -> err [i|expected one value, but got #{rs}|]
pure1 :: Applicative f => a -> f (List a)
pure1 = pure . (:[])
eval
:: Jalmot :> es
=> Env -> Exp
-> Eff es (List Obj)
eval g (ExpLetRec bs e) = eval g' e
where
g' = g <> foldMap
(\(f,ab) -> mempty & #store . at f ?~
ObjHob (HobClosure ab g'))
bs
eval g (Halt rs) = traverse (evalVal g) rs
eval g (ExpContinue k xs) = evalVal g k >>= \case
ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs
eval g (ExpApply f xs ktail) = do
f' <- evalVal g f
xs' <- traverse (evalVal g) xs
ktail' <- evalKexp g ktail
case f' of
ObjHob (HobClosure {code,env}) -> eval env' e
where
MkAbs bxs bktail e = code
env' = env
& #store <>~ H.fromList (zip bxs xs')
& maybe id (\b -> #store . at b ?~ ktail') bktail
eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|]
evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
evalKexp g = \case
KexpVar x -> var g x
KexpKappa kap -> _
evalVal
:: Jalmot :> es
=> Env -> Val
-> Eff es Obj
evalVal g (ValImm imm) = pure $ ObjImm imm
evalVal g (ValVar x) = var g x
var :: Jalmot :> es => Env -> Name -> Eff es Obj
var _ "halt" = pure . ObjImm . ImmLabel $ "halt"
var g x = case g ^. #store . at x of
Just o -> pure o
Nothing -> err [i|unbound var #{x}|]
evalExp :: Jalmot :> es => Exp -> Eff es (List Obj)
evalExp e = eval emptyEnv e
evalProgram :: Jalmot :> es => Program -> Eff es (List Obj)
evalProgram (MkProgram lam) = evalExp [cps|
(letrec ((start #{lam}))
(start halt))
|]
p :: Program
p = [cps|
(λ (ktail)
(continue ktail 123))
|]
e1 :: Exp
e1 = [cps|
(continue $halt 123)
|]
src/Gyehoek/CPS/Syntax.hs
+10 -2
View File
@@ -44,6 +44,7 @@ module Gyehoek.CPS.Syntax
, absBody
, pattern MkAbs
, _MkAbs
, unhoist
)
where
@@ -64,6 +65,7 @@ import Data.String (IsString)
import Control.Applicative
import qualified Data.HashMap.Strict as H
import GHC.Records (HasField (..))
import Data.Bifunctor
-- Data types
@@ -139,8 +141,8 @@ _MkAbs = iso
Nothing -> AbsKappa' xs e)
pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
pattern MkAbs xs ktail body <- (view _Abs' -> (xs,ktail,body))
where MkAbs xs ktail body = review _Abs' (xs,ktail,body)
pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
{-# COMPLETE MkAbs #-}
@@ -223,6 +225,12 @@ absBody = lens
(AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
(AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
unhoist :: HoistedProgram -> Program
unhoist p =
MkProgram $ p.body & body %~ ExpLetRec
(p ^.. #bindings . itraversed . withIndex
. to (\(MkLabel l, ab) -> (l,ab)))
-- DatumIso instances
src/Gyehoek/Driver.hs
+14 -8
View File
@@ -1,5 +1,5 @@
module Gyehoek.Driver
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e)
where
import Gyehoek.Options
@@ -120,13 +120,13 @@ driver opts = do
hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
cps <- convertProgram scm
when opts.dumpCPS do
hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
S.writeDatum cps
closedCps <- closeProgram cps
when opts.dumpClosed do
hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
S.writeData closedCps
hoistedCps <- hoistProgram closedCps
when opts.dumpHoisted do
hPutStrLn FS.stdout =<< S.encodeWith S.datumIso hoistedCps
S.writeData hoistedCps
-- contifiedCps <- contifyProgram hoistedCps
-- when opts.dumpContified do
-- hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
@@ -138,10 +138,8 @@ driver opts = do
>>> T.unwords
>>> hPutStrLn FS.stdout)
when (rt_is #CPS) do
closedCps
& CPS.evalProgram
& S.encodeDataWith S.dataIso
& hPutStrLn FS.stdout
CPS.evalProgram closedCps
>>= S.writeData
-- dumpOrRun opts.inspectWasm (rt_is #Wasm)
-- (lowerProgram cps)
-- inspectWasm
@@ -165,3 +163,11 @@ eval_e2e :: FilePath -> IO (List Obj)
eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
eval stk
eval_cps_e2e :: FilePath -> IO Text
eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
readScm fp
>>= convertProgram
-- >>= closeProgram
>>= CPS.evalProgram
>>= pure . S.encodeOrShowData' S.dataIso
src/Gyehoek/Options.hs
+5
View File
@@ -32,6 +32,7 @@ data Options = MkOptions
, dumpHoisted :: Bool
, dumpContified :: Bool
, traceStackified :: Bool
, noColour :: Bool
, runtime :: Maybe Runtime
, inspectWasm :: Bool
, output :: FilePath
@@ -66,6 +67,10 @@ parser = do
dumpHoisted <- switch (long "dump-hoisted")
dumpContified <- switch (long "dump-contified")
traceStackified <- switch (long "trace-stackified")
noColour <- switch . fold $
[ long "no-colour"
, long "no-color"
]
inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
runtime <- option runtimeReader . fold $
[ long "runtime"
src/Gyehoek/Sexp/Grammar.hs
+37
View File
@@ -15,6 +15,7 @@ module Gyehoek.Sexp.Grammar
, encodeDataTest
, encodeDataTestColour
, encodeOrShow'
, encodeOrShowData'
, decodeDataWith
, encodeDataWith'
, decodeTest
@@ -28,6 +29,8 @@ module Gyehoek.Sexp.Grammar
, fromDatumUnsafe
, Control.Category.id
, fromDataUnsafe
, writeDatum
, writeData
)
where
@@ -45,6 +48,7 @@ import qualified Control.Category
import qualified Data.Vector as V
import Data.String (IsString (fromString))
import qualified Data.Text as T
import System.Environment (lookupEnv)
toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -126,6 +130,39 @@ encodeOrShow' g x = fromString $
Left _ -> show x
Right t -> T.unpack t
encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
encodeOrShow g x = fromString $
case runPureEff . runJalmot . encodeWith' g $ x of
Left _ -> show x
Right t -> T.unpack t
encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
encodeOrShowData' g x = fromString $
case runPureEff . runJalmot . encodeDataWith' g $ x of
Left _ -> show x
Right t -> T.unpack t
encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
encodeOrShowData g x = fromString $
case runPureEff . runJalmot . encodeDataWith g $ x of
Left _ -> show x
Right t -> T.unpack t
useColour :: IO Bool
useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
writeDatum x = do
c <- liftIO useColour
let f = if c then encodeOrShow else encodeOrShow'
liftIO . TIO.putStrLn . f datumIso $ x
writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
writeData x = do
c <- liftIO useColour
let f = if c then encodeOrShowData else encodeOrShowData'
liftIO . TIO.putStrLn . f dataIso $ x
class DatumIso a where
datumIso :: DatumGrammar a
test/Gyehoek/Test/CPS/Eval.hs
+65 -46
View File
@@ -5,53 +5,72 @@ import Test.Tasty.HUnit
import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
import Gyehoek.CPS.Eval qualified as Sut
import Data.List (List)
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
import System.Directory (listDirectory)
import Test.Tasty.Silver
import System.FilePath
import Control.Exception
import qualified Gyehoek.Driver as Driver
import Control.DeepSeq (($!!))
import System.Exit (ExitCode(..))
import qualified Data.Text as T
import Data.Function (applyWhen)
import Gyehoek.Prelude
test_cpsInterpreter =
ignoreTestBecause "i forgorrrr" $
testGroup "cps interpreter" $
[ primitives
, testCase "halt with constant" do
evalsTo [ObjImm (ImmInt 123)] [cps|
(continue halt 123)
|]
, testCase "identity cont" do
evalsTo [ObjImm (ImmInt 154)] [cps|
(letrec ((id (κ (x)
(continue halt x))))
(continue id 154))
|]
, testCase "identity function" do
evalsTo [ObjImm (ImmInt 456)] [cps|
(letrec ((id (λ (x ktail)
(continue ktail x))))
(id 456 halt))
|]
, testCase "square" do
evalsTo [ObjImm (ImmInt 81)] [cps|
(letrec ((square (λ (x ktail)
(prim (* x x)
(κ (r) (continue ktail r))))))
(square 9 halt))
|]
]
brokenEvalTests :: List String
brokenEvalTests =
[]
-- [ "adder"
-- , "apply2"
-- , "apply-twice"
-- , "arith"
-- , "begin-1"
-- , "callcc-constant"
-- , "callcc-discard"
-- , "callcc-early-exit-1"
-- , "callcc-early-exit-2"
-- , "callcc-early-exit-3"
-- , "callcc-early-exit-4"
-- , "callcc-early-exit-5"
-- , "callcc-early-exit-6"
-- , "callcc-nested-1"
-- , "callcc-nested-2"
-- , "complicated-1"
-- , "cons-1"
-- , "factorial"
-- , "false"
-- , "fn-of-fn"
-- , "if-false"
-- , "if-number"
-- , "if-true"
-- , "lambda"
-- , "letrec-fn"
-- , "let-fn"
-- , "lit-int"
-- , "square"
-- , "true"
-- ]
evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
evalsTo rs e = Sut.evalExp e @?= rs
test_eval :: IO TestTree
test_eval = do
cs <- listDirectory "golden/exec"
<&> fmap ("golden/exec" </>)
pure $ testGroup "cps interpreter" $ cpsCase <$> cs
primitives = testGroup "primitives"
[ testGroup "arith"
[ testCase "basic 1" do
evalsTo [ObjImm (ImmInt 20)] [cps|
(prim (* 4 5)
(κ (x) (continue halt x)))
|]
, testCase "basic 2" do
evalsTo [ObjImm (ImmInt 35)] [cps|
(prim (* 2 16)
(κ (x) (prim (+ x 3)
(κ (r) (continue halt r)))))
|]
]
]
maybeBroken name broken = applyWhen (name `elem` broken) expectFail
cpsCase :: FilePath -> TestTree
cpsCase test =
maybeBroken testName brokenEvalTests $
goldenVsAction testName resultFile action printProcResult
where
testName = takeFileName test
resultFile = test </> "exec"
sourceFile = test </> "source.scm"
action = catch @SomeException
(do r <- Driver.eval_cps_e2e sourceFile
pure $!! ( ExitSuccess
, r
, "" ))
\e -> pure (ExitFailure 1, "", T.pack $ displayException e)
test/Gyehoek/Test/CPS/Stackify.hs
+76 -75
View File
@@ -10,86 +10,87 @@ import Gyehoek.GenSym (runGenSym)
import Effectful
import Gyehoek.Prelude
import Gyehoek.Jalmot
import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
test_stackify =
[ trivialReturn
, tailCall
, prim
, condition
, procedure
]
-- test_stackify =
-- [ trivialReturn
-- , tailCall
-- , prim
-- , condition
-- , procedure
-- ]
evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
where
e' = e & Sut.stackifyProgram & runGenSym & runPureEff
-- evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
-- evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
-- where
-- e' = e & Sut.stackifyProgram & runGenSym & runPureEff
trivialReturn = testGroup "trivial return"
[ testCase "return int" do
evalsTo [ObjImm (ImmInt 4)]
[cps|(λ (ktail) (continue ktail 4))|]
, testCase "return bool" do
evalsTo [ObjImm (ImmBool True)]
[cps|(λ (ktail) (continue ktail #t))|]
evalsTo [ObjImm (ImmBool False)]
[cps|(λ (ktail) (continue ktail #f))|]
]
-- trivialReturn = testGroup "trivial return"
-- [ testCase "return int" do
-- evalsTo [ObjImm (ImmInt 4)]
-- [cps|(λ (ktail) (continue ktail 4))|]
-- , testCase "return bool" do
-- evalsTo [ObjImm (ImmBool True)]
-- [cps|(λ (ktail) (continue ktail #t))|]
-- evalsTo [ObjImm (ImmBool False)]
-- [cps|(λ (ktail) (continue ktail #f))|]
-- ]
tailCall = testGroup "tail call"
[ testCase "square" do
evalsTo [ObjImm (ImmInt 16)] [cps|
(λ (ktail0)
(letrec ((square (λ (x ktail)
(prim (* x x)
(κ (x0) (continue ktail x0))))))
(square 4 halt)))
|]
]
-- tailCall = testGroup "tail call"
-- [ testCase "square" do
-- evalsTo [ObjImm (ImmInt 16)] [cps|
-- (λ (ktail0)
-- (letrec ((square (λ (x ktail)
-- (prim (* x x)
-- (κ (x0) (continue ktail x0))))))
-- (square 4 halt)))
-- |]
-- ]
prim = testGroup "prim"
[ testCase "multiply" do
evalsTo [ObjImm (ImmInt 20)]
[cps|(λ (ktail0)
(prim (* 4 5)
(κ (x) (continue ktail0 x))))|]
, testCase "add" do
evalsTo [ObjImm (ImmInt 9)]
[cps|(λ (ktail0)
(prim (+ 4 5)
(κ (x) (continue ktail0 x))))|]
-- , testGroup "call/cc"
-- [ testCase "trivial" do
-- evalsTo [ObjImm (ImmInt 123)]
-- [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
-- (prim (call/cc f)))|]
-- ]
]
-- prim = testGroup "prim"
-- [ testCase "multiply" do
-- evalsTo [ObjImm (ImmInt 20)]
-- [cps|(λ (ktail0)
-- (prim (* 4 5)
-- (κ (x) (continue ktail0 x))))|]
-- , testCase "add" do
-- evalsTo [ObjImm (ImmInt 9)]
-- [cps|(λ (ktail0)
-- (prim (+ 4 5)
-- (κ (x) (continue ktail0 x))))|]
-- -- , testGroup "call/cc"
-- -- [ testCase "trivial" do
-- -- evalsTo [ObjImm (ImmInt 123)]
-- -- [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
-- -- (prim (call/cc f)))|]
-- -- ]
-- ]
condition = testCase "if" do
evalsTo [ObjImm (ImmInt 123)]
[cps|(λ (ktail0)
(if #t (continue ktail0 123) (continue ktail0 456)))|]
evalsTo [ObjImm (ImmInt 456)]
[cps|(λ (ktail0)
(if #f (continue ktail0 123) (continue ktail0 456)))|]
-- condition = testCase "if" do
-- evalsTo [ObjImm (ImmInt 123)]
-- [cps|(λ (ktail0)
-- (if #t (continue ktail0 123) (continue ktail0 456)))|]
-- evalsTo [ObjImm (ImmInt 456)]
-- [cps|(λ (ktail0)
-- (if #f (continue ktail0 123) (continue ktail0 456)))|]
procedure = testGroup "procedure"
[ testCase "factorial" do
evalsTo [ObjImm (ImmInt 720)]
[cps|(λ (ktail0)
(letrec ((fac (λ (n ktail)
(prim (zero? n)
(κ (x0)
(if x0
(continue ktail 1)
(prim (- n 1)
(κ (x1)
(letrec ((fac-k0
(κ (x2)
(prim (* n x2)
(κ (x3)
(continue ktail x3))))))
(fac x1 fac-k0))))))))))
(fac 6 halt)))|]
]
-- procedure = testGroup "procedure"
-- [ testCase "factorial" do
-- evalsTo [ObjImm (ImmInt 720)]
-- [cps|(λ (ktail0)
-- (letrec ((fac (λ (n ktail)
-- (prim (zero? n)
-- (κ (x0)
-- (if x0
-- (continue ktail 1)
-- (prim (- n 1)
-- (κ (x1)
-- (letrec ((fac-k0
-- (κ (x2)
-- (prim (* n x2)
-- (κ (x3)
-- (continue ktail x3))))))
-- (fac x1 fac-k0))))))))))
-- (fac 6 halt)))|]
-- ]
test/Gyehoek/Test/CPS/Syntax.hs
+2 -2
View File
@@ -46,9 +46,9 @@ qq = testGroup "parser"
, testCase "application" do
assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
[Sut.ValVar "x",Sut.ValVar "y"]
"k")
(Sut.KexpVar "k"))
[cps|(f x y k)|]
assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
[] "k")
[] (Sut.KexpVar "k"))
[cps|(f k)|]
]
test/Gyehoek/Test/Golden.hs
+2 -1
View File
@@ -40,7 +40,8 @@ test_root = do
testGroup "execution" <$> sequenceA
[ ignoreTestBecause "wasm codegen is on the backburner"
<$> wasmTests tests
, stackifyTests tests
, ignoreTestBecause "i'm killing myself"
<$> stackifyTests tests
]
maybeBroken name broken = applyWhen (name `elem` broken) expectFail
test/Gyehoek/Test/Stack/VM.hs
+2 -1
View File
@@ -8,12 +8,13 @@ import Gyehoek.Stack.VM qualified as Sut
import Data.List (List)
import Gyehoek.Jalmot
import Gyehoek.Prelude (i)
import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
evalsTo :: List Obj -> Program -> Assertion
evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
test_root = testGroup "stack machine"
test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine"
[ testCase "immediate halt" do
evalsTo [] [stkP|
(define $start