From 950d1237607a0a24ab4f457bf62eb84efd26827d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 23 Aug 2026 11:42:14 -0600 Subject: [PATCH] refactor stack vm to use a basic block ish structure --- flake.nix | 1 + golden/print/begin-nonempty-thin | 4 +- golden/print/begin-nonempty-wide | 4 +- golden/print/lambda-thin | 10 +- golden/print/lambda-wide | 4 +- golden/print/null | 2 +- golden/print/rainbow | 2 +- golden/print/simple-list-thin | 4 +- golden/print/simple-list-wide | 2 +- gyehoek.cabal | 17 ++- src/Gyehoek/CPS/Stackify.hs | 56 ++++++---- src/Gyehoek/CPS/Syntax.hs | 24 ++-- src/Gyehoek/Scheme/Syntax.hs | 4 +- src/Gyehoek/Sexp/Grammar.hs | 42 ++++++- src/Gyehoek/Sexp/Grammar/Base.hs | 119 ++++++++++++++++---- src/Gyehoek/Sexp/Print.hs | 10 +- src/Gyehoek/Sexp/Syntax.hs | 1 + src/Gyehoek/Stack/Syntax.hs | 83 +++++++++----- src/Gyehoek/Stack/VM.hs | 51 +++++---- test/Gyehoek/Test/Stack/VM.hs | 182 +++++++++++++++---------------- test/doctest.hs | 16 ++- 21 files changed, 406 insertions(+), 232 deletions(-) diff --git a/flake.nix b/flake.nix index a6cb716..963f54e 100644 --- a/flake.nix +++ b/flake.nix @@ -35,6 +35,7 @@ in '' export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime} export PATH=${lib.makeBinPath bin}:$PATH + export GYEHOEK_IN_NIX_BUILD=1 ''; })]; shell = { diff --git a/golden/print/begin-nonempty-thin b/golden/print/begin-nonempty-thin index 17862c2..e120fc1 100644 --- a/golden/print/begin-nonempty-thin +++ b/golden/print/begin-nonempty-thin @@ -1,4 +1,4 @@ -(begin +(begin 책을 더 - 먹으세요~!) \ No newline at end of file + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/begin-nonempty-wide b/golden/print/begin-nonempty-wide index 17862c2..e120fc1 100644 --- a/golden/print/begin-nonempty-wide +++ b/golden/print/begin-nonempty-wide @@ -1,4 +1,4 @@ -(begin +(begin 책을 더 - 먹으세요~!) \ No newline at end of file + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/lambda-thin b/golden/print/lambda-thin index 78cb74c..f89ad45 100644 --- a/golden/print/lambda-thin +++ b/golden/print/lambda-thin @@ -1,5 +1,5 @@ -(lambda - (어간 - 어미) - (display - 꾸깃)) \ No newline at end of file +(lambda + (어간 + 어미) + (display + 꾸깃)) \ No newline at end of file diff --git a/golden/print/lambda-wide b/golden/print/lambda-wide index b989bcc..fbe0b17 100644 --- a/golden/print/lambda-wide +++ b/golden/print/lambda-wide @@ -1,2 +1,2 @@ -(lambda (어간 어미) - (display 꾸깃)) \ No newline at end of file +(lambda (어간 어미) + (display 꾸깃)) \ No newline at end of file diff --git a/golden/print/null b/golden/print/null index 8af028e..1ec8314 100644 --- a/golden/print/null +++ b/golden/print/null @@ -1 +1 @@ -() \ No newline at end of file +() \ No newline at end of file diff --git a/golden/print/rainbow b/golden/print/rainbow index 9ba5d84..fb059cd 100644 --- a/golden/print/rainbow +++ b/golden/print/rainbow @@ -1 +1 @@ -((((())))) \ No newline at end of file +((((())))) \ No newline at end of file diff --git a/golden/print/simple-list-thin b/golden/print/simple-list-thin index b9fa7cd..73aea8b 100644 --- a/golden/print/simple-list-thin +++ b/golden/print/simple-list-thin @@ -1,4 +1,4 @@ -(가 +(가 나 다 - 라) \ No newline at end of file + 라) \ No newline at end of file diff --git a/golden/print/simple-list-wide b/golden/print/simple-list-wide index c955446..b4745c3 100644 --- a/golden/print/simple-list-wide +++ b/golden/print/simple-list-wide @@ -1 +1 @@ -(가 나 다 라) \ No newline at end of file +(가 나 다 라) \ No newline at end of file diff --git a/gyehoek.cabal b/gyehoek.cabal index 0bab908..b8f4b21 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -156,12 +156,11 @@ test-suite test default-language: GHC2024 -- https://github.com/martijnbastiaan/doctest-parallel/pull/66 --- --- test-suite doctest --- import: ghcstuffs, ghcstuffs-dev --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: doctest.hs --- build-depends: --- , base --- , doctest-parallel >=0.1 +test-suite doctest + import: ghcstuffs, ghcstuffs-dev + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: doctest.hs + build-depends: + , base + , doctest-parallel >=0.1 diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 6d64f41..9cc2921 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -27,16 +27,30 @@ live g e = free' e & filter \x -> x `H.member` g.bound && not (x `elem` g.contStack) +data BlockBuilder + = Code (List Stk.Instr) BlockBuilder + | Tail Stk.Tail + deriving (Show, Generic) + +buildBlock :: BlockBuilder -> Stk.Block +buildBlock = go [] where + go acc (Code xs bb) = go (acc ++ xs) bb + go acc (Tail t) = Stk.MkBlock acc t + +emitRoutine :: Stackify :> es => Stk.Routine -> Eff es () +emitRoutine rt = tell [rt] + stackify :: (GenSym :> es, Stackify :> es) - => Env -> Exp -> Eff es (Seq Stk.Instr) + => Env -> Exp -> Eff es BlockBuilder stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do let vs = (f, Stk.ValLabel f) : (bindReg <$> xs) let ls = live g kap m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m - tell [Stk.MkBlock f xs $ - [Stk.Pop x | x <- ls] <> toList m'] + emitRoutine $ + Stk.MkRoutine f xs . buildBlock $ + Code [Stk.Pop x | x <- ls] m' let g' = g & #bound . at f ?~ Stk.ValLabel f & #liveness . at f ?~ ls stackify g' e @@ -45,19 +59,19 @@ stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do let vs = (k:xs) <&> \x -> (x, Stk.ValReg x) m' <- stackify (g & #bound .~ H.fromList vs & #contStack %~ (k:)) m - tell [Stk.MkBlock f xs . toList $ m'] + emitRoutine $ Stk.MkRoutine f xs (buildBlock m') stackify g 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') ] + let c' = stackifyVal g c + t' <- buildBlock <$> stackify g t + f' <- buildBlock <$> stackify g f + pure . Tail $ Stk.If c' t' f' -stackify g (ExpApply f xs ktail) = do - pure $ - [ Stk.PushCont k ] - <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ] - <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ] +stackify g (ExpApply f xs ktail) = pure $ + Code [ Stk.PushCont k ] $ + Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $ + Tail (Stk.TailCall (stackifyVal g f) (stackifyVal g <$> xs)) where k = var g ktail ls = fold $ (k ^? #ValImm . #ImmLabel) @@ -68,20 +82,20 @@ stackify g (ExpContinue k xs) = -- when a continuation is a return continuation? is this a correct -- test? case elemIndex k g.contStack of - Nothing -> pure [ Stk.Call (Stk.ValLabel k) xs' ] + Nothing -> pure . Tail $ Stk.TailCall (Stk.ValLabel k) xs' Just j -> do - ktail <- gensym' $ k ^. _Wrapped' + ktail <- gensym' @Name $ k ^. _Wrapped' pure $ - Seq.replicate j (Stk.PopCont "_") - <> [ Stk.PopCont ktail - , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs) - ] - + Code (replicate j $ Stk.PopCont "_") $ + Code [Stk.PopCont ktail] $ + Tail (Stk.TailCall (Stk.ValReg ktail) xs') where xs' = stackifyVal g <$> xs stackify g (ExpPrim p (MkKappa [x] e)) = do e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e - pure $ [ Stk.Prim x (stackifyVal g <$> p) ] <> e' + pure $ + Code [ Stk.Prim x (stackifyVal g <$> p) ] $ + e' stackify _ e = error [i|unimplemented exp: #{e}|] @@ -119,7 +133,7 @@ emptyEnv = MkEnv mempty mempty ["halt"] 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 [] (toList code) ] + pure $ p <> [ Stk.MkRoutine lbl [] (buildBlock code) ] stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program stackifyProgram (MkProgram e) = stackifyExp "main" e diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index d2bc692..6cbc227 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -172,7 +172,7 @@ instance S.DatumIso Imm where labelName :: S.DatumGrammar Name labelName = S.coproduct - [ S.datumIso @Name >>> S.prismIso + [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso (S.expected "label") (prefixed @Name "$") , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name) @@ -209,14 +209,11 @@ instance S.DatumIso Lambda where ) instance S.DatumIso Kappa where - datumIso = S.match - $ S.With (. kappa) - $ S.End - where - kappa = S.list $ - S.el S.kappaKeyword - >>> S.el (S.list $ S.rest S.datumIso) - >>> S.el S.datumIso + datumIso = S.with \g -> + S.lambdaLike S.kappaKeyword + (S.list $ S.rest (S.datumIso @Name)) + (S.el $ S.datumIso @Exp) + >>> g instance S.DatumIso Abs where datumIso = S.match @@ -234,8 +231,8 @@ instance S.DatumIso Exp where $ S.End where continue = S.list $ - S.el (S.sym "continue") - >>> S.el S.datumIso + S.el (S.decorate S.SynBuiltin >>> S.sym "continue") + >>> S.el (S.decorate S.SynProcedure >>> S.datumIso) >>> S.rest S.datumIso letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso if_ = S.ifLike "if" @@ -254,8 +251,11 @@ instance S.DatumIso Exp where Right $ karg:- args :- op :- t _ -> Left $ S.expected "continuation arg" )) + -- prim = S.headTagged2 "prim" + -- (primDatumIso id (S.datumIso @Val)) + -- (S.datumIso @Kappa) prim = S.list $ - S.el (S.sym "prim") + S.el (S.decorate S.SynBuiltin >>> S.sym "prim") >>> S.el (primDatumIso id (S.datumIso @Val)) >>> S.el S.datumIso diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 8b85e8d..a8892b2 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -142,7 +142,9 @@ makeBaseFunctor ''Exp instance DatumIso Name where - datumIso = S.symbol >>> S.iso MkName (review _Unwrapped') + datumIso = S.decorate S.SynVariable + >>> S.symbol + >>> S.iso coerce coerce primDatumIso :: (Text -> Text) diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 0188a30..33ba9e1 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -12,24 +12,29 @@ module Gyehoek.Sexp.Grammar , decodeWith , encodeTest , encodeTestColour + , encodeDataTest + , encodeDataTestColour + , encodeOrShow' + , decodeDataWith + , encodeDataWith' , decodeTest + , decodeDataTest , DataIso(..) , DatumIso(..) -- * generics , with , match - , Coproduct (..) + , Coproduct(..) , fromDatumUnsafe , Control.Category.id - , encodeOrShow' - , decodeDataWith + , fromDataUnsafe ) where import Gyehoek.Sexp.Grammar.Base -import Gyehoek.Prelude hiding (traversed, iso) +import Gyehoek.Prelude hiding (snoc, Iso, flipped, cons, traversed, iso) import Data.InvertibleGrammar (backward, sealed, forward, runGrammar) -import Gyehoek.Sexp.Print (printDatum, printDatum', printData) +import Gyehoek.Sexp.Print (printDatum, printDatum', printData, printData') import Gyehoek.Jalmot import Data.InvertibleGrammar.Combinators import qualified Gyehoek.Sexp.Read as Read @@ -63,6 +68,9 @@ fromDatum g = fromDatumUnsafe :: DatumGrammar a -> Datum -> a fromDatumUnsafe g = runJalmotUnsafe . fromDatum g +fromDataUnsafe :: DataGrammar a -> List Datum -> a +fromDataUnsafe g = runJalmotUnsafe . fromData g + fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a fromData g = forward (sealed g) @@ -75,6 +83,9 @@ encodeWith g = toDatum g >>> fmap printDatum encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text encodeDataWith g = toData g >>> fmap printData +encodeDataWith' :: Jalmot :> es => DataGrammar a -> a -> Eff es Text +encodeDataWith' g = toData g >>> fmap printData' + encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text encodeWith' g = toDatum g >>> fmap printDatum' @@ -97,6 +108,16 @@ encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g) encodeTestColour :: DatumGrammar a -> a -> IO () encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g) +encodeDataTest :: DataGrammar a -> a -> IO () +encodeDataTest g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith' g) + +encodeDataTestColour :: DataGrammar a -> a -> IO () +encodeDataTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith g) + +-- | run a grammar, quick and dirty. +decodeDataTest :: Show a => DataGrammar a -> Text -> IO () +decodeDataTest g = pPrintNoColor <=< (runJalmotIO . decodeDataWith g) + encodeOrShow' :: (IsString s, Show a) => DatumGrammar a -> a -> s encodeOrShow' g x = fromString $ case runPureEff . runJalmot . encodeWith' g $ x of @@ -129,3 +150,14 @@ instance DatumIso a => DataIso (V.Vector a) where instance (DatumIso a, DatumIso b) => DatumIso (a, b) where datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2 + +data Example = MkExample (List Int) Text + deriving (Generic, Show) + +instance DataIso Example where + dataIso = with \g -> + flipped snoced + >>> onHead (traversed $ sealed int) + >>> onTail (onHead $ sealed symbol) + >>> swap + >>> g diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index 8224108..4ca3bbe 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -5,7 +5,7 @@ module Gyehoek.Sexp.Grammar.Base , expected, unexpected -- * types , G - , Grammar + , Grammar(..) , DatumGrammar , DataGrammar , Grammar @@ -13,8 +13,15 @@ module Gyehoek.Sexp.Grammar.Base , (:-)((:-)) -- * lists , list + , listWithIndentation , el , rest + , restData + , headTagged0' + , headTagged0 + , headTagged1' + , headTagged1 + , headTagged2 -- * atoms , simple , string @@ -23,24 +30,23 @@ module Gyehoek.Sexp.Grammar.Base , boolean , number , integer - , headTagged1' - , headTagged1 - , headTagged2 , int + -- * TODO: sort lol + , prismIso + , isoIso, decorate + , snoced , letLike , ifLike - , headTagged0' - , headTagged0 , lambdaLike , lambdaKeyword , kappaKeyword , beginLike - , prismIso - , isoIso ) where import Data.InvertibleGrammar import Data.InvertibleGrammar.Base +import Data.InvertibleGrammar.Base as Re + ( Grammar(..)) import Data.InvertibleGrammar.Combinators import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple) import Gyehoek.Sexp.Syntax hiding (position) @@ -54,6 +60,9 @@ import Control.Monad.RWS (modify) -- $setup -- >>> :set -XOverloadedStrings -- >>> import Gyehoek.Sexp.Grammar +-- >>> import Data.Text (Text) +-- >>> import GHC.Generics (Generic) +-- >>> import Data.List (List) type G = Grammar Ann @@ -79,7 +88,10 @@ modifyAnn f = Iso (\(d:-t) -> (d & ann %~ f) :- t) (\(d:-t) -> (d & ann %~ f) :- t) -newtype ListContext = MkListContext (List Datum) +decorate :: Syn -> G (Datum :- t) (Datum :- t) +decorate s = modifyAnn $ #syntax .~ s + +newtype ListContext = MkListContext { inner :: List Datum } unexpectedSimple :: Simple -> Mismatch unexpectedSimple = unexpected . printDatum' . Simple @@ -118,7 +130,8 @@ el -> G (ListContext :- t) (ListContext :- t') el g = coerced (Flip cons >>> onTail g >>> Step) --- | matches the remainder of a list +-- | matches the remainder of a list as repetition of a given +-- grammar. -- -- >>> decodeTest (list $ rest simple) "(ga na da ra)" -- [ SimpleSymbol "ga" @@ -134,6 +147,71 @@ rest g = onHead (Traverse (sealed g >>> Step)) >>> Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a) +-- | matches the remainder of a list with a 'DataGrammar'. this +-- differs from 'rest' in that the tail can be matched as a single +-- chunk, as opposed to matching each element individually with a +-- homogeneous \"rest element\" grammar. +-- +-- >>> :{ +-- data Example = MkExample (List Int) Text +-- deriving (Generic, Show) +-- dataGrammar :: DataGrammar Example +-- dataGrammar = with \g -> +-- flipped snoced >>> +-- onHead (traversed $ sealed int) >>> +-- onTail (onHead $ sealed symbol) >>> +-- swap >>> +-- g +-- :} +-- +-- a 'DataGrammar' is usually used to code sequences of S-expressions, +-- e.g. the top-level of a Scheme program: +-- >>> decodeDataTest dataGrammar "1 2 3 end" +-- MkExample +-- [ 1 +-- , 2 +-- , 3 +-- ] "end" +-- >>> encodeDataTest dataGrammar $ MkExample [1,2,3] "end" +-- 1 +-- +-- 2 +-- +-- 3 +-- +-- end +-- +-- with 'dataRest', we can apply that same "top-level" grammar within a list: +-- >>> :{ +-- dataRestGrammar :: DatumGrammar Example +-- dataRestGrammar = list . restData $ dataGrammar +-- :} +-- +-- >>> decodeTest dataRestGrammar "(1 2 3 end)" +-- MkExample +-- [ 1 +-- , 2 +-- , 3 +-- ] "end" +-- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end" +-- (1 2 3 end) +restData + :: G (List Datum :- t) (a :- t) + -> G (ListContext :- t) (ListContext :- a :- t) +restData g = + iso coerce coerce + >>> g + >>> push (MkListContext []) (const True) mempty + +snoced + :: Snoc s s a a + => Grammar p (s :- a :- t) (s :- t) +snoced = PartialIso + (\(s:-a:-t) -> Gyehoek.Prelude.snoc s a :- t) + (\(s:-t) -> case s ^? _Snoc of + Nothing -> Left $ expected "list element" + Just (s',a) -> Right $ s' :- a :- t) + -- atoms @@ -227,25 +305,25 @@ int = integer >>> iso fromIntegral fromIntegral -- high-level combinators headTagged0 :: Text -> G (Datum :- t) t -headTagged0 s = list $ el (sym s) +headTagged0 s = list $ el (symProcedure s) headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t) -headTagged0' s gt = list $ el (sym s) >>> rest gt +headTagged0' s gt = list $ el (symProcedure s) >>> rest gt headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t) -headTagged1 s g1 = list $ el (sym s) >>> el g1 +headTagged1 s g1 = list $ el (symProcedure s) >>> el g1 headTagged1' :: Text -> DatumGrammar a -> DatumGrammar b -> G (Datum :- t) (List b :- a :- t) -headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt +headTagged1' s g1 gt = list $ el (symProcedure s) >>> el g1 >>> rest gt headTagged2 :: Text -> DatumGrammar a -> DatumGrammar b -> G (Datum :- t) (b :- a :- t) -headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2 +headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2 ifLike -- | keyword @@ -257,10 +335,13 @@ ifLike -- | alternative (else-branch) -> DatumGrammar c -> G (Datum :- t) (c :- b :- a :- t) -ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f +ifLike kw c t f = + listWithIndentation (NSpecial 1) $ + el (symBuiltin kw) >>> el c >>> el t >>> el f -symBuiltin :: Text -> G (Datum :- t) t -symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s +symBuiltin, symProcedure :: Text -> G (Datum :- t) t +symBuiltin s = decorate SynBuiltin >>> sym s +symProcedure s = decorate SynProcedure >>> sym s letLike :: Text @@ -281,7 +362,7 @@ lambdaLike -> G (ListContext :- a :- t) (ListContext :- t') -> G (Datum :- t) t' lambdaLike kw formals body = listWithIndentation (NSpecial 1) $ - el (modifyAnn (#syntax .~ SynBuiltin) >>> kw) + el (decorate SynBuiltin >>> kw) >>> el formals >>> body diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 467e40c..741f256 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -3,6 +3,7 @@ module Gyehoek.Sexp.Print , printDatumW , printDatum' , printData + , printData' ) where import Gyehoek.Sexp.Syntax @@ -14,7 +15,7 @@ import Gyehoek.Prelude hiding (Simple, (:<)) import Data.Foldable (traverse_) import qualified Prettyprinter.Render.Terminal as ANSI import System.IO (stdout) -import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold) +import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull) import Prettyprinter.Render.Text (renderStrict) import qualified Data.Scientific as Sci import Data.List (intersperse) @@ -36,6 +37,9 @@ printDatum = printDatumW 80 printData :: List Datum -> Text printData = mconcat . intersperse "\n\n" . fmap printDatum +printData' :: List Datum -> Text +printData' = mconcat . intersperse "\n\n" . fmap printDatum' + printDatumW :: Int -> Datum -> Text printDatumW w = prettyDatum 0 @@ -91,7 +95,9 @@ putDoc = ANSI.renderIO stdout highlight :: Syn -> AnsiStyle highlight = \case (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold - SynParen n -> color $ rainbow ^?! ix n + SynProcedure -> color Blue + SynConstant -> color Yellow + SynParen n -> colorDull $ rainbow ^?! ix n _ -> mempty where rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan] diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 31517e6..69ea111 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -125,6 +125,7 @@ data Syn | SynParen Int | SynString | SynConstant + | SynVariable | SynNone deriving (Show, Read, Data, Generic, Eq, Lift) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 2141d31..79549e4 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -4,8 +4,10 @@ {-# LANGUAGE DeriveAnyClass #-} module Gyehoek.Stack.Syntax ( Program(..) - , Block(..) + , Routine(..) , Instr(..) + , Block(..) + , Tail(..) , Val(..) , Lit(..) , Obj(..) @@ -14,6 +16,7 @@ module Gyehoek.Stack.Syntax , Prim(..) , Name , pattern ValLabel + , stkP ) where import Control.Lens @@ -23,30 +26,43 @@ import GHC.Exts (IsList(..)) import Data.List (intersperse) import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName) import Gyehoek.Prelude +import Gyehoek.Sexp ((:-)((:-))) newtype Program = MkProgram - { blocks :: List Block + { routines :: HashMap Name Routine } deriving stock (Show, Generic, Data) deriving newtype (Semigroup, Monoid) deriving anyclass (NFData) instance IsList Program where - type Item Program = Block - fromList = MkProgram - toList = view #blocks + type Item Program = Routine + fromList rs = MkProgram + { routines = fromList [ (r.label, r) | r <- rs ] + } + toList = toListOf $ #routines . each -data Block = MkBlock +data Routine = MkRoutine { label :: Name , params :: List Name - , code :: List Instr + , start :: Block } deriving stock (Show, Generic, Data) deriving anyclass (NFData) -instance Each Block Block Instr Instr where - each = #code . each +data Block = MkBlock + { code :: List Instr + , tail :: Tail + } + deriving stock (Show, Generic, Data) + deriving anyclass (NFData) + +data Tail + = TailCall Val (List Val) + | If Val Block Block + deriving stock (Show, Generic, Data) + deriving anyclass (NFData) data Instr = Pop Name @@ -54,8 +70,6 @@ data Instr | PopCont Name | PushCont Val | Prim Name (Prim Val) - | Call Val (List Val) - | If Val (List Instr) (List Instr) deriving stock (Show, Generic, Data) deriving anyclass (NFData) @@ -80,14 +94,29 @@ instance S.DatumIso Instr where $ S.With (S.headTagged1 "pop-cont!" regName >>>) $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>) $ S.With (S.headTagged2 "prim" regName S.datumIso >>>) - $ S.With (S.headTagged1' "call" S.datumIso S.datumIso >>>) + $ S.End + where + +instance S.DataIso Block where + dataIso = S.with \g -> + S.flipped S.snoced + >>> S.onHead (S.traversed $ S.sealed S.datumIso) + >>> S.onTail (S.datumIso @Tail) + >>> S.swap + >>> g + +instance S.DatumIso Tail where + datumIso = S.match + $ S.With (S.headTagged1' "tail-call!" S.datumIso S.datumIso >>>) $ S.With (if_ >>>) $ S.End where - if_ = S.list $ S.el (S.sym "if") - >>> S.el (S.datumIso @Val) - >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.datumIso @Instr)) - >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.datumIso @Instr)) + if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else") + branch :: Text -> S.DatumGrammar Block + branch s = + S.listWithIndentation (S.NSpecial 0) $ + S.el (S.decorate S.SynBuiltin >>> S.sym s) + >>> S.restData (S.dataIso @Block) instance S.DatumIso Val where datumIso = S.match @@ -95,18 +124,22 @@ instance S.DatumIso Val where $ S.With (S.datumIso >>>) $ S.End -instance S.DatumIso Block where - datumIso = S.with (block >>>) - where - block = S.list $ - S.el (S.sym "define") - >>> S.el (S.list $ S.el labelName >>> S.rest regName) - >>> S.rest (S.datumIso @Instr) +instance S.DatumIso Routine where + datumIso = S.with \rout -> + S.listWithIndentation (S.NSpecial 1) + ( S.el (S.decorate S.SynBuiltin >>> S.sym "define") + >>> S.el (S.list $ S.el labelName >>> S.rest regName) + >>> S.restData (S.dataIso @Block) + ) + >>> rout regName :: S.DatumGrammar Name -regName = S.datumIso @Name >>> S.prismIso +regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso (S.expected "register") (prefixed @Name "%") instance S.DataIso Program where - dataIso = S.dataIso @(List Block) >>> S.iso coerce coerce + dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList + +stkP :: S.QuasiQuoter +stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||] diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index a6600ff..569d0a3 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -19,6 +19,7 @@ data VM = MkVM { stack :: List Obj , kstack :: List Name , code :: List Instr + , tail :: Tail , registers :: HashMap Name Obj , stdout :: Text , result :: Maybe (List Obj) @@ -26,14 +27,14 @@ data VM = MkVM deriving (Show, Generic) data Env = MkEnv - { blocks :: HashMap Name Block + { labels :: HashMap Name Routine } deriving (Show, Generic) step :: Env -> VM -> VM -step e vm = case vm ^. #code of - c:cs -> stepI e (vm & #code .~ cs) c - _ -> error "halt never called" +step g vm = case vm ^. #code of + c:cs -> stepI g (vm & #code .~ cs) c + [] -> stepT g vm vm.tail stepI :: Env -> VM -> Instr -> VM @@ -78,23 +79,28 @@ stepI e vm ins@(PopCont r) = case vm ^. #kstack of (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x) & #kstack .~ xs -stepI e vm (Call v xs) = - case evalToLabel e vm v of - "halt" -> vm & #result ?~ fmap (evalVal e vm) xs - l -> vm & #code .~ b.code - & #registers .~ fmap (evalVal e vm) (H.fromList $ b.params `zip` xs) - where - b = case e ^. #blocks . at l of - Just x -> x - Nothing -> error [i|undefined label: #{l}|] - -stepI e vm (If c t f) = - case evalVal e vm c of - ObjImm (ImmBool False) -> vm & #code .~ f - _ -> vm & #code .~ t - stepI e vm ins = error [i|unimplemented instruction: #{ins}|] +stepT :: Env -> VM -> Tail -> VM + +stepT g vm (TailCall f xs) = + case evalToLabel g vm f of + "halt" -> vm & #result ?~ fmap (evalVal g vm) xs + l -> vm & #code .~ rt.start.code + & #tail .~ rt.start.tail + & #registers .~ + fmap (evalVal g vm) (H.fromList $ rt.params `zip` xs) + where + rt = case g ^. #labels . at l of + Nothing -> error [i|undefined label: #{l}|] + Just x -> x + +stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail + where + branch = case evalVal g vm c of + ObjImm (ImmBool False) -> f + _ -> t + evalToLabel e vm v = case evalVal e vm v of ObjImm (ImmLabel x) -> x @@ -111,15 +117,16 @@ initialVM :: VM initialVM = MkVM { stack = [] , kstack = ["halt"] - , code = [Call (ValImm $ ImmLabel "main") []] + , code = [] + , tail = TailCall (ValLabel "main") [] , registers = mempty , stdout = "" , result = Nothing } initialEnv :: Program -> Env -initialEnv (MkProgram bs) = MkEnv - { blocks = bs & foldMap \b -> H.singleton b.label b +initialEnv p = MkEnv + { labels = p.routines } loop :: (a -> Either b a) -> a -> b diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index d25663f..857b8bd 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} module Gyehoek.Test.Stack.VM where import Test.Tasty (TestTree, testGroup) @@ -7,110 +8,97 @@ import Gyehoek.Stack.VM qualified as Sut import Data.List (List) -test_root = testGroup "stack machine" $ - [ lit_int - , procedure - , prims - ] +evalsTo :: List Obj -> Program -> Assertion +evalsTo rs p = Sut.eval p @?= rs - - -evalsTo :: List Obj -> List Block -> Assertion -evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs - - - -lit_int = testCase "lit int" do - evalsTo [ObjImm (ImmInt 3)] - [ MkBlock "main" [] - [ PopCont "ktail" - , Call (ValReg "ktail") [ValImm (ImmInt 3)] - ] - ] - -procedure = testGroup "procedure" - [ testCase "return constant" do - evalsTo [ObjImm (ImmInt 123)] - [ MkBlock "main" [] - [ Call (ValLabel "silly") [] - ] - , MkBlock "silly" [] - [ PopCont "ktail" - , Call (ValReg "ktail") [ValImm (ImmInt 123)] - ] - ] +test_root = testGroup "stack machine" + [ testCase "lit int" do + evalsTo [ObjImm (ImmInt 3)] [stkP| + (define ($main) + (pop-cont! %ktail) + (tail-call! %ktail 3)) + |] + , testCase "return constant" do + evalsTo [ObjImm (ImmInt 123)] [stkP| + (define ($main) + (tail-call! $silly)) + (define ($silly) + (pop-cont! %ktail) + (tail-call! %ktail 123)) + |] , testCase "identity function" do - evalsTo [ObjImm (ImmInt 45)] - [ MkBlock "main" [] - [ Call (ValLabel "id") [ValImm (ImmInt 45)] - ] - , MkBlock "id" ["x"] - [ PopCont "ktail" - , Call (ValReg "ktail") [ValReg "x"] - ] - ] + evalsTo [ObjImm (ImmInt 45)] [stkP| + (define ($main) + (tail-call! $id 45)) + (define ($id %x) + (pop-cont! %ktail) + (tail-call! %ktail %x)) + |] + -- , testCase "square" do + -- evalsTo [ObjImm (ImmInt 16)] [stkP| + -- (define ($main)) + -- |] , testCase "square" do - evalsTo [ObjImm (ImmInt 16)] - [ MkBlock "main" [] - [ Call (ValLabel "square") [ValImm (ImmInt 4)] - ] - , MkBlock "square" ["x"] - [ PopCont "ktail" - , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x") - , Call (ValReg "ktail") [ValReg "x2"] - ] - ] + evalsTo [ObjImm (ImmInt 16)] [stkP| + (define ($main) + (tail-call! $square 4)) + (define ($square %x) + (prim %x2 (* %x %x)) + (pop-cont! %ktail) + (tail-call! %ktail %x2)) + |] , testCase "factorial" do - let fac n = - [ MkBlock "fac" ["n"] - [ Prim "x0" $ PrimZeroP (ValReg "n") - , If (ValReg "x0") - [ PopCont "ktail" - , Call (ValReg "ktail") [ValImm (ImmInt 1)] - ] - [ Push (ValReg "n") - , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1)) - , PushCont (ValLabel "fac-k0") - , Call (ValLabel "fac") [ValReg "x1"] - ] - ] - , MkBlock "fac-k0" ["x2"] - [ Pop "n" - , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n") - , PopCont "ktail" - , Call (ValReg "ktail") [ValReg "x3"] - ] - , MkBlock "main" [] - [ Call (ValLabel "fac") [ValImm (ImmInt n)] - ] - ] + let hsfac (n :: Int) = foldr (*) (1) [1..n] + let fac (n :: Int) = [stkP| + (define ($fac %n) + (prim %x0 (zero? %n)) + (if %x0 + (then (pop-cont! %ktail) + (tail-call! %ktail 1)) + (else (push! %n) + (prim %x1 (- %n 1)) + (push-cont! $fac-k0) + (tail-call! $fac %x1)))) + (define ($fac-k0 %x2) + (pop! %n) + (prim %x3 (* %x2 %n)) + (pop-cont! %ktail) + (tail-call! %ktail %x3)) + (define ($main) + (tail-call! $fac #{n})) + |] 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 ] -prims = testGroup "prims" - [ arith - , testCase "zero?" do - trivialPrimTest [ObjImm (ImmBool True)] $ - PrimZeroP $ ValImm $ ImmInt 0 - trivialPrimTest [ObjImm (ImmBool False)] $ - PrimZeroP $ ValImm $ ImmInt 12 - ] +-- ] -trivialPrimTest rs p = - evalsTo rs - [ MkBlock "main" [] - [ PopCont "ktail" - , Prim "x1" p - , Call (ValReg "ktail") [ValReg "x1"] - ] - ] +-- prims = testGroup "prims" +-- [ arith +-- , testCase "zero?" do +-- trivialPrimTest [ObjImm (ImmBool True)] $ +-- PrimZeroP $ ValImm $ ImmInt 0 +-- trivialPrimTest [ObjImm (ImmBool False)] $ +-- PrimZeroP $ ValImm $ ImmInt 12 +-- ] -arith = testGroup "arith" - [ testCase "multipy" do - trivialPrimTest [ObjImm (ImmInt 12)] - (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4)) - , testCase "subtract" do - trivialPrimTest [ObjImm (ImmInt 14)] - (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6)) - ] +-- trivialPrimTest rs p = +-- evalsTo rs +-- [ MkRoutine "main" [] +-- [ PopCont "ktail" +-- , Prim "x1" p +-- , Call (ValReg "ktail") [ValReg "x1"] +-- ] +-- ] + +-- arith = testGroup "arith" +-- [ testCase "multipy" do +-- trivialPrimTest [ObjImm (ImmInt 12)] +-- (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4)) +-- , testCase "subtract" do +-- trivialPrimTest [ObjImm (ImmInt 14)] +-- (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6)) +-- ] diff --git a/test/doctest.hs b/test/doctest.hs index 85fa358..9534c91 100644 --- a/test/doctest.hs +++ b/test/doctest.hs @@ -1,7 +1,17 @@ +{-# LANGUAGE DoAndIfThenElse #-} module Main where - + import Test.DocTest (mainFromCabal) -import System.Environment (getArgs) +import System.Environment (getArgs, lookupEnv) +import System.IO (stderr, hPutStrLn) + main :: IO () -main = mainFromCabal "gyehoek" =<< getArgs +main = do + nix <- maybe False null <$> lookupEnv "GYEHOEK_IN_NIX_BUILD" + if nix then do + hPutStrLn stderr "\ + \skipping doctests in Nix build environment. \ + \see https://github.com/pcapriotti/optparse-applicative/pull/408." + else + mainFromCabal "gyehoek" =<< getArgs