426 lines
12 KiB
Haskell
426 lines
12 KiB
Haskell
{- HLINT ignore "Use newtype instead of data" -}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE DeepSubsumption #-}
|
|
{-# LANGUAGE NoFieldSelectors #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
{-# LANGUAGE RecordPuns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE ImpredicativeTypes #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
module Gyehoek.Wasm
|
|
( defun
|
|
, rec'
|
|
, start
|
|
, runGenMod
|
|
, execGenMod
|
|
, renderModule
|
|
, Module
|
|
, Function
|
|
, Type(..)
|
|
, Expr
|
|
, Instr
|
|
, GenMod
|
|
, Idx
|
|
, i32
|
|
, export
|
|
, ins
|
|
, sxp
|
|
, result
|
|
, param
|
|
, if'
|
|
, ref
|
|
, eq
|
|
, i31ref
|
|
, i31
|
|
, struct
|
|
, mut
|
|
, sub
|
|
, deftype
|
|
, namedType
|
|
, type'
|
|
, deftypeNamed
|
|
, defglobal
|
|
, array
|
|
, FromIdx(..)
|
|
, func
|
|
, refnull
|
|
, declareFuncref
|
|
)
|
|
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, Generically(..))
|
|
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((<|>)))
|
|
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)
|
|
import qualified Control.Category
|
|
import Data.Functor (void)
|
|
|
|
|
|
data Module = MkModule
|
|
{ types :: Vector RecType
|
|
, functions :: Vector Function
|
|
, funcrefs :: Vector Funcref
|
|
, start :: Maybe Idx
|
|
, exports :: Vector Export
|
|
, globals :: Vector Global
|
|
}
|
|
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
|
|
, funcrefs = m1.funcrefs <> m2.funcrefs
|
|
, globals = m1.globals <> m2.globals
|
|
}
|
|
|
|
instance Monoid Module where
|
|
mempty = MkModule mempty mempty mempty Nothing mempty mempty
|
|
|
|
newtype Funcref = MkFuncref { inner :: Idx }
|
|
deriving (Show, Generic)
|
|
|
|
data Global = MkGlobal
|
|
{ ty :: Type
|
|
, body :: Expr
|
|
}
|
|
deriving (Show, Generic)
|
|
|
|
newtype RecType = MkRecType { inner :: Vector Type }
|
|
deriving (Show, Generic)
|
|
|
|
data Function = MkFunction
|
|
{ params :: List Type
|
|
, result :: List Type
|
|
, locals :: List Type
|
|
, body :: Expr
|
|
}
|
|
deriving (Show, Generic)
|
|
|
|
newtype Export = MkExport { inner :: Sexp }
|
|
deriving (Show, Generic)
|
|
|
|
newtype Expr = MkExpr { inner :: Vector Instr }
|
|
deriving (Show, Generic)
|
|
deriving newtype (Semigroup, Monoid)
|
|
|
|
newtype Instr = MkInstr { inner :: Sexp }
|
|
deriving (Show, Generic)
|
|
|
|
newtype Type = MkType { inner :: Sexp }
|
|
deriving (Show, Generic)
|
|
|
|
data Idx
|
|
= IdxNumeric Natural
|
|
| IdxNamed Text
|
|
deriving (Show, Generic)
|
|
|
|
data GenMod :: Effect where
|
|
DefRecType :: List Type -> GenMod m (List Idx)
|
|
Defun :: List Type -> List Type -> List Type
|
|
-> (Idx -> m Expr) -> GenMod m Idx
|
|
Start :: Idx -> GenMod m ()
|
|
Export :: Text -> Text -> Idx -> GenMod m ()
|
|
DefGlobal :: Type -> Expr -> GenMod m Idx
|
|
DeclareFuncref :: 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
|
|
|
|
rec' :: (GenMod :> es) => List Type -> Eff es (List Idx)
|
|
rec' = send . DefRecType
|
|
|
|
deftype :: (GenMod :> es) => Type -> Eff es Idx
|
|
deftype (MkType t) = send (DefRecType [type' t]) <&> \case
|
|
[x] -> x
|
|
x -> error $ "unreachable " <> show x
|
|
|
|
deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
|
|
deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
|
|
|
|
defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
|
|
defglobal t e = send $ DefGlobal t e
|
|
|
|
defun
|
|
:: (GenMod :> es)
|
|
=> List Type -> List Type -> List Type
|
|
-> (Idx -> Eff es Expr)
|
|
-> Eff es Idx
|
|
defun params res locals code = send $ Defun params res locals code
|
|
|
|
declareFuncref :: GenMod :> es => Idx -> Eff es ()
|
|
declareFuncref = send . DeclareFuncref
|
|
|
|
-- 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 :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module)
|
|
runGenMod =
|
|
reinterpret (runStateLocal (mempty :: Module)) \cases
|
|
_ (DefRecType ts) -> state \m ->
|
|
( let prev_n = sumOf (#types . each . #inner . to V.length) m
|
|
in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1]
|
|
, m & #types <>~ V.singleton (MkRecType (V.fromList ts))
|
|
)
|
|
_ (Start idx) -> assign #start (Just idx)
|
|
_ (Export name ty idx) ->
|
|
#exports <>= V.singleton e
|
|
where e = MkExport $ ParenList
|
|
[ "export", sxp name, ParenList [ "func", sxp idx ] ]
|
|
env (Defun params result locals code) ->
|
|
localSeqUnlift env \unlift ->
|
|
stateM \m -> do
|
|
-- the least unused function index, computed as the number
|
|
-- of currently allocated functions.
|
|
let idx = IdxNumeric . fromIntegral . length $ m.functions
|
|
-- the body is computed with access to the newly allocated
|
|
-- index `idx` for the sake of recursive occurences.
|
|
body <- unlift $ code idx
|
|
let func = MkFunction {params,result,locals,body}
|
|
let m' = m & #functions <>~ V.singleton func
|
|
pure (idx, m')
|
|
_ (DefGlobal t e) -> state \m ->
|
|
let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
|
|
m' = m & #globals <>~ V.singleton (MkGlobal t e)
|
|
in (prev_n, m')
|
|
_ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx)
|
|
|
|
execGenMod = fmap snd . runGenMod
|
|
|
|
renderModule :: Module -> Text
|
|
renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
|
|
|
|
ref :: Type -> Type
|
|
ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
|
|
|
|
refnull :: Type -> Type
|
|
refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
|
|
|
|
sub :: List Idx -> Type -> Type
|
|
sub supers (MkType x) = MkType . ParenList $
|
|
Symbol "sub" : (sxp <$> supers) ++ [x]
|
|
|
|
array :: Type -> Type
|
|
array (MkType x) = MkType . ParenList $ [Symbol "array", x]
|
|
|
|
mut :: Type -> Type
|
|
mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
|
|
|
|
struct :: List Type -> Type
|
|
struct xs = MkType . ParenList $
|
|
Symbol "struct" : (xs ^.. each . #inner . to field)
|
|
where field x = ParenList [Symbol "field", x]
|
|
|
|
func :: List Type -> List Type -> Type
|
|
func params results =
|
|
MkType . ParenList $
|
|
[ Symbol "func"
|
|
, wrap "param" params
|
|
, wrap "result" results
|
|
]
|
|
where
|
|
wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
|
|
|
|
i32, i31ref, eq, i31 :: Type
|
|
i32 = MkType $ Symbol "i32"
|
|
i31ref = MkType $ Symbol "i31ref"
|
|
eq = MkType $ Symbol "eq"
|
|
i31 = MkType $ Symbol "i31"
|
|
|
|
class FromIdx a where
|
|
fromIdx :: Idx -> a
|
|
|
|
instance FromIdx Type where
|
|
fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
|
|
|
|
|
|
|
|
instance SexpIso Idx where
|
|
sexpIso = match
|
|
$ With (\numeric -> num >>> numeric)
|
|
$ With (\named -> name >>> named)
|
|
$ End
|
|
where
|
|
num = Sexp.integer >>> Sexp.partialOsi f g
|
|
where
|
|
f n | n < 0 = Left $ Sexp.unexpected "negative"
|
|
<> Sexp.expected "natural"
|
|
| otherwise = Right $ fromIntegral n
|
|
g n = fromIntegral n
|
|
l :: Prism' Text Text
|
|
l = prefixed "$"
|
|
name = Sexp.symbol >>> Sexp.partialOsi
|
|
(maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l)
|
|
(review l)
|
|
|
|
instance SexpIso RecType where
|
|
sexpIso = with \rectype ->
|
|
Sexp.coproduct
|
|
[ sexpIso @Type >>> Sexp.partialIso
|
|
(\x -> [x])
|
|
(\case [x] -> Right x
|
|
_ -> Left $ Sexp.expected "a single type")
|
|
, list (el (sym "rec") >>> rest sexpIso)
|
|
]
|
|
>>> Sexp.iso V.fromList V.toList
|
|
>>> rectype
|
|
-- where
|
|
-- typedef
|
|
-- :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t)
|
|
-- -> Sexp.Grammar Position (Sexp :- t) (a :- t)
|
|
-- typedef x = list (el (sym "type") >>> el x)
|
|
|
|
type' :: Sexp -> Type
|
|
type' e = MkType . ParenList $ [ "type", e ]
|
|
|
|
namedType :: Text -> Sexp -> Type
|
|
namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
|
|
|
|
instance SexpIso Global where
|
|
sexpIso = with \glob ->
|
|
list ( el (sym "global")
|
|
>>> el (sexpIso @Type)
|
|
>>> restCode
|
|
)
|
|
>>> glob
|
|
|
|
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
|
|
|
|
restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
|
|
restCode =
|
|
rest (sexpIso @Instr)
|
|
>>> Sexp.onTail
|
|
(Sexp.iso
|
|
(view instrsExpr)
|
|
(review instrsExpr))
|
|
where
|
|
instrsExpr :: Iso' (List Instr) Expr
|
|
instrsExpr = vector . coerced
|
|
|
|
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))
|
|
>>> restCode
|
|
)
|
|
>>> func
|
|
|
|
instance SexpIso Module where
|
|
sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
|
|
ParenList $
|
|
[ Symbol "module" ]
|
|
<> (m ^.. #types . each . to sxp)
|
|
<> (m ^.. #funcrefs . each . to sxp)
|
|
<> (m ^.. #functions . each . to sxp)
|
|
<> (m ^.. #exports . each . to sxp)
|
|
|
|
instance SexpIso Funcref where
|
|
sexpIso = with \funcref ->
|
|
list ( el (sym "elem")
|
|
>>> el (sym "declare")
|
|
>>> el (sym "funcref")
|
|
>>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx))
|
|
)
|
|
>>> funcref
|
|
|
|
instance SexpIso Sexp where
|
|
sexpIso = Control.Category.id
|
|
|
|
instance Each Expr Expr Instr Instr where
|
|
each = #MkExpr . each
|
|
|
|
sxp :: HasCallStack => SexpIso a => a -> Sexp
|
|
sxp e = either error id . Sexp.toSexp sexpIso $ e
|
|
|
|
ins :: Text -> List Sexp -> Expr
|
|
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
|
|
|
|
data ResultType = MkResultType
|
|
{ params :: List Type
|
|
, result :: List Type
|
|
}
|
|
deriving stock (Generic)
|
|
deriving (Semigroup, Monoid)
|
|
via Generically ResultType
|
|
|
|
param :: List Type -> ResultType
|
|
param ts = MkResultType ts mempty
|
|
|
|
result :: List Type -> ResultType
|
|
result ts = MkResultType mempty ts
|
|
|
|
resultTypeSexp :: ResultType -> List Sexp
|
|
resultTypeSexp rt =
|
|
f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result)
|
|
where
|
|
f :: Text -> List Sexp -> List Sexp
|
|
f _ [] = []
|
|
f kw s = [ ParenList $ Symbol kw : s ]
|
|
|
|
-- resultSexp :: ResultType -> Sexp
|
|
-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
|
|
|
|
if' :: ResultType -> Expr -> Expr -> Expr
|
|
if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $
|
|
[ Symbol "if" ]
|
|
<> resultTypeSexp rt
|
|
<> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ]
|
|
<> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ]
|