+19
-369
@@ -11,43 +11,7 @@
|
||||
{-# 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
|
||||
( Module
|
||||
)
|
||||
where
|
||||
|
||||
@@ -83,344 +47,30 @@ 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 }
|
||||
newtype Module = MkModule { inner :: Vector Sexp }
|
||||
deriving (Show, Generic)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
newtype Instr = MkInstr { inner :: Sexp }
|
||||
newtype Expr = MkExpr { inner :: Vector Sexp }
|
||||
deriving (Show, Generic)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
newtype Type = MkType { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
newtype Idx = MkIdx { inner :: Natural }
|
||||
deriving (Generic)
|
||||
deriving newtype (Show)
|
||||
|
||||
data Idx
|
||||
= IdxNumeric Natural
|
||||
| IdxNamed Text
|
||||
|
||||
-- GenMod
|
||||
|
||||
-- | 'GenModState' is a 'Module' paired with the numbers of functions,
|
||||
-- types, globals, etc. defined in the module.
|
||||
data GenModState = MkGenModState
|
||||
{ mod :: Module
|
||||
, funcs :: Natural
|
||||
, types :: Natural
|
||||
}
|
||||
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 -> do
|
||||
m <- get
|
||||
-- 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}
|
||||
#functions <>= V.singleton func
|
||||
pure idx
|
||||
_ (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 ^.. #globals . 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) ]
|
||||
DefineFunction :: Sexp -> GenMod m Idx
|
||||
DefineType :: Sexp -> GenMod m Idx
|
||||
|
||||
Reference in New Issue
Block a user