diff --git a/app/Gyehoek/CPS/Lower.hs b/app/Gyehoek/CPS/Lower.hs index 90e0cc4..530f9fd 100644 --- a/app/Gyehoek/CPS/Lower.hs +++ b/app/Gyehoek/CPS/Lower.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Gyehoek.CPS.Lower ( @@ -31,7 +31,7 @@ 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) +import Gyehoek.Wasm (i32, ins, sxp) data Env = MkEnv { vars :: Vector Name } @@ -57,10 +57,10 @@ lowerVal :: Env -> Val -> Wasm.Expr lowerVal g (ValLit l) = case l of - LitInt n -> [i|i32.const #{n}|] + LitInt n -> [ ins "i32.const" [sxp n] ] _ -> _ -lowerVal g (ValVar x) = [i|local.get #{l}|] +lowerVal g (ValVar x) = [ ins "local.get" [sxp l] ] where l = V.elemIndex x g.vars ^?! _Just @@ -81,8 +81,8 @@ lowerBinOp lowerBinOp op g x y r e = lowerVal g x <> lowerVal g y - <> op - <> [i|local.set #{n}|] + <> [ ins op [] ] + <> [ ins "local.set" [sxp n] ] <> lower' g' e where g' = g & #vars <>~ [r] diff --git a/app/Gyehoek/Sexp.hs b/app/Gyehoek/Sexp.hs index 826649b..ea90a8f 100644 --- a/app/Gyehoek/Sexp.hs +++ b/app/Gyehoek/Sexp.hs @@ -19,11 +19,13 @@ module Gyehoek.Sexp , lambda , kappaKeyword , lambdaKeyword + , encodePrettyWith + , encodePretty ) where import Data.Text (Text) -import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso) +import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty) import Language.SexpGrammar qualified as Sexp import Language.Sexp qualified as S import Language.SexpGrammar.Generic @@ -59,9 +61,16 @@ decode = decodeWith sexpIso encodeWith :: SexpGrammar a -> a -> Either String Text encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g +encodePretty :: SexpIso a => a -> Either String Text +encodePretty = encodePrettyWith sexpIso + decodeWith :: SexpGrammar a -> Text -> Either String a decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8 +encodePrettyWith :: SexpGrammar a -> a -> Either String Text +encodePrettyWith g = + (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g + parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a) parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8 where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso) diff --git a/app/Gyehoek/Wasm.hs b/app/Gyehoek/Wasm.hs index de8ddbe..be1deee 100644 --- a/app/Gyehoek/Wasm.hs +++ b/app/Gyehoek/Wasm.hs @@ -1,8 +1,13 @@ {- HLINT ignore "Use newtype instead of data" -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeepSubsumption #-} {-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ImpredicativeTypes #-} module Gyehoek.Wasm ( defun , deftype @@ -17,9 +22,15 @@ module Gyehoek.Wasm , GenMod , i32 , export + , ins + , sxp ) where +import Language.SexpGrammar + ( SexpIso(..), list, el, (>>>), rest, sym, symbol ) +import Language.SexpGrammar qualified as Sexp +import Language.SexpGrammar.Generic import Data.List (List) import GHC.Generics (Generic) import Data.Text (Text) @@ -37,6 +48,13 @@ import qualified Data.Vector as V import qualified Data.Text as T import Effectful.Writer.Dynamic import Control.Applicative (Alternative((<|>))) +import Control.Category qualified as Cat +import Data.Vector.Lens +import Data.Either (fromLeft, fromRight) +import Language.Sexp.Located +import qualified Gyehoek.Sexp +import GHC.IsList (IsList(..)) +import Data.Coerce (coerce) data Module = MkModule @@ -66,30 +84,18 @@ data Function = MkFunction } deriving (Show, Generic) -newtype Export = MkExport { getExport :: Text } - deriving (Generic) - deriving newtype (Show, IsString) +newtype Export = MkExport { inner :: Sexp } + deriving (Show, Generic) -newtype Expr = MkExpr { getExpr :: Vector Instr } - deriving (Generic) +newtype Expr = MkExpr { inner :: Vector Instr } + deriving (Show, Generic) deriving newtype (Semigroup, Monoid) -instance IsString Expr where - fromString s = MkExpr . V.fromList $ fromString <$> lines s +newtype Instr = MkInstr { inner :: Sexp } + deriving (Show, Generic) -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 Type = MkType { inner :: Sexp } + deriving (Show, Generic) newtype Idx = MkIdx { getIdx :: Natural } deriving newtype (Show) @@ -135,7 +141,9 @@ runGenMod = ) _ (Start idx) -> assign #start (Just idx) _ (Export name ty idx) -> - #exports <>= V.singleton [i|(export #{show name} (#{ty} #{idx}))|] + #exports <>= V.singleton e + where e = MkExport $ ParenList + [ "export", sxp name, ParenList [ "func", sxp idx ] ] _ (Defun params result locals code) -> state \m -> let idx = MkIdx . fromIntegral . length $ m.functions in ( idx @@ -145,46 +153,66 @@ runGenMod = 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 +renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty i32 :: Type -i32 = "i32" +i32 = MkType $ Symbol "i32" + + + +instance SexpIso Idx where + sexpIso = Sexp.integer >>> Sexp.partialOsi f g + where + f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural" + | otherwise = Right . MkIdx $ fromIntegral n + g (MkIdx n) = fromIntegral n + +instance SexpIso Instr where + sexpIso = Sexp.iso coerce coerce + +instance SexpIso Type where + sexpIso = Sexp.iso coerce coerce + +instance SexpIso Export where + sexpIso = Sexp.iso coerce coerce + +instance SexpIso Function where + sexpIso = with \func -> + list ( el (sym "func") + >>> el (list $ el (sym "param") >>> rest (sexpIso @Type)) + >>> el (list $ el (sym "result") >>> rest (sexpIso @Type)) + >>> el (list $ el (sym "local") >>> rest (sexpIso @Type)) + >>> rest (sexpIso @Instr) + >>> Sexp.onTail + (Sexp.iso + (view instrsExpr) + (review instrsExpr)) + ) + >>> func + where + instrsExpr :: Iso' (List Instr) Expr + instrsExpr = vector . coerced + +instance SexpIso Module where + sexpIso = Sexp.partialOsi (const $ Left mempty) \m -> + ParenList $ + [ Symbol "module" ] + <> (m ^.. #types . each . #inner) + <> (m ^.. #functions . each . to sxp) + <> (m ^.. #exports . each . to sxp) + +sxp :: SexpIso a => a -> Sexp +sxp e = Sexp.toSexp sexpIso e ^?! _Right + +ins :: Text -> List Sexp -> Instr +ins op [] = MkInstr $ Symbol op +ins op xs = MkInstr . ParenList $ Symbol op : xs + +instance IsString Sexp where + fromString = Symbol . T.pack + +instance IsList Expr where + type Item Expr = Instr + fromList = MkExpr . V.fromList + toList e = V.toList e.inner diff --git a/t.wat b/t.wat index 7a74178..8400043 100644 --- a/t.wat +++ b/t.wat @@ -1,20 +1,17 @@ (module - - (func (param ) - (result i32) - (local i32 i32 i32 i32 i32) - i32.const 3 - i32.const 4 + (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 + (local.set 0) + (i32.const 2) + (i32.const 5) i32.mul - local.set 1 - local.get 0 - local.get 1 + (local.set 1) + (local.get 0) + (local.get 1) i32.add - local.set 2 - local.get 2) - + (local.set 2) + (local.get 2)) (export "main" (func 0))) \ No newline at end of file