more stackification

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

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)
+  let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
-  m' <- stackify (g & #bound .~ H.fromList xs') m
   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

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
+  stk <- stackifyProgram cps
-  withFile opts.output FS.WriteMode \h ->
+  if opts.dumpStackified then do
-    hPutStrLn h wat
+    hPutStrLn FS.stdout . encodeProgram $ stk
-  when opts.inspectWasm do
+  else if opts.stackify then do
-    inspectWasm wat
+    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

src/Gyehoek/Options.hs

@@ -15,10 +15,10 @@ import GHC.Generics (Generic)
 
 
 data Options = MkOptions
-  { -- dumpANF :: Maybe FilePath
+  { dumpCPS :: Bool
-  -- , dumpQBE :: Maybe FilePath
-  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")

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

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

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 "$")

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 -> "#<procedure>"

test/Gyehoek/Test/CPS/Stackify.hs

@@ -8,6 +8,7 @@ import Data.List (List)
 import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.GenSym (runGenSym)
 import Effectful
+import Test.Tasty.ExpectedFailure (expectFail)
 
 
 root :: IO TestTree
@@ -15,6 +16,8 @@ root = pure . testGroup "stackify" $
   [ trivialReturn
   , tailCall
   , prim
+  , condition
+  , procedure
   ]
 
 evalsTo :: List Obj -> Sut.Exp -> Assertion
@@ -52,3 +55,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"
+  [ expectFail $ 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))|]
+  ]

test/Gyehoek/Test/Golden.hs

@@ -10,35 +10,76 @@ 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
+brokenWasmTests :: List String
-disabled =
+brokenWasmTests =
-  [
+  [ "adder"
+  , "apply-twice"
+  , "square"
+  , "fn-of-fn"
+  , "let-fn"
+  , "apply2"
+  ]
+
+brokenStackifyTests :: List String
+brokenStackifyTests =
+  [ "apply-twice"
+  , "adder"
+  , "apply2"
+  , "let-fn"
   ]
 
 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
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
-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 goldenVsAction
+    in maybeBroken testname brokenWasmTests $
+      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 =
+          catches (do rs <- Driver.eval_e2e scmfile
+                      pure ( ExitSuccess
+                           , T.unwords . fmap writeObj $ rs
+                           , "" ))
+            [ Handler \(ErrorCall s) ->
+                pure (ExitFailure 1, "", T.pack s)
+            ]
+    in maybeBroken testname brokenStackifyTests $
+     goldenVsAction
        testname
        resultfile
        action

test/Gyehoek/Test/Stack/VM.hs

@@ -75,7 +75,7 @@ procedure = testGroup "procedure"
                 ]
                 [ Push (ValReg "n")
                 , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
-                , PushCont "fac-k0"
+                , PushCont (ValLabel "fac-k0")
                 , Call (ValLabel "fac") [ValReg "x1"]
                 ]
               ]

test/Main.hs

@@ -14,8 +14,8 @@ main = defaultMain =<< root
 
 root :: IO TestTree
 root = testGroup "test" <$> sequenceA
-  [ {- Gyehoek.Test.Golden.root
+  [ Gyehoek.Test.Golden.root
-  ,-} Gyehoek.Test.Sexp.root
+  , Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
   , Gyehoek.Test.Stack.VM.root
   , Gyehoek.Test.CPS.Stackify.root