sexp
This commit is contained in:
@@ -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]
|
||||
|
||||
+10
-1
@@ -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)
|
||||
|
||||
+89
-61
@@ -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
|
||||
|
||||
@@ -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)))
|
||||
Reference in New Issue
Block a user