tests
This commit is contained in:
msyds committed
1 parent
475f0a7f68
commit
d71d78c68f
24 files changed
+458
-120
No files matched your search
@@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Gyehoek.CPS.Convert
|
||||
( convert
|
||||
, convertProgram
|
||||
) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
import Control.Lens
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
|
||||
convert
|
||||
:: forall es. (GenSym :> es)
|
||||
=> Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
|
||||
|
||||
convert (Scm.ExpVar x) k = k $ ValVar x
|
||||
convert (Scm.ExpLit l) k = k $ ValLit l
|
||||
|
||||
convert (Scm.ExpPrim p) k =
|
||||
telescope (convert @es) p \p' -> do
|
||||
r <- gensym' "r"
|
||||
ExpPrim p' [r] <$> k (ValVar r)
|
||||
|
||||
convert (Scm.ExpLambda xs e) k = do
|
||||
f <- gensym' "λ-body"
|
||||
ktail <- gensym' "λ-tail"
|
||||
m <- convert e $ \e' ->
|
||||
pure $ ExpContinue ktail [e']
|
||||
ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f)
|
||||
|
||||
convert (Scm.ExpApply f xs) k =
|
||||
telescope (convert @es) (f:|xs) \(f':|xs') -> do
|
||||
r <- gensym' "r"
|
||||
x <- gensym' "x"
|
||||
m <- k (ValVar x)
|
||||
pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
|
||||
|
||||
convert (Scm.ExpBegin xs) k = _
|
||||
|
||||
convert (Scm.ExpIf c t f) k =
|
||||
convert c \c' ->
|
||||
ExpIf c' <$> convert t k <*> convert f k
|
||||
|
||||
convert _ k = _
|
||||
|
||||
convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
|
||||
convertProgram p =
|
||||
MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
|
||||
pure . Halt1 $ case NE.nonEmpty exps of
|
||||
Nothing -> ValLit Void
|
||||
Just es -> NE.last es
|
||||
@@ -0,0 +1,107 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultilineStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
||||
module Gyehoek.CPS.Lower
|
||||
(
|
||||
lower, lowerProgram) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Data.Generics.Labels
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
import Effectful.Writer.Static.Local
|
||||
import Data.Text (Text)
|
||||
import Data.Vector.Strict (Vector)
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Numeric.Natural
|
||||
import GHC.Generics (Generic)
|
||||
import Gyehoek.Scheme.Syntax (Lit(..))
|
||||
import Text.Printf
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector.Strict as V
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.String.Interpolate
|
||||
import Gyehoek.Wasm qualified as Wasm
|
||||
import Gyehoek.Wasm (i32, ins, sxp)
|
||||
|
||||
|
||||
data Env = MkEnv { vars :: Vector Name }
|
||||
deriving (Show, Generic)
|
||||
|
||||
emptyEnv :: Env
|
||||
emptyEnv = MkEnv mempty
|
||||
|
||||
type instance Index Env = Natural
|
||||
type instance IxValue Env = Name
|
||||
|
||||
instance Ixed Env where
|
||||
ix i = #vars . ix (fromIntegral i)
|
||||
|
||||
|
||||
|
||||
tshow :: Show a => a -> Text
|
||||
tshow = T.pack . show
|
||||
|
||||
|
||||
|
||||
lowerVal :: Env -> Val -> Wasm.Expr
|
||||
|
||||
lowerVal g (ValLit l) =
|
||||
case l of
|
||||
LitInt n -> ins "i32.const" [sxp n]
|
||||
LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
|
||||
_ -> _
|
||||
|
||||
lowerVal g (ValVar x) = ins "local.get" [sxp l]
|
||||
where
|
||||
l = V.elemIndex x g.vars ^?! _Just
|
||||
|
||||
lower' :: Env -> Exp -> Wasm.Expr
|
||||
|
||||
lower' g (Halt [e]) = lowerVal g e
|
||||
|
||||
lower' g (ExpPrim p rs e) =
|
||||
case p of
|
||||
PrimAdd x y -> lowerBinOp "i32.add" g x y r e
|
||||
PrimMul x y -> lowerBinOp "i32.mul" g x y r e
|
||||
where
|
||||
r = head rs
|
||||
|
||||
lower' g (ExpIf c t f) =
|
||||
lowerVal g c
|
||||
<> Wasm.if' (Wasm.result [i32])
|
||||
(lower' g t)
|
||||
(lower' g f)
|
||||
|
||||
lowerBinOp
|
||||
:: _
|
||||
-> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
|
||||
lowerBinOp op g x y r e =
|
||||
lowerVal g x
|
||||
<> lowerVal g y
|
||||
<> ins op []
|
||||
<> ins "local.set" [sxp n]
|
||||
<> lower' g' e
|
||||
where
|
||||
g' = g & #vars <>~ [r]
|
||||
n = length (g ^. #vars)
|
||||
|
||||
|
||||
|
||||
lower :: Exp -> Eff es Text
|
||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
|
||||
lower' emptyEnv e
|
||||
Wasm.export "main" "func" main
|
||||
|
||||
lowerProgram :: Program -> Eff es Text
|
||||
lowerProgram (MkProgram e) = lower e
|
||||
@@ -0,0 +1,139 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Gyehoek.CPS.Syntax
|
||||
( Val(..)
|
||||
, Kappa(..)
|
||||
, Lambda(..)
|
||||
, Exp(..)
|
||||
, Name(..)
|
||||
, Prim(..)
|
||||
, Program(..)
|
||||
, Lit(..)
|
||||
, pattern Void
|
||||
, pattern Halt
|
||||
, pattern Halt1
|
||||
, _MkKappa
|
||||
, _ExpPrim
|
||||
, _ExpFix
|
||||
, _ExpApply
|
||||
)
|
||||
where
|
||||
|
||||
import Language.SexpGrammar qualified as S
|
||||
import Gyehoek.Sexp qualified
|
||||
import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
|
||||
import Data.Text (Text)
|
||||
import Data.List (List)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.SexpGrammar.Generic
|
||||
import Control.Category
|
||||
import Control.Lens
|
||||
import Data.Text qualified as T
|
||||
import Data.Generics.Labels
|
||||
import Prelude hiding ((.), id)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.InvertibleGrammar.Base qualified as IGB
|
||||
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
||||
import qualified Data.InvertibleGrammar as IG
|
||||
|
||||
-- Data types
|
||||
|
||||
data Val
|
||||
= ValLabel Name
|
||||
| ValVar Name
|
||||
| ValLit Lit
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Kappa = MkKappa (List Name) Exp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Lambda = MkLambda (List Name) Name Exp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Exp
|
||||
= ExpPrim (Prim Val) (List Name) Exp
|
||||
| ExpFix (NonEmpty (Name, Kappa)) Exp
|
||||
| ExpLet (NonEmpty (Name, Lambda)) Exp
|
||||
| ExpContinue Name (List Val)
|
||||
| ExpIf Val Exp Exp
|
||||
| ExpApply Val (List Val)
|
||||
deriving (Show, Generic)
|
||||
|
||||
pattern Halt :: List Val -> Exp
|
||||
pattern Halt xs = ExpApply (ValVar "halt") xs
|
||||
|
||||
pattern Halt1 :: Val -> Exp
|
||||
pattern Halt1 x = ExpApply (ValVar "halt") [x]
|
||||
|
||||
data Def = DefConstant Name Exp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Program = MkProgram
|
||||
{ body :: Exp
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
makePrisms ''Kappa
|
||||
makePrisms ''Exp
|
||||
|
||||
|
||||
-- SexpIso instances
|
||||
|
||||
instance S.SexpIso Val where
|
||||
sexpIso = match
|
||||
$ With (. label)
|
||||
$ With (. var)
|
||||
$ With (. S.sexpIso)
|
||||
$ End
|
||||
where
|
||||
label = S.keyword >>> S.iso MkName getName
|
||||
var = S.sexpIso
|
||||
|
||||
instance S.SexpIso Lambda where
|
||||
sexpIso = match
|
||||
$ With (. lambda)
|
||||
$ End
|
||||
where
|
||||
lambda = S.list $
|
||||
S.el Gyehoek.Sexp.lambdaKeyword
|
||||
>>> S.el (S.list (S.rest S.sexpIso))
|
||||
>>> S.el S.sexpIso
|
||||
>>> S.el S.sexpIso
|
||||
|
||||
instance S.SexpIso Kappa where
|
||||
sexpIso = match
|
||||
$ With (. kappa)
|
||||
$ End
|
||||
where
|
||||
kappa = S.list $
|
||||
S.el Gyehoek.Sexp.kappaKeyword
|
||||
>>> S.el (S.list $ S.rest S.sexpIso)
|
||||
>>> S.el S.sexpIso
|
||||
|
||||
instance S.SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ With (. prim)
|
||||
$ With (. fix)
|
||||
$ With (. let_)
|
||||
$ With (. continue)
|
||||
$ With (. if_)
|
||||
$ With (. app)
|
||||
$ End
|
||||
where
|
||||
continue = S.list $
|
||||
S.el (S.sym "continue")
|
||||
>>> S.el S.sexpIso
|
||||
>>> S.rest S.sexpIso
|
||||
fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
|
||||
let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso S.sexpIso
|
||||
if_ = S.list $ S.el (S.sym "if")
|
||||
>>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
|
||||
app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
|
||||
prim = S.list $
|
||||
S.el (S.sym "prim")
|
||||
>>> S.el (primSexpIso id (S.sexpIso @Val))
|
||||
>>> S.el S.sexpIso
|
||||
>>> S.el S.sexpIso
|
||||
|
||||
instance S.SexpIso Program where
|
||||
sexpIso = with \prog -> S.sexpIso @Exp >>> prog
|
||||
Reference in new issue
Block a user