unitype
This commit is contained in:
+22
-2
@@ -1,19 +1,39 @@
|
||||
(module
|
||||
(type (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 3)
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(i32.const 4)
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.mul
|
||||
ref.i31
|
||||
(local.set 0)
|
||||
(i32.const 2)
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(i32.const 5)
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.mul
|
||||
ref.i31
|
||||
(local.set 1)
|
||||
(local.get 0)
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(local.get 1)
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.add
|
||||
ref.i31
|
||||
(local.set 2)
|
||||
(local.get 2))
|
||||
(export "main" (func 0)))
|
||||
@@ -1,11 +1,13 @@
|
||||
(module
|
||||
(type (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
ref.i31
|
||||
(if
|
||||
(result i32)
|
||||
(then (i32.const 777))
|
||||
(else (i32.const 555))))
|
||||
(then (i32.const 777) ref.i31)
|
||||
(else (i32.const 555) ref.i31)))
|
||||
(export "main" (func 0)))
|
||||
@@ -1,11 +1,13 @@
|
||||
(module
|
||||
(type (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 1)
|
||||
ref.i31
|
||||
(if
|
||||
(result i32)
|
||||
(then (i32.const 777))
|
||||
(else (i32.const 555))))
|
||||
(then (i32.const 777) ref.i31)
|
||||
(else (i32.const 555) ref.i31)))
|
||||
(export "main" (func 0)))
|
||||
@@ -31,7 +31,8 @@ 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, ins, sxp, eq, ref, i31)
|
||||
import Gyehoek.Wasm (i32, ins, sxp, eq, ref, i31, Type (..))
|
||||
import Language.Sexp.Located (pattern ParenList)
|
||||
|
||||
|
||||
data Env = MkEnv { vars :: Vector Name }
|
||||
@@ -103,8 +104,12 @@ lowerBinOp op g x y r e =
|
||||
|
||||
scm = ref eq
|
||||
|
||||
|
||||
|
||||
lower :: Exp -> Eff es Text
|
||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
|
||||
[ Wasm.mut i32 ]
|
||||
main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
|
||||
lower' emptyEnv e
|
||||
Wasm.export "main" "func" main
|
||||
|
||||
+82
-18
@@ -11,13 +11,14 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module Gyehoek.Wasm
|
||||
( defun
|
||||
, deftype
|
||||
, rec'
|
||||
, start
|
||||
, runGenMod
|
||||
, execGenMod
|
||||
, renderModule
|
||||
, Module
|
||||
, Function
|
||||
, Type(..)
|
||||
, Expr
|
||||
, Instr
|
||||
, GenMod
|
||||
@@ -32,11 +33,18 @@ module Gyehoek.Wasm
|
||||
, eq
|
||||
, i31ref
|
||||
, i31
|
||||
, struct
|
||||
, mut
|
||||
, sub
|
||||
, deftype
|
||||
, namedType
|
||||
, type'
|
||||
, deftypeNamed
|
||||
)
|
||||
where
|
||||
|
||||
import Language.SexpGrammar
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.SexpGrammar.Generic
|
||||
import Data.List (List)
|
||||
@@ -64,10 +72,11 @@ 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 Type
|
||||
{ types :: Vector RecType
|
||||
, functions :: Vector Function
|
||||
, start :: Maybe Idx
|
||||
, exports :: Vector Export
|
||||
@@ -85,6 +94,9 @@ instance Semigroup Module where
|
||||
instance Monoid Module where
|
||||
mempty = MkModule mempty mempty Nothing mempty
|
||||
|
||||
newtype RecType = MkRecType { inner :: Vector Type }
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Function = MkFunction
|
||||
{ params :: List Type
|
||||
, result :: List Type
|
||||
@@ -106,11 +118,13 @@ newtype Instr = MkInstr { inner :: Sexp }
|
||||
newtype Type = MkType { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Idx = MkIdx { getIdx :: Natural }
|
||||
deriving newtype (Show)
|
||||
data Idx
|
||||
= IdxNumeric Natural
|
||||
| IdxNamed Text
|
||||
deriving (Show, Generic)
|
||||
|
||||
data GenMod :: Effect where
|
||||
DefType :: Type -> GenMod m Idx
|
||||
DefRecType :: List Type -> GenMod m (List Idx)
|
||||
Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
|
||||
Start :: Idx -> GenMod m ()
|
||||
Export :: Text -> Text -> Idx -> GenMod m ()
|
||||
@@ -123,8 +137,16 @@ 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 = send . DefType
|
||||
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])
|
||||
|
||||
defun
|
||||
:: (GenMod :> es)
|
||||
@@ -144,20 +166,21 @@ defun params result locals code = send $ Defun params result locals 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
|
||||
_ (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 ] ]
|
||||
_ (Defun params result locals code) -> state \m ->
|
||||
let idx = MkIdx . fromIntegral . length $ m.functions
|
||||
_ (Defun params res locals code) -> state \m ->
|
||||
let idx = IdxNumeric . fromIntegral . length $ m.functions
|
||||
in ( idx
|
||||
, m & #functions <>~ V.singleton
|
||||
(MkFunction params result locals (code idx))
|
||||
(MkFunction params res locals (code idx))
|
||||
)
|
||||
|
||||
execGenMod = fmap snd . runGenMod
|
||||
@@ -168,6 +191,18 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
|
||||
ref :: Type -> Type
|
||||
ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
|
||||
|
||||
sub :: List Idx -> Type -> Type
|
||||
sub supers (MkType x) = MkType . ParenList $
|
||||
Symbol "sub" : (sxp <$> supers) ++ [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]
|
||||
|
||||
i32, i31ref, eq, i31 :: Type
|
||||
i32 = MkType $ Symbol "i32"
|
||||
i31ref = MkType $ Symbol "i31ref"
|
||||
@@ -177,11 +212,40 @@ i31 = MkType $ Symbol "i31"
|
||||
|
||||
|
||||
instance SexpIso Idx where
|
||||
sexpIso = Sexp.integer >>> Sexp.partialOsi f g
|
||||
sexpIso = match
|
||||
$ With (\numeric -> num >>> numeric)
|
||||
$ With (\named -> symbol >>> named)
|
||||
$ End
|
||||
where
|
||||
f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
|
||||
| otherwise = Right . MkIdx $ fromIntegral n
|
||||
g (MkIdx n) = fromIntegral n
|
||||
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
|
||||
|
||||
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 Instr where
|
||||
sexpIso = Sexp.iso coerce coerce
|
||||
@@ -213,7 +277,7 @@ instance SexpIso Module where
|
||||
sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
|
||||
ParenList $
|
||||
[ Symbol "module" ]
|
||||
<> (m ^.. #types . each . #inner)
|
||||
<> (m ^.. #types . each . to sxp)
|
||||
<> (m ^.. #functions . each . to sxp)
|
||||
<> (m ^.. #exports . each . to sxp)
|
||||
|
||||
|
||||
@@ -0,0 +1,6 @@
|
||||
# Comment out certain settings to use default values.
|
||||
# For more settings, please refer to the documentation:
|
||||
# https://bytecodealliance.github.io/wasmtime/cli-cache.html
|
||||
|
||||
[wasm]
|
||||
gc=true
|
||||
Reference in New Issue
Block a user