From 10d449a0b5a4686a8b60470cd8cd0d47e18a7000 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Tue, 18 Aug 2026 03:21:42 -0600 Subject: [PATCH] more stackification --- gyehoek.cabal | 2 + src/Gyehoek/CPS/Stackify.hs | 30 ++++++++++++--- src/Gyehoek/Driver.hs | 31 ++++++++++++--- src/Gyehoek/Options.hs | 10 +++-- src/Gyehoek/Scheme/Syntax.hs | 18 ++++----- src/Gyehoek/Sexp.hs | 34 +++++++++++++++++ src/Gyehoek/Stack/Syntax.hs | 63 ++++++++++++++++++++++++++++++- src/Gyehoek/Stack/VM.hs | 10 ++++- test/Gyehoek/Test/CPS/Stackify.hs | 27 +++++++++++++ test/Gyehoek/Test/Golden.hs | 44 +++++++++++++++++---- test/Main.hs | 4 +- 11 files changed, 236 insertions(+), 37 deletions(-) diff --git a/gyehoek.cabal b/gyehoek.cabal index 3c61a5d..1a16e8f 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -119,9 +119,11 @@ test-suite test , gyehoek , lens , process-extras + , text , sexp-grammar , tasty , tasty-hunit , tasty-silver + , tasty-expected-failure default-language: GHC2024 diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 5b7ab4b..ac01d5f 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -20,6 +20,8 @@ import GHC.Generics (Generic) import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H +import Data.HashSet.Lens (hashMap) +import Data.List (List) type Stackify = Writer Stk.Program @@ -31,16 +33,31 @@ stackify :: (GenSym :> es, Stackify :> es) => Env -> Exp -> Eff es (Seq Stk.Instr) +stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do + let vs = (f, Stk.ValLabel f) : (bindReg <$> xs) + let live = free' kap & filter (`H.member` g.bound) + m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> live))) m + tell [Stk.MkBlock f xs $ + [Stk.Pop x | x <- live] <> toList m'] + stackify (g & #bound . at f ?~ Stk.ValLabel f) e + stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do - let xs' = (k:xs) <&> \x -> (x, Stk.ValReg x) - m' <- stackify (g & #bound .~ H.fromList xs') m + let vs = (k:xs) <&> \x -> (x, Stk.ValReg x) lam_body <- gensym' "lambda-body" + m' <- stackify (g & #bound .~ H.fromList vs + & #bound . at f ?~ Stk.ValLabel lam_body) m tell [Stk.MkBlock lam_body xs . toList $ - [Stk.PopCont "ktail"] <> m'] + -- this is probably evil and wrong. + [Stk.PopCont k] <> m'] stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) e +stackify g (ExpIf c t f) = do + t' <- stackify g t + f' <- stackify g f + pure [ Stk.If (stackifyVal g c) (toList t') (toList f') ] + stackify g (ExpApply f xs ktail) = do - pure [ Stk.PushCont ktail + pure [ Stk.PushCont (var g ktail) , Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ] @@ -66,6 +83,9 @@ var g v = case g ^. #bound . at v of Just x -> x Nothing -> Stk.ValLabel v +bindReg :: Name -> (Name, Stk.Val) +bindReg x = (x, Stk.ValReg x) + data Env = MkEnv @@ -81,7 +101,7 @@ emptyEnv = MkEnv mempty stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program stackifyExp lbl e = do (code,p) <- runStackify $ stackify emptyEnv e - pure $ p <> Stk.MkProgram [ Stk.MkBlock lbl [] (code ^.. each) ] + pure $ p <> Stk.MkProgram [ Stk.MkBlock lbl [] (toList code) ] stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program stackifyProgram (MkProgram e) = stackifyExp "main" e diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 9ddbd63..788b07c 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,5 +1,5 @@ module Gyehoek.Driver - (main, lower_e2e, convert_e2e, parse_e2e, readScm) + (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e) where import Gyehoek.Options @@ -28,6 +28,12 @@ import System.Environment.Blank (getEnvDefault) import GHC.Conc (atomically) import qualified Data.Text.IO as TIO import qualified Data.ByteString.Lazy as BS +import Gyehoek.CPS.Stackify (stackifyProgram) +import Text.Pretty.Simple (pShow) +import Gyehoek.Stack.VM (eval, writeObj, Obj) +import qualified Data.Text as T +import Data.List (List) +import Gyehoek.Stack.Syntax (encodeProgram) main :: IO () @@ -101,11 +107,19 @@ driver opts = do cps <- convertProgram scm when opts.dumpCPS do hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right - wat <- lowerProgram cps - withFile opts.output FS.WriteMode \h -> - hPutStrLn h wat - when opts.inspectWasm do - inspectWasm wat + stk <- stackifyProgram cps + if opts.dumpStackified then do + hPutStrLn FS.stdout . encodeProgram $ stk + else if opts.stackify then do + eval stk & fmap writeObj + & T.unwords + & hPutStrLn FS.stdout + else do + wat <- lowerProgram cps + withFile opts.output FS.WriteMode \h -> + hPutStrLn h wat + when opts.inspectWasm do + inspectWasm wat parse_e2e :: FilePath -> IO Scm.Program parse_e2e = runEff . runFileSystem . readScm @@ -117,3 +131,8 @@ lower_e2e :: FilePath -> IO Text lower_e2e = runEff . runFileSystem . runGenSym . (lowerProgram <=< convertProgram <=< readScm) + +eval_e2e :: FilePath -> IO (List Obj) +eval_e2e fp = runEff . runFileSystem . runGenSym $ do + stk <- stackifyProgram <=< convertProgram <=< readScm $ fp + pure . eval $ stk diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 64243c9..20bae6f 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -15,10 +15,10 @@ import GHC.Generics (Generic) data Options = MkOptions - { -- dumpANF :: Maybe FilePath - -- , dumpQBE :: Maybe FilePath - dumpCPS :: Bool + { dumpCPS :: Bool , dumpParsed :: Bool + , dumpStackified :: Bool + , stackify :: Bool , inspectWasm :: Bool , output :: FilePath , sourceFile :: FilePath @@ -49,6 +49,8 @@ parseOutput = strOption ) parseDumpCPS = switch (long "dump-cps") +parseDumpStackified = switch (long "dump-stackified") +parseStackify = switch (long "stackify") parseDumpParsed = switch (long "dump-parsed") parseInspectWasm = switch $ long "inspect-wasm" <> short 'p' @@ -56,6 +58,8 @@ parser :: Parser Options parser = MkOptions <$> parseDumpCPS <*> parseDumpParsed + <*> parseDumpStackified + <*> parseStackify <*> parseInspectWasm <*> parseOutput <*> argument str (metavar "FILE") diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index e36b655..cd8a956 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -8,6 +8,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OrPatterns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveAnyClass #-} module Gyehoek.Scheme.Syntax ( Name(..) , Prim(..) @@ -36,7 +37,7 @@ import Language.SexpGrammar qualified as Sexp import Language.Sexp.Located qualified as S import Language.SexpGrammar.Generic import Effectful -import GHC.Generics +import GHC.Generics (Generic) import Prelude hiding ((.), id) import Control.Category import Data.List.NonEmpty (NonEmpty) @@ -61,6 +62,10 @@ import qualified Effectful.FileSystem.IO.ByteString as FB newtype Name = MkName { inner :: Text } deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable) deriving stock (Generic, Data) + deriving anyclass (Wrapped) + +instance Prefixed Name where + prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped' getName :: Name -> Text getName (MkName x) = x @@ -183,19 +188,10 @@ instance SexpIso Lit where sexpIso = match $ With (. sexpIso) $ With (. sym "nil") - $ With (. bool) + $ With (. Gyehoek.Sexp.schemeBool) $ With (. sexpIso) $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso) $ End - where - bool :: Sexp.SexpGrammar Bool - bool = Sexp.hashed $ Sexp.partialOsi f g - where - f (S.Symbol ("t";"true")) = Right True - f (S.Symbol ("f";"false")) = Right False - f _ = Left $ Sexp.expected "bool" - g True = S.Symbol "true" - g False = S.Symbol "false" instance SexpIso Sexp where sexpIso = match diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index a8c0066..7f62fcc 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -44,6 +44,11 @@ module Gyehoek.Sexp , equivalent , encodeOrShow , readSxs + , prismIso + , schemeBool + , headTagged1' + , headTagged1 + , headTagged2 ) where @@ -238,12 +243,41 @@ lambda name e = list $ isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t) isoIso l = Sexp.iso (view l) (review l) +prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t) +prismIso mm p = Sexp.partialOsi + (maybe (Left mm) Right . preview p) + (review p) + kappaKeyword :: Grammar Position (Sexp :- t) t kappaKeyword = coproduct [ sym "κ", sym "kappa" ] lambdaKeyword :: Grammar Position (Sexp :- t) t lambdaKeyword = coproduct [ sym "λ", sym "lambda" ] +schemeBool :: SexpGrammar Bool +schemeBool = Sexp.hashed $ Sexp.partialOsi f g + where + f (SL.Symbol ("t";"true")) = Right True + f (SL.Symbol ("f";"false")) = Right False + f _ = Left $ Sexp.expected "bool" + g True = SL.Symbol "true" + g False = SL.Symbol "false" + +headTagged1 :: Text -> SexpGrammar a -> Grammar Position (Sexp :- t) (a :- t) +headTagged1 s g1 = list $ el (sym s) >>> el g1 + +headTagged1' + :: Text + -> SexpGrammar a -> SexpGrammar b + -> Grammar Position (Sexp :- t) (List b :- a :- t) +headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt + +headTagged2 + :: Text + -> SexpGrammar a -> SexpGrammar b + -> Grammar Position (Sexp :- t) (b :- a :- t) +headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2 + class UglySexpIso a where diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 1cd3b1f..d024099 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} module Gyehoek.Stack.Syntax ( Program(..) , Block(..) @@ -11,6 +12,7 @@ module Gyehoek.Stack.Syntax , Prim(..) , Name , pattern ValLabel + , encodeProgram ) where import Control.Lens @@ -29,6 +31,7 @@ import qualified Data.HashMap.Strict as H import Effectful import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..)) import GHC.Exts (IsList(..)) +import Data.List (intersperse) newtype Program = MkProgram @@ -56,7 +59,7 @@ data Instr = Pop Name | Push Val | PopCont Name - | PushCont Name + | PushCont Val | Prim Name (Prim Val) | Call Val (List Val) | If Val (List Instr) (List Instr) @@ -79,3 +82,61 @@ data Imm data Obj = ObjImm Imm deriving (Show, Generic, Data, Eq) + + +--- sexp work + +pure [] + +instance SexpIso Instr where + sexpIso = match + $ With (Gyehoek.Sexp.headTagged1 "pop!" regName >>>) + $ With (Gyehoek.Sexp.headTagged1 "push!" S.sexpIso >>>) + $ With (Gyehoek.Sexp.headTagged1 "pop-cont!" regName >>>) + $ With (Gyehoek.Sexp.headTagged1 "push-cont!" S.sexpIso >>>) + $ With (Gyehoek.Sexp.headTagged2 "prim" regName S.sexpIso >>>) + $ With (Gyehoek.Sexp.headTagged1' "call" S.sexpIso S.sexpIso >>>) + $ With (if_ >>>) + $ End + where + if_ = S.list $ S.el (S.sym "if") + >>> S.el (S.sexpIso @Val) + >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.sexpIso @Instr)) + >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.sexpIso @Instr)) + +instance SexpIso Val where + sexpIso = match + $ With (regName >>>) + $ With (S.sexpIso >>>) + $ End + +instance SexpIso Imm where + sexpIso = match + $ With (S.sexpIso @Int >>>) + $ With (Gyehoek.Sexp.schemeBool >>>) + $ With (labelName >>>) + $ End + +instance SexpIso Block where + sexpIso = with (block >>>) + where + block = S.list $ + S.el (S.sym "define") + >>> S.el (S.list $ S.el labelName >>> S.rest regName) + >>> S.rest (S.sexpIso @Instr) + +encodeProgram :: Program -> Text +encodeProgram p = p.blocks + & fmap ((^?! _Right) . Gyehoek.Sexp.encodePretty) + & intersperse "\n\n" + & mconcat + +regName :: S.SexpGrammar Name +regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso + (S.expected "register") + (prefixed @Name "%") + +labelName :: S.SexpGrammar Name +labelName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso + (S.expected "label") + (prefixed @Name "$") diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index 14a2f72..6faf2f3 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -5,6 +5,7 @@ module Gyehoek.Stack.VM , eval , trace , module Gyehoek.Stack.Syntax + , writeObj ) where import Gyehoek.Stack.Syntax @@ -46,7 +47,7 @@ stepI :: Env -> VM -> Instr -> VM stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :) -stepI e vm (PushCont k) = vm & #kstack %~ (k:) +stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :) stepI e vm (Prim r p) = case evalVal e vm <$> p of PrimZeroP x -> case x of @@ -133,3 +134,10 @@ trace p = initialVM & unfoldr \vm -> Just _ -> Nothing Nothing -> Just (vm, step e vm) where e = initialEnv p + +writeObj :: Obj -> Text +writeObj (ObjImm im) = case im of + ImmInt n -> [i|#{n}|] + ImmBool True -> "#t" + ImmBool False -> "#f" + ImmLabel l -> "#" diff --git a/test/Gyehoek/Test/CPS/Stackify.hs b/test/Gyehoek/Test/CPS/Stackify.hs index 9410e39..d6e0d83 100644 --- a/test/Gyehoek/Test/CPS/Stackify.hs +++ b/test/Gyehoek/Test/CPS/Stackify.hs @@ -15,6 +15,8 @@ root = pure . testGroup "stackify" $ [ trivialReturn , tailCall , prim + , condition + , procedure ] evalsTo :: List Obj -> Sut.Exp -> Assertion @@ -52,3 +54,28 @@ prim = testGroup "prim" [cps|(prim (+ 4 5) (κ (x) (continue halt x)))|] ] + +condition = testCase "if" do + evalsTo [ObjImm (ImmInt 123)] + [cps|(if #t (continue halt 123) (continue halt 456))|] + evalsTo [ObjImm (ImmInt 456)] + [cps|(if #f (continue halt 123) (continue halt 456))|] + +procedure = testGroup "procedure" + [ testCase "factorial" do + evalsTo [ObjImm (ImmInt 720)] + [cps|(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))|] + ] diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 58e1ebb..2782157 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -10,34 +10,62 @@ import System.Directory import Data.Function import System.Environment.Blank (getEnvDefault) import qualified System.Process.Text as PT +import Control.Exception (catches, ErrorCall(..), Handler(..)) +import Gyehoek.Stack.VM (writeObj) +import Data.Text qualified as T +import System.Exit (ExitCode(..)) +import Test.Tasty.ExpectedFailure (expectFail) -disabled :: List String -disabled = - [ +brokenWasmTests :: List String +brokenWasmTests = + [ "adder" + , "apply-twice" + , "square" + , "fn-of-fn" + , "let-fn" + , "apply2" ] root :: IO TestTree root = do all_cases <- listDirectory "golden" let tests = all_cases - & filter (`notElem` disabled) & fmap ("golden") testGroup "golden" <$> sequenceA - [ executionTests tests + [ wasmTests tests + , stackifyTests tests ] -executionTests :: List FilePath -> IO TestTree -executionTests files = do +wasmTests :: List FilePath -> IO TestTree +wasmTests files = do cmd <- getEnvDefault "GYEHOEK_RUNTIME" "runtime/target/debug/gyehoek-runtime" - pure $ testGroup "execution" $ files <&> \test -> + pure $ testGroup "wasm execution" $ files <&> \test -> let testname = takeFileName test scmfile = test "source.scm" resultfile = test "exec" action = do t <- Driver.lower_e2e scmfile PT.readProcessWithExitCode cmd ["-"] t + in applyWhen (testname `elem` brokenWasmTests) expectFail $ + goldenVsAction + testname + resultfile + action + printProcResult + +stackifyTests :: List FilePath -> IO TestTree +stackifyTests files = do + pure $ testGroup "stackified execution" $ files <&> \test -> + let testname = takeFileName test + scmfile = test "source.scm" + resultfile = test "exec" + action = do + rs <- Driver.eval_e2e scmfile + pure ( ExitSuccess + , T.unwords . fmap writeObj $ rs + , "" ) in goldenVsAction testname resultfile diff --git a/test/Main.hs b/test/Main.hs index 2a8b87b..22518ee 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -14,8 +14,8 @@ main = defaultMain =<< root root :: IO TestTree root = testGroup "test" <$> sequenceA - [ {- Gyehoek.Test.Golden.root - ,-} Gyehoek.Test.Sexp.root + [ Gyehoek.Test.Golden.root + , Gyehoek.Test.Sexp.root , Gyehoek.Test.CPS.Syntax.root , Gyehoek.Test.Stack.VM.root , Gyehoek.Test.CPS.Stackify.root