diff --git a/.dir-locals.el b/.dir-locals.el index c5558e4..0d9facf 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -4,4 +4,6 @@ (haskell-mode-buffer-apply-command "cabal-fmt")) (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t) (add-to-list 'haskell-font-lock-quasi-quote-modes - '("cps" . scheme-mode))))))) + '("cps" . scheme-mode)) + (add-to-list 'haskell-font-lock-quasi-quote-modes + '("scm" . scheme-mode))))))) diff --git a/doc/closure-conversion.org b/doc/closure-conversion.org index 1f58588..56a7f1d 100644 --- a/doc/closure-conversion.org +++ b/doc/closure-conversion.org @@ -2,8 +2,59 @@ the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment. +nice testable properties of closure-converted code: +- code pointers only appear in function position +- no function has free variables + +multiple ~env-ref~ calls could probably be replaced with a primitive that loads the entire environment at once, returning multiple variables. + * scratchpad +** example + +#+caption: scheme source +#+begin_src scheme + (letrec ((curried-add (λ (n) + (λ (m) + (+ n m))))) + ((curried-add 3) 4)) +#+end_src + +#+caption: cps +#+begin_src scheme + (letrec ((curried-add + (λ (n ktail0) + (letrec ((curried-add-in + (λ (m ktail1) + (prim (+ n m) + (κ (x0) (continue ktail1 x0)))))) + (continue ktail0 curried-add-in))))) + (letrec ((k0 (κ (adder) (adder 4 halt)))) + (curried-add 3 k0))) +#+end_src + +#+caption: closure-converted +#+begin_src scheme + (letrec ((curried-add + (λ (n ktail0) + (letrec ((curried-add-in-code + (λ (env m ktail1) + (prim (env-ref 0 env) + (κ (n) + (prim (+ n m) + (κ (x0) (continue ktail1 x0)))))))) + (prim (make-closure curried-add-in-code n) + (κ (curried-add-in) + (continue ktail0 curried-add-in))))))) + (letrec ((k0 (κ (adder-closure) + (prim (closure-code adder-closure) + (κ (adder) + (adder adder-closure 4 halt)))))) + (curried-add 3 k0))) +#+end_src + +** wasm + #+begin_src scheme (letrec ((make-adder (lambda (n) diff --git a/golden/adder/exec b/golden/adder/exec new file mode 100644 index 0000000..904735b --- /dev/null +++ b/golden/adder/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 9 diff --git a/golden/callcc-nested1/exec b/golden/callcc-nested1/exec new file mode 100644 index 0000000..6901ce2 --- /dev/null +++ b/golden/callcc-nested1/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 456 diff --git a/golden/let-fn/exec b/golden/let-fn/exec new file mode 100644 index 0000000..1ced3ba --- /dev/null +++ b/golden/let-fn/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 16 diff --git a/golden/letrec-fn/exec b/golden/letrec-fn/exec new file mode 100644 index 0000000..1ced3ba --- /dev/null +++ b/golden/letrec-fn/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 16 diff --git a/golden/letrec-fn/source.scm b/golden/letrec-fn/source.scm new file mode 100644 index 0000000..37773cb --- /dev/null +++ b/golden/letrec-fn/source.scm @@ -0,0 +1,2 @@ +(letrec ((square (λ (x) (* x x)))) + (square 4)) diff --git a/gyehoek.cabal b/gyehoek.cabal index ea948a1..eef1e01 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -54,6 +54,7 @@ library exposed-modules: Gyehoek.CPS.Close Gyehoek.CPS.Convert + Gyehoek.CPS.Eval Gyehoek.CPS.Lower Gyehoek.CPS.Stackify Gyehoek.CPS.Syntax @@ -83,6 +84,7 @@ library , megaparsec , mtl , optparse-applicative + , ordered-containers , pretty-simple , prettyprinter , process @@ -105,9 +107,11 @@ test-suite test hs-source-dirs: test main-is: Main.hs other-modules: + Gyehoek.Test.CPS.Eval Gyehoek.Test.CPS.Stackify Gyehoek.Test.CPS.Syntax Gyehoek.Test.Golden + Gyehoek.Test.Scheme.Syntax Gyehoek.Test.Sexp Gyehoek.Test.Stack.VM diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index 20e9ded..f9663f5 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/src/Gyehoek/CPS/Close.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} module Gyehoek.CPS.Close ( closeProgram ) where @@ -9,6 +10,12 @@ import Control.Monad ((>=>)) import Control.Lens import Data.List.NonEmpty (NonEmpty) import qualified Data.HashSet as HS +import qualified Data.Set.Ordered as O +import Data.Set.Ordered (OSet) +import Gyehoek.GenSym +import Data.String.Interpolate (i) +import Debug.Pretty.Simple +import Data.HashSet (HashSet) cataM @@ -16,14 +23,77 @@ cataM => (Base t a -> m a) -> t -> m a cataM f = cata (sequenceA >=> f) -close :: Exp -> Exp -close = cata \case - ExpLetRecF {bindersF,bodyF} -> ExpLetRec binders bodyF - where - binders = bindersF & (each . _2 . _AbsLambda' . _3) %~ \e -> _ - e -> embed e +close :: GenSym :> es => Exp -> Eff es Exp - -- let frees = freeWithBound' (HS.fromList $ ktail : bs) e' +close = transformM \case -closeProgram :: Program -> Eff es Program -closeProgram (MkProgram e) = pure . MkProgram . close $ e + ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do + f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code") + -- it would probably be most sane to generate a symbol for `env`, + -- but we're reusing the lambda binding for the sake of recursive + -- reverences. + -- env <- gensym' @Name "env" + let frees = freeWithBound' [f] lam + let m' = ifoldr + (\n x q -> [cps|(prim (env-ref #{f} #{n}) + (κ (#{x}) #{q}))|]) + m frees + pure [cps| + (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb}) + #{m'}))) + (prim (make-closure ($ #{f_code}) ##{frees}) + (κ (#{f}) #{e}))) + |] + + ExpApply f xs ktail -> do + code <- gensym' @Name "code" + pure [cps| + (prim (env-code #{f}) + (κ (#{code}) + (#{code} #{f} ##{xs} #{ktail}))) + |] + + e -> pure e + + e -> error [i|unimplemented case: #{e}|] + + -- lam@(ExpLambdaF bs m) -> do + -- env <- gensym' @Name "env" + -- let upvalBinds = free' (embed lam) + -- & itraversed %@~ \i x -> (x, [cps|(env-ref #{env} #{i})|]) + -- let upvals = upvalBinds ^.. each . _1 + -- pure [cps| + -- (make-closure (λ (#{env} ##{bs}) + -- (let #{upvalBinds} + -- #{m})) + -- ##{upvals}) + -- |] + -- ExpApplyF f xs -> + -- pure [scm| + -- (apply-closure #{f} ##{xs}) + -- |] + +closeProgram :: GenSym :> es => Program -> Eff es Program +closeProgram = traverseOf #body close + +curriedadd :: Program +curriedadd = [cps| + (letrec ((curried-add + (λ (n ktail1) + (letrec ((curried-add-in + (λ (m ktail2) + (prim (+ n m) + (κ (x0) (continue ktail2 x0)))))) + (continue ktail1 curried-add-in))))) + (letrec ((k0 (κ (adder) (adder 4 halt)))) + (curried-add 5 k0))) +|] + +square :: Program +square = [cps| +(letrec ((lambda-body0 (λ (x lambda-tail1) + (prim (* x x) (κ (r2) (continue lambda-tail1 r2)))))) + (letrec + ((r3 (κ (x4) (continue halt x4)))) + (lambda-body0 5 r3))) +|] diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 52f9e60..74dbb9a 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -18,6 +18,7 @@ import Data.String.Interpolate (i) import Data.Functor (unzip) import Data.List (List) import Prelude hiding (unzip) +import Debug.Pretty.Simple (pTraceShowMForceColor) -- 뻘짓이어라 @@ -64,7 +65,7 @@ convert (Scm.ExpPrim p) k = ExpPrim p' . MkKappa [r] <$> k (ValVar r) convert (Scm.ExpLambda xs e) k = do - f <- gensym' "λ-body" + f <- gensym' "lambda-body" lam <- convertLambda xs e ke <- k $ ValVar f pure [cps| @@ -92,7 +93,7 @@ convert (Scm.ExpLet bs e) k = let rhss = bs ^.. each . _2 in telescope (convert @es) rhss \rhss' -> do e' <- convert e k - kbody <- gensym' @Name "letrec-body" + kbody <- gensym' @Name "let-body" let bs' = bs ^.. each . _1 pure [cps| (letrec ((#{kbody} (κ #{bs'} #{e'}))) diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs new file mode 100644 index 0000000..ddde213 --- /dev/null +++ b/src/Gyehoek/CPS/Eval.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ViewPatterns #-} +module Gyehoek.CPS.Eval + ( evalProgram + , module Gyehoek.CPS.Syntax + ) where + +import Gyehoek.CPS.Syntax +import Data.String.Interpolate (i) +import Data.HashMap.Strict (HashMap) +import Control.Lens +import Data.Maybe (fromMaybe) +import Data.Generics.Labels () +import GHC.Generics (Generic) +import Data.List (List) +import Text.Show.Functions () +import qualified Data.HashMap.Strict as H +import Debug.Pretty.Simple (pTraceShowId) +import qualified Data.Text as T + + +data Code + = CodeKap (List Obj -> List Obj) + | CodeLam (List Obj -> Name -> List Obj) + deriving (Show, Generic) + +data Env = MkEnv + { vars :: HashMap Name Obj + , labels :: HashMap Name (Env, Abs) + } + deriving (Show, Generic) + +eval :: Env -> Exp -> List Obj + +eval g (Halt xs) = evalVal g <$> xs + +eval g (ExpContinue k xs) = + case g ^. #labels . at k of + Just (h, AbsKappa' bs m) -> eval h' m + where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs) + _ -> error [i|not a kappa: #{k}|] + +eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) = + case g ^?! #labels . at f of + Just (h,AbsLambda' bs kb m) -> eval h' m + where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs) + & #labels . at kb .~ (g ^. #labels . at ktail) + Nothing -> error [i|undefined label: #{f}|] + +eval g (ExpLetRec [(b, ab)] e) = eval g' e + where g' = g & #labels . at b ?~ (g,ab) + +eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of + PrimAdd x y -> arithBinop (+) x y + PrimMul x y -> arithBinop (*) x y + PrimSub x y -> arithBinop (-) x y + PrimDiv x y -> arithBinop div x y + _ -> error [i|unhandled prim: #{p}|] + where + ret rs = eval + (g & #vars <>~ envOfBinds bs rs) + e + arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) = + ret [ObjImm . ImmInt $ f x y] + arithBinop _ x y = error [i|bad arith: #{x}, #{y}|] + +eval _ e = error [i|unimplemented case: #{e}|] + +envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs) + +evalVal :: Env -> Val -> Obj +evalVal g = \case + ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x + ValImm x -> ObjImm x + ValLit l -> ObjImm $ case l of + LitInt n -> ImmInt n + LitBool b -> ImmBool b + +emptyEnv :: Env +emptyEnv = MkEnv + { vars = mempty + , labels = H.singleton "halt" $ + ( emptyEnv + , AbsKappa' ["h0"] $ Halt [ValVar "h0"] + ) + } + +evalProgram :: Program -> List Obj +evalProgram (MkProgram e) = eval emptyEnv e + +curriedadd :: Program +curriedadd = [cps| +(letrec ((curried-add + (λ (n ktail1) + (letrec ((curried-add-in + (λ (m ktail2) + (prim (+ n m) + (κ (x0) (continue ktail2 x0)))))) + (continue ktail1 curried-add-in))))) + (letrec ((k0 (κ (adder) (adder 4 halt)))) + (curried-add 5 k0))) +|] + +idfn = [cps| + (letrec ((id (λ (x ktail) + (continue ktail x)))) + (id 456 halt)) + |] :: Program diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 9bc9391..b435e55 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -8,6 +8,7 @@ module Gyehoek.CPS.Stackify import Gyehoek.CPS.Syntax import Gyehoek.Stack.Syntax qualified as Stk import Data.Sequence (Seq) +import Data.Sequence qualified as Seq import Effectful import Gyehoek.GenSym import Effectful.Writer.Static.Shared @@ -18,7 +19,7 @@ import GHC.Generics (Generic) import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H -import Data.List (List) +import Data.List (List, elemIndex) import GHC.Exts (IsList(fromList)) @@ -48,12 +49,10 @@ stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do 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 & #contStack %~ (k:)) m - tell [Stk.MkBlock lam_body xs . toList $ m'] - stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) e + tell [Stk.MkBlock f xs . toList $ m'] + stackify g e stackify g (ExpIf c t f) = do t' <- stackify g t @@ -70,16 +69,21 @@ stackify g (ExpApply f xs ktail) = do ls = fold $ (k ^? #ValImm . #ImmLabel) >>= \klbl -> g ^. #liveness . at klbl --- this probably won't work for call/cc, for cps-converted code it'll --- be fine i think. notice how, instead of calling `var g k`, we just --- assume it's the return continuation on top of the stack. -stackify g (ExpContinue k xs) = do - ktail <- gensym' $ k ^. _Wrapped' - pure $ - fromList [ Stk.PopCont "_" | _ <- takeWhile (/= k) g.contStack ] - <> [ Stk.PopCont ktail - , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs) - ] +stackify g (ExpContinue k xs) = + -- return continuations require popping the stack. how do we know + -- 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' ] + Just j -> do + ktail <- gensym' $ k ^. _Wrapped' + pure $ + Seq.replicate j (Stk.PopCont "_") + <> [ Stk.PopCont ktail + , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs) + ] + + where xs' = stackifyVal g <$> xs stackify g (ExpPrim p (MkKappa [x] e)) = do e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e @@ -91,6 +95,7 @@ stackifyVal :: Env -> Val -> Stk.Val stackifyVal g = \case ValLit (LitInt n) -> Stk.ValImm (ImmInt n) ValLit (LitBool b) -> Stk.ValImm (ImmBool b) + ValImm imm -> Stk.ValImm imm ValVar v -> var g v v -> error [i|unimplemented val: #{v}|] diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e57d874..d911ce0 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DeriveAnyClass #-} module Gyehoek.CPS.Syntax ( Val(..) , Kappa(..) @@ -14,6 +15,9 @@ module Gyehoek.CPS.Syntax , Prim(..) , Program(..) , Lit(..) + , Imm(..) + , Obj(..) + , Hob(..) , pattern Void , pattern Halt , pattern Halt1 @@ -34,6 +38,8 @@ module Gyehoek.CPS.Syntax , Free(..) , Vars(..) , Subst(..) + , pattern ValLabel + , labelName -- don't like that this is part of the api ) where @@ -61,14 +67,41 @@ import Data.Monoid (Endo) import Data.Containers.ListUtils (nubOrd) import Data.Functor.Foldable.TH import Data.Functor.Foldable (Recursive(..), Corecursive (..)) +import Control.DeepSeq (NFData) +import qualified Gyehoek.Sexp as GS +import qualified Language.Sexp.Located as SL +import Data.Data.Lens (uniplate) -- Data types data Val - = ValVar Name + = ValImm Imm | ValLit Lit + | ValVar Name deriving (Show, Generic, Data, Eq) +pattern ValLabel :: Name -> Val +pattern ValLabel x = ValImm (ImmLabel x) + +data Imm + = ImmInt Int + | ImmBool Bool + | ImmLabel Name + deriving stock (Show, Generic, Data, Eq) + deriving anyclass (NFData) + +data Obj + = ObjImm Imm + | ObjHob Hob + deriving stock (Show, Generic, Data, Eq) + deriving anyclass (NFData) + +-- | a heap object. +data Hob + = HobClosure { label :: Name, env :: List Obj } + deriving stock (Show, Generic, Data, Eq) + deriving anyclass (NFData) + data Kappa = MkKappa { binders :: List Name, body :: Exp } deriving (Show, Generic, Data, Eq) @@ -88,7 +121,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail) data Exp = ExpPrim (Prim Val) Kappa - | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp } + | ExpLetRec { binders :: List (Name, Abs), body :: Exp } | ExpContinue Name (List Val) | ExpIf Val Exp Exp | ExpApply @@ -139,15 +172,57 @@ _AbsLambda' = prism' (\case AbsLambda' bs ktail e -> Just (bs,ktail,e) _ -> Nothing) +instance Plated Exp where + plate = uniplate + -- plate k = \case + -- ExpPrim p kap -> ExpPrim p <$> body k kap + -- ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e + -- ExpContinue c xs -> pure $ ExpContinue c xs + -- ExpIf c t f -> ExpIf c <$> k t <*> k f + -- ExpApply f xs ktail -> pure $ ExpApply f xs ktail + -- SexpIso instances instance S.SexpIso Val where sexpIso = match - $ With (\var -> var . S.sexpIso) $ With (\lit -> lit . S.sexpIso) + $ With (\imm -> imm . S.sexpIso) + $ With (\var -> var . S.sexpIso) $ End +instance S.SexpIso Obj where + sexpIso = match + $ With (\imm -> imm . S.sexpIso) + $ With (\hob -> hob . S.sexpIso) + $ End + +instance S.SexpIso Imm where + sexpIso = match + $ With (. S.int) + $ With (. GS.schemeBool) + $ With (. labelName) + $ End + +labelName :: S.SexpGrammar Name +labelName = S.coproduct + [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso + (S.expected "label") + (prefixed @Name "$") + , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name) + ] + +instance S.SexpIso Hob where + sexpIso = match + $ With (. closure) + $ End + where + -- closures can be printed, but not parsed. + closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t) + closure = IG.Flip $ IG.PartialIso + (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t) + (const . Left $ mempty) + instance S.SexpIso Lambda where sexpIso = match $ With (. lambda) @@ -359,8 +434,3 @@ instance Scoped Exp where class Subst a where substWith :: (Name -> Maybe Val) -> a -> a - -instance Subst Exp where - substWith f = go HS.empty where - go bound e = case scope e of - Use xs ss -> _ diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index d3bd905..09034cc 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -19,7 +19,7 @@ import System.IO (Handle) import System.IO qualified as IO import Gyehoek.CPS.Convert import Gyehoek.CPS.Lower -import Gyehoek.CPS.Syntax qualified as Cps +import Gyehoek.CPS.Eval qualified as CPS import Control.Monad import Text.Pretty.Simple (pShowNoColor) import System.Process.Typed @@ -33,8 +33,11 @@ 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) +import Gyehoek.Stack.Syntax qualified as Stk import Effectful.Exception +import Gyehoek.CPS.Close (closeProgram) +import Control.Lens.Extras (is) +import Control.Arrow ((>>>)) main :: IO () @@ -98,6 +101,18 @@ inspectWasm wat = do IO.hFlush (getStdin pager) IO.hClose (getStdin pager) +dumpOrRun + :: Monad m + => Bool -> Bool + -> m a + -> (a -> m ()) -> (a -> m ()) + -> m () +dumpOrRun dump run acquire do_dump do_run = + when (dump || run) do + x <- acquire + when dump (do_dump x) + when run (do_run x) + driver :: (GenSym :> es, FileSystem :> es, IOE :> es) => Options -> Eff es () @@ -108,32 +123,40 @@ driver opts = do cps <- convertProgram scm when opts.dumpCPS do hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right - 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 + closedCps <- closeProgram cps + when opts.dumpClosed do + hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right + let rt_is p = is (_Just . p) opts.runtime + dumpOrRun opts.dumpStackified (rt_is #Stackify) + (stackifyProgram closedCps) + (hPutStrLn FS.stdout . Stk.encodeProgram) + (eval >>> fmap writeObj + >>> T.unwords + >>> hPutStrLn FS.stdout) + dumpOrRun False (rt_is #CPS) + (pure closedCps) + (const $ pure ()) + (CPS.evalProgram >>> fmap writeObj + >>> T.unwords + >>> hPutStrLn FS.stdout) + dumpOrRun opts.inspectWasm (rt_is #Wasm) + (lowerProgram cps) + inspectWasm + (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) parse_e2e :: FilePath -> IO Scm.Program parse_e2e = runEff . runFileSystem . readScm -convert_e2e :: FilePath -> IO Cps.Program -convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm) +convert_e2e :: FilePath -> IO CPS.Program +convert_e2e = runEff . runFileSystem . runGenSym + . (closeProgram <=< convertProgram <=< readScm) lower_e2e :: FilePath -> IO Text lower_e2e = runEff . runFileSystem . runGenSym - . (lowerProgram <=< convertProgram <=< readScm) + . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm) eval_e2e :: FilePath -> IO (List Obj) eval_e2e fp = runEff . runFileSystem . runGenSym $ do - stk <- stackifyProgram <=< convertProgram <=< readScm $ fp + stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp pure . eval $ stk diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 20bae6f..1e25989 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoFieldSelectors #-} module Gyehoek.Options ( Options(..) + , Runtime(..) , parser ) where @@ -12,13 +13,18 @@ import System.FilePath import qualified Data.HashSet as HS import Control.Lens hiding (argument) import GHC.Generics (Generic) +import Data.Foldable +data Runtime = Stackify | Wasm | CPS + deriving (Show, Generic) + data Options = MkOptions - { dumpCPS :: Bool + { dumpClosed :: Bool + , dumpCPS :: Bool , dumpParsed :: Bool , dumpStackified :: Bool - , stackify :: Bool + , runtime :: Maybe Runtime , inspectWasm :: Bool , output :: FilePath , sourceFile :: FilePath @@ -48,18 +54,32 @@ parseOutput = strOption <> value "-" ) +parseRuntime = option rdr . fold $ + [ long "runtime" + , short 'R' + , value Nothing + ] + where + rdr = maybeReader \case + "stackify" -> Just (Just Stackify) + "wasm" -> Just (Just Wasm) + "cps" -> Just (Just CPS) + "none" -> Just Nothing + _ -> Nothing + +parseDumpClosed = switch (long "dump-closed") 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' parser :: Parser Options parser = MkOptions - <$> parseDumpCPS + <$> parseDumpClosed + <*> parseDumpCPS <*> parseDumpParsed <*> parseDumpStackified - <*> parseStackify + <*> parseRuntime <*> parseInspectWasm <*> parseOutput <*> argument str (metavar "FILE") diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index c33de21..cab601a 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -15,6 +16,7 @@ module Gyehoek.Scheme.Syntax , Lit(..) , Def(..) , Exp(..) + , ExpF(..) , Sexp(..) , Program(..) , CommandOrDef(..) @@ -26,11 +28,15 @@ module Gyehoek.Scheme.Syntax , scm , readExp , readProgram + , free' + , freeWithBound' + , freeO + , encodeProgram ) where import Data.Text (Text) -import Data.List (List) +import Data.List (List, intersperse) import Language.SexpGrammar ( SexpIso(..), list, el, rest, sym, symbol ) import Language.SexpGrammar qualified as Sexp @@ -51,13 +57,15 @@ import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Foldable hiding (fold) import Data.HashSet (HashSet) import qualified Data.HashSet as HS -import Data.Foldable (fold) +import Data.Foldable (fold, toList) import Language.Haskell.TH.Quote (QuasiQuoter) import Effectful.FileSystem (runFileSystem) import qualified Effectful.FileSystem.IO as FS import qualified Data.Text.Encoding as T import qualified Effectful.FileSystem.IO.ByteString as FB import Control.DeepSeq (NFData) +import qualified Data.Set.Ordered as O +import Data.Sequence (Seq) newtype Name = MkName { inner :: Text } @@ -87,6 +95,7 @@ data Prim e | PrimNewline | PrimMakeClosure { code :: e, env :: List e } | PrimEnvRef e Int + | PrimEnvCode e | PrimCallCC e deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq) deriving anyclass (NFData) @@ -112,8 +121,8 @@ data Def deriving anyclass (NFData) data Exp - = ExpLet (NonEmpty (Name, Exp)) Exp - | ExpLetRec (NonEmpty (Name, Exp)) Exp + = ExpLet (List (Name, Exp)) Exp + | ExpLetRec (List (Name, Exp)) Exp | ExpPrim (Prim Exp) | ExpBegin (List Exp) | ExpIf Exp Exp Exp @@ -180,6 +189,7 @@ primSexpIso namefn a = match $ With (. nullop "newline") $ With (. ht1' "make-closure") $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int) + $ With (. ht1 "env-code") $ With (. ht1 "call/cc") $ End where @@ -253,6 +263,35 @@ instance SexpIso CommandOrDef where scm :: QuasiQuoter scm = GS.makeSx [|| GS.fromSexp @Exp ||] +freeWithBound' :: Foldable f => f Name -> Exp -> List Name +freeWithBound' bound = filter (`elem` bound) . free' + +freeO :: Exp -> O.OSet Name +freeO = O.unbiased . cata \case + ExpVarF x -> O.Bias @O.L $ O.singleton x + ExpLetF bs e -> + foldOf (each . _2) bs + <> (e & coerced %~ deleteFromO (bs ^.. each . _1)) + ExpLetRecF bs e -> + (foldOf (each . _2) bs & coerced %~ deleteFromO binds) + <> (e & coerced %~ deleteFromO binds) + where binds = bs ^.. each . _1 + ExpLambdaF bs e -> e & coerced %~ deleteFromO bs + e -> fold e + +free' :: Exp -> List Name +free' = toList @O.OSet . O.unbiased . cata \case + ExpVarF x -> O.Bias @O.L $ O.singleton x + ExpLetF bs e -> + foldOf (each . _2) bs + <> (e & coerced %~ deleteFromO (bs ^.. each . _1)) + ExpLetRecF bs e -> + (foldOf (each . _2) bs & coerced %~ deleteFromO binds) + <> (e & coerced %~ deleteFromO binds) + where binds = bs ^.. each . _1 + ExpLambdaF bs e -> e & coerced %~ deleteFromO bs + e -> fold e + free :: Exp -> HashSet Name free = cata \case ExpVarF x -> HS.singleton x @@ -260,6 +299,9 @@ free = cata \case ExpLambdaF binders vs -> deleteFrom binders vs e -> fold e +deleteFromO :: (Foldable f, Ord a) => f a -> O.OSet a -> O.OSet a +deleteFromO = flip $ foldr O.delete + deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a deleteFrom = flip $ foldr HS.delete @@ -292,3 +334,9 @@ readProgram fp = runFileSystem $ readExp :: IOE :> es => FilePath -> Eff es Exp readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command) + +encodeProgram :: Program -> Text +encodeProgram p = p.commandsAndDefs + & fmap ((^?! _Right) . GS.encodePretty) + & intersperse "\n\n" + & mconcat diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 2e12437..7b04e83 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -170,12 +170,12 @@ let_ :: Text -> (forall t. Grammar Position (Sexp :- t) (a :- t)) -> (forall t. Grammar Position (Sexp :- t) (b :- t)) - -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2 + -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2 -> Grammar Position (Sexp :- t1) t2 let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e) where -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _) - bindings = nonempty binding + bindings = list $ rest binding binding :: Grammar Position (Sexp :- t) ((_, _) :- t) binding = list (el name >>> el rhs) >>> pair @@ -304,6 +304,7 @@ instance Each Sexp Sexp Sexp Sexp where each k (SL.ParenList xs) = SL.ParenList <$> traverse k xs each k (SL.BracketList xs) = SL.BracketList <$> traverse k xs each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs + -- each k (SL.Modified m e) = SL.Modified m <$> each k e each _ e@(SL.Atom _; SL.Modified _ _) = pure e stripLocation :: Sexp -> Sexp @@ -348,10 +349,6 @@ unquoteSplicingRecursive xs = [| mconcat $(spans) |] _ (UnquoteSplicing _) -> False _ _ -> True & fmap \case - -- [e@(Unquote _)] -> - -- case unquote e of - -- Just x -> [| [$(x)] |] - -- Nothing -> error "unreachable" [UnquoteSplicing x] -> [| spliceSexp $(varE (mkName (T.unpack x))) |] es -> listE $ unquoteRecursive <$> es diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index a4da1c0..2909447 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -10,6 +10,7 @@ module Gyehoek.Stack.Syntax , Lit(..) , Obj(..) , Imm(..) + , Hob(..) , Prim(..) , Name , pattern ValLabel @@ -34,6 +35,7 @@ import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..)) import GHC.Exts (IsList(..)) import Data.List (intersperse) import Control.DeepSeq (NFData) +import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName) newtype Program = MkProgram @@ -79,18 +81,6 @@ data Val pattern ValLabel :: Name -> Val pattern ValLabel x = ValImm (ImmLabel x) -data Imm - = ImmInt Int - | ImmBool Bool - | ImmLabel Name - deriving stock (Show, Generic, Data, Eq) - deriving anyclass (NFData) - -data Obj - = ObjImm Imm - deriving stock (Show, Generic, Data, Eq) - deriving anyclass (NFData) - --- sexp work @@ -118,13 +108,6 @@ instance SexpIso Val where $ 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 @@ -143,8 +126,3 @@ 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 6faf2f3..9a44959 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -57,6 +57,18 @@ stepI e vm (Prim r p) = case evalVal e vm <$> p of PrimMul x y -> arith_binop (*) x y PrimSub x y -> arith_binop (-) x y PrimDiv x y -> arith_binop div x y + PrimMakeClosure f env -> + case f of + ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env + _ -> error [i|expected label, got #{f}|] + PrimEnvCode env -> + case env of + ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l + _ -> error [i|expected closure, got #{env}|] + PrimEnvRef env n -> + case env of + ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n + _ -> error [i|expected closure, got #{env}|] x -> error [i|unimplemented prim: #{p}|] where ret v = vm & #registers . at r ?~ v @@ -69,8 +81,8 @@ stepI e vm (Pop r) = case vm ^. #stack of (x:xs) -> vm & #registers . at r ?~ x & #stack .~ xs -stepI e vm (PopCont r) = case vm ^. #kstack of - [] -> error "empty stack" +stepI e vm ins@(PopCont r) = case vm ^. #kstack of + [] -> error [i|empty cont stack: #{ins}|] (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x) & #kstack .~ xs @@ -141,3 +153,5 @@ writeObj (ObjImm im) = case im of ImmBool True -> "#t" ImmBool False -> "#f" ImmLabel l -> "#" +writeObj (ObjHob h) = case h of + HobClosure code env -> "#" diff --git a/test/Gyehoek/Test/CPS/Eval.hs b/test/Gyehoek/Test/CPS/Eval.hs new file mode 100644 index 0000000..7990309 --- /dev/null +++ b/test/Gyehoek/Test/CPS/Eval.hs @@ -0,0 +1,56 @@ +module Gyehoek.Test.CPS.Eval (root) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import Language.SexpGrammar () +import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..)) +import Gyehoek.CPS.Eval qualified as Sut +import Data.List (List) + + +root :: IO TestTree +root = pure . testGroup "cps interpreter" $ + [ prim + , 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)) + |] + ] + +evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion +evalsTo rs p = Sut.evalProgram p @?= rs + +prim = 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))))) + |] + ] + ] diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index a2264e9..4ef0b2d 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -25,10 +25,11 @@ brokenWasmTests = brokenStackifyTests :: List String brokenStackifyTests = - [ "adder" - , "let-fn" - , "callcc-nested1" -- requires closure-conversion - ] + [] + -- [ "adder" + -- , "let-fn" + -- , "callcc-nested1" -- requires closure-conversion + -- ] root :: IO TestTree root = do diff --git a/test/Gyehoek/Test/Scheme/Syntax.hs b/test/Gyehoek/Test/Scheme/Syntax.hs new file mode 100644 index 0000000..6eaa4b8 --- /dev/null +++ b/test/Gyehoek/Test/Scheme/Syntax.hs @@ -0,0 +1,27 @@ +module Gyehoek.Test.Scheme.Syntax (root) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import Language.SexpGrammar () +import Gyehoek.Scheme.Syntax (scm) +import Gyehoek.Scheme.Syntax qualified as Sut + + +root :: IO TestTree +root = pure . testGroup "scheme syntax" $ + [ freeTree + ] + +freeTree :: TestTree +freeTree = testGroup "free" + [ testCase "lambda" do + Sut.free' [scm| + (lambda (x y z k) (f x b a)) + |] @=? ["f","b","a"] + , testCase "exp" do + Sut.free' [scm| + (letrec ((x (lambda (r) (f a y))) + (y (lambda (r b) (f b x)))) + (g x y z)) + |] @=? ["f","a","g","z"] + ] diff --git a/test/Main.hs b/test/Main.hs index 22518ee..0f2ad3a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -5,8 +5,10 @@ import Test.Tasty.Silver.Interactive (defaultMain) import qualified Gyehoek.Test.Golden import qualified Gyehoek.Test.Sexp import qualified Gyehoek.Test.CPS.Syntax +import qualified Gyehoek.Test.Scheme.Syntax import qualified Gyehoek.Test.Stack.VM import qualified Gyehoek.Test.CPS.Stackify +import qualified Gyehoek.Test.CPS.Eval main :: IO () @@ -17,7 +19,9 @@ root = testGroup "test" <$> sequenceA [ Gyehoek.Test.Golden.root , Gyehoek.Test.Sexp.root , Gyehoek.Test.CPS.Syntax.root + , Gyehoek.Test.Scheme.Syntax.root , Gyehoek.Test.Stack.VM.root , Gyehoek.Test.CPS.Stackify.root + , Gyehoek.Test.CPS.Eval.root ]