From b630cddb831e700436e9ae1f221b6cd97144bde1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 10 Jul 2026 22:40:10 -0600 Subject: [PATCH] we r so bak --- app/Gyehoek/CPS/Lower.hs | 34 ++++---- app/Gyehoek/GenSym.hs | 8 ++ app/Gyehoek/Wasm.hs | 174 +++++++++++++++++++++++++++++++++++++-- gyehoek.cabal | 2 + t.wat | 20 +++++ 5 files changed, 216 insertions(+), 22 deletions(-) create mode 100644 t.wat diff --git a/app/Gyehoek/CPS/Lower.hs b/app/Gyehoek/CPS/Lower.hs index 1952724..90e0cc4 100644 --- a/app/Gyehoek/CPS/Lower.hs +++ b/app/Gyehoek/CPS/Lower.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -28,6 +29,9 @@ 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) data Env = MkEnv { vars :: Vector Name } @@ -49,18 +53,18 @@ tshow = T.pack . show -lowerVal :: Env -> Val -> Vector Text +lowerVal :: Env -> Val -> Wasm.Expr lowerVal g (ValLit l) = case l of - LitInt n -> [ "i32.const " <> tshow n ] + LitInt n -> [i|i32.const #{n}|] _ -> _ -lowerVal g (ValVar x) = [ "local.get " <> tshow i ] +lowerVal g (ValVar x) = [i|local.get #{l}|] where - i = V.elemIndex x g.vars ^?! _Just + l = V.elemIndex x g.vars ^?! _Just -lower' :: Env -> Exp -> Vector Text +lower' :: Env -> Exp -> Wasm.Expr lower' g (Halt [e]) = lowerVal g e @@ -71,10 +75,14 @@ lower' g (ExpPrim p rs e) = where r = head rs +lowerBinOp + :: _ + -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr lowerBinOp op g x y r e = lowerVal g x <> lowerVal g y - <> [ op, "local.set " <> tshow n ] + <> op + <> [i|local.set #{n}|] <> lower' g' e where g' = g & #vars <>~ [r] @@ -82,14 +90,8 @@ lowerBinOp op g x y r e = -makeFunc :: Vector Text -> Text -makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent - where - indent = (" "<>) - preamble = "(module\n\ - \ (func (export \"main\") (result i32)\n\ - \ (local i32 i32 i32 i32 i32 i32)\n" - postamble = " ))" - lower :: Exp -> Eff es Text -lower = pure . makeFunc . lower' emptyEnv +lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do + idx <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ -> + lower' emptyEnv e + Wasm.export "main" "func" idx diff --git a/app/Gyehoek/GenSym.hs b/app/Gyehoek/GenSym.hs index 839a74f..1e4cd2d 100644 --- a/app/Gyehoek/GenSym.hs +++ b/app/Gyehoek/GenSym.hs @@ -35,3 +35,11 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases instance Gen Text where gen = fromString . ('x':) . show gen' s = (s <>) . fromString . show + +instance Gen Natural where + gen = id + gen' = const id + +instance Gen Int where + gen = fromIntegral + gen' _ = fromIntegral diff --git a/app/Gyehoek/Wasm.hs b/app/Gyehoek/Wasm.hs index 335949f..de8ddbe 100644 --- a/app/Gyehoek/Wasm.hs +++ b/app/Gyehoek/Wasm.hs @@ -1,19 +1,62 @@ {- HLINT ignore "Use newtype instead of data" -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedLabels #-} module Gyehoek.Wasm - () + ( defun + , deftype + , start + , runGenMod + , execGenMod + , renderModule + , Module + , Function + , Expr + , Instr + , GenMod + , i32 + , export + ) where import Data.List (List) import GHC.Generics (Generic) +import Data.Text (Text) +import Data.String (IsString (fromString)) +import Text.Printf +import Effectful +import Numeric.Natural (Natural) +import Effectful.Dispatch.Dynamic +import Effectful.State.Dynamic +import Control.Lens +import Data.Generics.Labels +import Data.Vector (Vector) +import Data.String.Interpolate +import qualified Data.Vector as V +import qualified Data.Text as T +import Effectful.Writer.Dynamic +import Control.Applicative (Alternative((<|>))) data Module = MkModule - { typeSection :: List Type + { types :: Vector Type + , functions :: Vector Function + , start :: Maybe Idx + , exports :: Vector Export } deriving (Show, Generic) -data Type - deriving (Show, Generic) +instance Semigroup Module where + m1 <> m2 = MkModule + { types = m1.types <> m2.types + , functions = m1.functions <> m2.functions + , start = m2.start <|> m1.start + , exports = m1.exports <> m2.exports + } + +instance Monoid Module where + mempty = MkModule mempty mempty Nothing mempty data Function = MkFunction { params :: List Type @@ -23,6 +66,125 @@ data Function = MkFunction } deriving (Show, Generic) -type Expr = List Instr +newtype Export = MkExport { getExport :: Text } + deriving (Generic) + deriving newtype (Show, IsString) -type Instr = ByteString +newtype Expr = MkExpr { getExpr :: Vector Instr } + deriving (Generic) + deriving newtype (Semigroup, Monoid) + +instance IsString Expr where + fromString s = MkExpr . V.fromList $ fromString <$> lines s + +instance Show Expr where + show e = unlines . fmap show . V.toList $ e.getExpr + +newtype Instr = MkInstr { getInstr :: Text } + deriving (Generic) + deriving newtype (IsString) + +instance Show Instr where + show e = T.unpack e.getInstr + +newtype Type = MkType { getType :: Text } + deriving (Generic) + deriving newtype (Show, IsString) + +newtype Idx = MkIdx { getIdx :: Natural } + deriving newtype (Show) + +data GenMod :: Effect where + DefType :: Type -> GenMod m Idx + Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx + Start :: Idx -> GenMod m () + Export :: Text -> Text -> Idx -> GenMod m () + +type instance DispatchOf GenMod = Dynamic + +export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es () +export name ty idx = send $ Export name ty idx + +start :: (GenMod :> es) => Idx -> Eff es () +start = send . Start + +deftype :: (GenMod :> es) => Type -> Eff es Idx +deftype = send . DefType + +defun + :: (GenMod :> es) + => List Type -> List Type -> List Type + -> (Idx -> Expr) + -> Eff es Idx +defun params result locals code = send $ Defun params result locals code + +-- defun +-- :: (GenMod :> es) +-- => List Type -> List Type -> List Type +-- -> (Idx -> Eff '[GenExp] a) +-- -> Eff es Idx +-- defun params result locals code = +-- send $ Defun params result locals (runPureEff . execWriterLocal . code) + +runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module) +runGenMod = + reinterpret (runStateLocal (mempty :: Module)) \cases + _ (DefType t) -> state \m -> + ( MkIdx . fromIntegral . length $ m.types + , m & #types <>~ V.singleton t + ) + _ (Start idx) -> assign #start (Just idx) + _ (Export name ty idx) -> + #exports <>= V.singleton [i|(export #{show name} (#{ty} #{idx}))|] + _ (Defun params result locals code) -> state \m -> + let idx = MkIdx . fromIntegral . length $ m.functions + in ( idx + , m & #functions <>~ V.singleton + (MkFunction params result locals (code idx)) + ) + +execGenMod = fmap snd . runGenMod + +indent n = (T.replicate n " " <>) + +unlines' :: Foldable f => f Text -> Text +unlines' = foldr f "" + where + f a "" = a + f a b = a <> "\n" <> b + +renderModule :: Module -> Text +renderModule m = [__i| + (module + #{types} + #{functions} + #{strt} + #{exports}) +|] + where + strt :: Text + strt = case m.start of + Just x -> [i|(start #{x})|] + Nothing -> "" + exports = unlines' $ view #getExport <$> m.exports + types = foldMapOf (#types . each . #getType) (indent 2) m + functions = unlines' $ + indent 2 . showfunc <$> m.functions + showtypes ts = T.unwords $ fmap (\x -> x.getType) ts + showfunc :: Function -> Text + showfunc func = [__i| + (func (param #{params}) + (result #{result}) + (local #{locals}) + #{body}) + |] + where + params = showtypes func.params + result = showtypes func.result + locals = showtypes func.locals + body = unlines' $ indent 4 . view #getInstr <$> func.body.getExpr + +type GenExp = Writer Expr + +i32 :: Type +i32 = "i32" diff --git a/gyehoek.cabal b/gyehoek.cabal index c8fac5f..e85866b 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -29,6 +29,7 @@ common ghcstuffs OverloadedStrings PartialTypeSignatures PatternSynonyms + QuasiQuotes executable gyehoek import: ghcstuffs, ghcstuffs-dev @@ -70,6 +71,7 @@ executable gyehoek , text-short , unordered-containers , vector + , string-interpolate hs-source-dirs: app default-language: GHC2024 diff --git a/t.wat b/t.wat new file mode 100644 index 0000000..7a74178 --- /dev/null +++ b/t.wat @@ -0,0 +1,20 @@ +(module + + (func (param ) + (result i32) + (local i32 i32 i32 i32 i32) + i32.const 3 + i32.const 4 + i32.mul + local.set 0 + i32.const 2 + i32.const 5 + i32.mul + local.set 1 + local.get 0 + local.get 1 + i32.add + local.set 2 + local.get 2) + + (export "main" (func 0))) \ No newline at end of file