Compare commits
2 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Ilya Rezvov
|
7d199ddc03 | ||
|
Ilya Rezvov
|
f8bec75b25 |
+255
-193
@@ -12,7 +12,11 @@
|
||||
{-# LANGUAGE TypeInType #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Language.Wasm.Builder (
|
||||
GenMod,
|
||||
@@ -28,7 +32,7 @@ module Language.Wasm.Builder (
|
||||
arg,
|
||||
i32, i64, f32, f64,
|
||||
i32c, i64c, f32c, f64c,
|
||||
add, inc, sub, dec, mul, div_u, div_s, rem_u, rem_s, and, or, xor, shl, shr_u, shr_s, rotl, rotr,
|
||||
add, {-inc,-} sub, {-dec,-} mul, div_u, div_s, rem_u, rem_s, and, or, xor, shl, shr_u, shr_s, rotl, rotr,
|
||||
eq, ne, lt_s, lt_u, gt_s, gt_u, le_s, le_u, ge_s, ge_u,
|
||||
eqz,
|
||||
extend_s, extend_u, wrap,
|
||||
@@ -46,7 +50,7 @@ import Prelude hiding (and, or)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Maybe as Maybe
|
||||
import Control.Monad.State (State, execState, get, gets, put, modify)
|
||||
import Control.Monad.Reader (ReaderT, ask, runReaderT)
|
||||
import Control.Monad.Reader (ReaderT, ask, runReaderT, withReaderT)
|
||||
import Numeric.Natural
|
||||
import Data.Word (Word32, Word64)
|
||||
import Data.Int (Int32, Int64)
|
||||
@@ -64,100 +68,146 @@ data FuncDef = FuncDef {
|
||||
instrs :: Expression
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type GenFun = ReaderT Natural (State FuncDef)
|
||||
|
||||
genExpr :: Natural -> GenFun a -> Expression
|
||||
genExpr deep gen = instrs $ flip execState (FuncDef [] [] [] []) $ runReaderT gen deep
|
||||
newtype GenFun a = GenFun { unGenFun :: ReaderT Natural (State FuncDef) a } deriving (Functor, Applicative, Monad)
|
||||
|
||||
newtype Loc t = Loc Natural deriving (Show, Eq)
|
||||
|
||||
param :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
|
||||
param t = do
|
||||
f@FuncDef { args } <- get
|
||||
put $ f { args = args ++ [getValueType t] }
|
||||
return $ Loc $ fromIntegral $ length args
|
||||
class (Monad m) => GenFunMonad m where
|
||||
appendExpr :: Expression -> m ()
|
||||
inner :: m a -> m Expression
|
||||
param :: (ValueTypeable t) => Proxy t -> m (Loc t)
|
||||
local :: (ValueTypeable t) => Proxy t -> m (Loc t)
|
||||
deep :: m Natural
|
||||
|
||||
local :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
|
||||
local t = do
|
||||
f@FuncDef { args, locals } <- get
|
||||
put $ f { locals = locals ++ [getValueType t]}
|
||||
return $ Loc $ fromIntegral $ length args + length locals
|
||||
instance GenFunMonad GenFun where
|
||||
appendExpr expr = do
|
||||
GenFun $ modify $ \def -> def { instrs = instrs def ++ expr }
|
||||
return ()
|
||||
|
||||
appendExpr :: Expression -> GenFun ()
|
||||
appendExpr expr = do
|
||||
modify $ \def -> def { instrs = instrs def ++ expr }
|
||||
return ()
|
||||
inner (GenFun subExpr) = GenFun $ do
|
||||
stateBefore <- get
|
||||
res <- withReaderT (+1) $ do
|
||||
subExpr
|
||||
gets instrs
|
||||
put stateBefore
|
||||
return res
|
||||
|
||||
after :: Expression -> GenFun a -> GenFun a
|
||||
param t = GenFun $ do
|
||||
f@FuncDef { args } <- get
|
||||
put $ f { args = args ++ [getValueType t] }
|
||||
return $ Loc $ fromIntegral $ length args
|
||||
|
||||
local t = GenFun $ do
|
||||
f@FuncDef { args, locals } <- get
|
||||
put $ f { locals = locals ++ [getValueType t]}
|
||||
return $ Loc $ fromIntegral $ length args + length locals
|
||||
|
||||
deep = GenFun ask
|
||||
-- type GenFun = ReaderT Natural (State FuncDef)
|
||||
|
||||
-- genExpr :: Natural -> GenFun a -> Expression
|
||||
-- genExpr deep gen = instrs $ flip execState (FuncDef [] [] [] []) $ runReaderT gen deep
|
||||
|
||||
-- param :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
|
||||
-- param t = do
|
||||
-- f@FuncDef { args } <- get
|
||||
-- put $ f { args = args ++ [getValueType t] }
|
||||
-- return $ Loc $ fromIntegral $ length args
|
||||
|
||||
-- local :: (ValueTypeable t) => Proxy t -> GenFun (Loc t)
|
||||
-- local t = do
|
||||
-- f@FuncDef { args, locals } <- get
|
||||
-- put $ f { locals = locals ++ [getValueType t]}
|
||||
-- return $ Loc $ fromIntegral $ length args + length locals
|
||||
|
||||
-- appendExpr :: Expression -> GenFun ()
|
||||
-- appendExpr expr = do
|
||||
-- modify $ \def -> def { instrs = instrs def ++ expr }
|
||||
-- return ()
|
||||
|
||||
-- after :: Expression -> GenFun a -> GenFun a
|
||||
-- after instr expr = do
|
||||
-- res <- expr
|
||||
-- modify $ \def -> def { instrs = instrs def ++ instr }
|
||||
-- return res
|
||||
|
||||
after :: (GenFunMonad m) => Expression -> m a -> m a
|
||||
after instr expr = do
|
||||
res <- expr
|
||||
modify $ \def -> def { instrs = instrs def ++ instr }
|
||||
appendExpr instr
|
||||
return res
|
||||
|
||||
data TypedExpr
|
||||
= ExprI32 (GenFun (Proxy I32))
|
||||
| ExprI64 (GenFun (Proxy I64))
|
||||
| ExprF32 (GenFun (Proxy F32))
|
||||
| ExprF64 (GenFun (Proxy F64))
|
||||
data TypedExpr m
|
||||
= ExprI32 (m (Proxy I32))
|
||||
| ExprI64 (m (Proxy I64))
|
||||
| ExprF32 (m (Proxy F32))
|
||||
| ExprF64 (m (Proxy F64))
|
||||
|
||||
class Producer expr where
|
||||
data ProducerType
|
||||
= LocProd
|
||||
| GlobProd
|
||||
| ExprProd
|
||||
|
||||
type family GetProdType a :: ProducerType where
|
||||
GetProdType (Loc t) = 'LocProd
|
||||
GetProdType (Glob t) = 'GlobProd
|
||||
GetProdType a = 'ExprProd
|
||||
|
||||
class (GenFunMonad m) => ProducerHelp (prodType :: ProducerType) m expr where
|
||||
type OutTypeHelp prodType expr
|
||||
asTypedExprHelp :: expr -> TypedExpr m
|
||||
produceHelp :: expr -> m (OutTypeHelp prodType expr)
|
||||
|
||||
instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'LocProd m (Loc t) where
|
||||
type OutTypeHelp 'LocProd (Loc t) = Proxy t
|
||||
asTypedExprHelp e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produceHelp @'LocProd e >> return Proxy)
|
||||
I64 -> ExprI64 (produceHelp @'LocProd e >> return Proxy)
|
||||
F32 -> ExprF32 (produceHelp @'LocProd e >> return Proxy)
|
||||
F64 -> ExprF64 (produceHelp @'LocProd e >> return Proxy)
|
||||
where
|
||||
t :: Loc t -> Proxy t
|
||||
t _ = Proxy
|
||||
produceHelp (Loc i) = appendExpr [GetLocal i] >> return Proxy
|
||||
|
||||
instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'GlobProd m (Glob t) where
|
||||
type OutTypeHelp 'GlobProd (Glob t) = Proxy t
|
||||
asTypedExprHelp e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produceHelp @'GlobProd e >> return Proxy)
|
||||
I64 -> ExprI64 (produceHelp @'GlobProd e >> return Proxy)
|
||||
F32 -> ExprF32 (produceHelp @'GlobProd e >> return Proxy)
|
||||
F64 -> ExprF64 (produceHelp @'GlobProd e >> return Proxy)
|
||||
where
|
||||
t :: Glob t -> Proxy t
|
||||
t _ = Proxy
|
||||
produceHelp (Glob i) = appendExpr [GetGlobal i] >> return Proxy
|
||||
|
||||
instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'ExprProd m (m (Proxy t)) where
|
||||
type OutTypeHelp 'ExprProd (m (Proxy t)) = Proxy t
|
||||
asTypedExprHelp e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produceHelp @'ExprProd e >> return Proxy)
|
||||
I64 -> ExprI64 (produceHelp @'ExprProd e >> return Proxy)
|
||||
F32 -> ExprF32 (produceHelp @'ExprProd e >> return Proxy)
|
||||
F64 -> ExprF64 (produceHelp @'ExprProd e >> return Proxy)
|
||||
where
|
||||
t :: (GenFunMonad m) => m (Proxy t) -> Proxy t
|
||||
t _ = Proxy
|
||||
produceHelp = id
|
||||
|
||||
class (GenFunMonad m) => Producer m expr where
|
||||
type OutType expr
|
||||
asTypedExpr :: expr -> TypedExpr
|
||||
asValueType :: expr -> ValueType
|
||||
produce :: expr -> GenFun (OutType expr)
|
||||
asTypedExpr :: expr -> TypedExpr m
|
||||
produce :: expr -> m (OutType expr)
|
||||
|
||||
instance (ValueTypeable t) => Producer (Loc t) where
|
||||
type OutType (Loc t) = Proxy t
|
||||
asTypedExpr e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produce e >> return Proxy)
|
||||
I64 -> ExprI64 (produce e >> return Proxy)
|
||||
F32 -> ExprF32 (produce e >> return Proxy)
|
||||
F64 -> ExprF64 (produce e >> return Proxy)
|
||||
where
|
||||
t :: Loc t -> Proxy t
|
||||
t _ = Proxy
|
||||
asValueType e = getValueType (t e)
|
||||
where
|
||||
t :: Loc t -> Proxy t
|
||||
t _ = Proxy
|
||||
produce (Loc i) = appendExpr [GetLocal i] >> return Proxy
|
||||
instance (GenFunMonad m, ProducerHelp (GetProdType (m a)) m (m a)) => Producer m (m a) where
|
||||
type OutType (m a) = OutTypeHelp (GetProdType (m a)) (m a)
|
||||
asTypedExpr = asTypedExprHelp @(GetProdType (m a))
|
||||
produce = produceHelp @(GetProdType (m a))
|
||||
|
||||
instance (ValueTypeable t) => Producer (Glob t) where
|
||||
type OutType (Glob t) = Proxy t
|
||||
asTypedExpr e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produce e >> return Proxy)
|
||||
I64 -> ExprI64 (produce e >> return Proxy)
|
||||
F32 -> ExprF32 (produce e >> return Proxy)
|
||||
F64 -> ExprF64 (produce e >> return Proxy)
|
||||
where
|
||||
t :: Glob t -> Proxy t
|
||||
t _ = Proxy
|
||||
asValueType e = getValueType (t e)
|
||||
where
|
||||
t :: Glob t -> Proxy t
|
||||
t _ = Proxy
|
||||
produce (Glob i) = appendExpr [GetGlobal i] >> return Proxy
|
||||
|
||||
instance (ValueTypeable t) => Producer (GenFun (Proxy t)) where
|
||||
type OutType (GenFun (Proxy t)) = Proxy t
|
||||
asTypedExpr e = case getValueType (t e) of
|
||||
I32 -> ExprI32 (produce e >> return Proxy)
|
||||
I64 -> ExprI64 (produce e >> return Proxy)
|
||||
F32 -> ExprF32 (produce e >> return Proxy)
|
||||
F64 -> ExprF64 (produce e >> return Proxy)
|
||||
where
|
||||
t :: GenFun (Proxy t) -> Proxy t
|
||||
t _ = Proxy
|
||||
asValueType e = getValueType (t e)
|
||||
where
|
||||
t :: GenFun (Proxy t) -> Proxy t
|
||||
t _ = Proxy
|
||||
produce = id
|
||||
|
||||
ret :: (Producer expr) => expr -> GenFun (OutType expr)
|
||||
ret :: (Producer m expr) => expr -> m (OutType expr)
|
||||
ret = produce
|
||||
|
||||
arg :: (Producer expr) => expr -> GenFun ()
|
||||
arg :: (Producer m expr) => expr -> m ()
|
||||
arg e = produce e >> return ()
|
||||
|
||||
getSize :: ValueType -> BitSize
|
||||
@@ -174,184 +224,191 @@ type family IsInt i :: Bool where
|
||||
nop :: GenFun ()
|
||||
nop = appendExpr [Nop]
|
||||
|
||||
iBinOp :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => IBinOp -> a -> b -> GenFun (OutType a)
|
||||
iBinOp op a b = produce a >> after [IBinOp (getSize $ asValueType a) op] (produce b)
|
||||
asValueType :: forall m a . (GenFunMonad m, Producer m a) => a -> ValueType
|
||||
asValueType a = case asTypedExpr @m a of
|
||||
ExprI32 e -> I32
|
||||
ExprI64 e -> I64
|
||||
ExprF32 e -> F32
|
||||
ExprF64 e -> F64
|
||||
|
||||
add :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (OutType a)
|
||||
iBinOp :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => IBinOp -> a -> b -> m (OutType a)
|
||||
iBinOp op a b = produce a >> after [IBinOp (getSize $ asValueType @m a) op] (produce b)
|
||||
|
||||
add :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
|
||||
add a b = do
|
||||
produce a
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> after [IBinOp BS32 IAdd] (produce b)
|
||||
I64 -> after [IBinOp BS64 IAdd] (produce b)
|
||||
F32 -> after [FBinOp BS32 FAdd] (produce b)
|
||||
F64 -> after [FBinOp BS64 FAdd] (produce b)
|
||||
|
||||
inc :: (Consumer a, Producer a, Integral i) => i -> a -> GenFun ()
|
||||
inc i a = case asTypedExpr a of
|
||||
ExprI32 e -> a .= (e `add` i32c i)
|
||||
ExprI64 e -> a .= (e `add` i64c i)
|
||||
ExprF32 e -> a .= (e `add` f32c (fromIntegral i))
|
||||
ExprF64 e -> a .= (e `add` f64c (fromIntegral i))
|
||||
-- inc :: (GenFunMonad m, Consumer m a, Producer m a, Integral i) => i -> a -> m ()
|
||||
-- inc i a = case asTypedExpr a of
|
||||
-- ExprI32 e -> a .= (e `add` i32c i)
|
||||
-- ExprI64 e -> a .= (e `add` i64c i)
|
||||
-- ExprF32 e -> a .= (e `add` f32c (fromIntegral i))
|
||||
-- ExprF64 e -> a .= (e `add` f64c (fromIntegral i))
|
||||
|
||||
sub :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (OutType a)
|
||||
sub :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
|
||||
sub a b = do
|
||||
produce a
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> after [IBinOp BS32 ISub] (produce b)
|
||||
I64 -> after [IBinOp BS64 ISub] (produce b)
|
||||
F32 -> after [FBinOp BS32 FSub] (produce b)
|
||||
F64 -> after [FBinOp BS64 FSub] (produce b)
|
||||
|
||||
dec :: (Consumer a, Producer a, Integral i) => i -> a -> GenFun ()
|
||||
dec i a = case asTypedExpr a of
|
||||
ExprI32 e -> a .= (e `sub` i32c i)
|
||||
ExprI64 e -> a .= (e `sub` i64c i)
|
||||
ExprF32 e -> a .= (e `sub` f32c (fromIntegral i))
|
||||
ExprF64 e -> a .= (e `sub` f64c (fromIntegral i))
|
||||
-- dec :: (GenFunMonad m, Consumer m a, Producer m a, Integral i) => i -> a -> m ()
|
||||
-- dec i a = case asTypedExpr a of
|
||||
-- ExprI32 e -> a .= (e `sub` i32c i)
|
||||
-- ExprI64 e -> a .= (e `sub` i64c i)
|
||||
-- ExprF32 e -> a .= (e `sub` f32c (fromIntegral i))
|
||||
-- ExprF64 e -> a .= (e `sub` f64c (fromIntegral i))
|
||||
|
||||
mul :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (OutType a)
|
||||
mul :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (OutType a)
|
||||
mul a b = do
|
||||
produce a
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> after [IBinOp BS32 IMul] (produce b)
|
||||
I64 -> after [IBinOp BS64 IMul] (produce b)
|
||||
F32 -> after [FBinOp BS32 FMul] (produce b)
|
||||
F64 -> after [FBinOp BS64 FMul] (produce b)
|
||||
|
||||
div_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
div_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
div_u = iBinOp IDivU
|
||||
|
||||
div_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
div_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
div_s = iBinOp IDivS
|
||||
|
||||
rem_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
rem_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
rem_u = iBinOp IRemU
|
||||
|
||||
rem_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
rem_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
rem_s = iBinOp IRemS
|
||||
|
||||
and :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
and :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
and = iBinOp IAnd
|
||||
|
||||
or :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
or :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
or = iBinOp IOr
|
||||
|
||||
xor :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
xor :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
xor = iBinOp IXor
|
||||
|
||||
shl :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
shl :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
shl = iBinOp IShl
|
||||
|
||||
shr_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
shr_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
shr_u = iBinOp IShrU
|
||||
|
||||
shr_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
shr_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
shr_s = iBinOp IShrS
|
||||
|
||||
rotl :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
rotl :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
rotl = iBinOp IRotl
|
||||
|
||||
rotr :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (OutType a)
|
||||
rotr :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (OutType a)
|
||||
rotr = iBinOp IRotr
|
||||
|
||||
relOp :: (Producer a, Producer b, OutType a ~ OutType b) => IRelOp -> a -> b -> GenFun (Proxy I32)
|
||||
relOp :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => IRelOp -> a -> b -> m (Proxy I32)
|
||||
relOp op a b = do
|
||||
produce a
|
||||
produce b
|
||||
appendExpr [IRelOp (getSize $ asValueType a) op]
|
||||
appendExpr [IRelOp (getSize $ asValueType @m a) op]
|
||||
return Proxy
|
||||
|
||||
eq :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (Proxy I32)
|
||||
eq :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (Proxy I32)
|
||||
eq a b = do
|
||||
produce a
|
||||
produce b
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> appendExpr [IRelOp BS32 IEq]
|
||||
I64 -> appendExpr [IRelOp BS64 IEq]
|
||||
F32 -> appendExpr [FRelOp BS32 FEq]
|
||||
F64 -> appendExpr [FRelOp BS64 FEq]
|
||||
return Proxy
|
||||
|
||||
ne :: (Producer a, Producer b, OutType a ~ OutType b) => a -> b -> GenFun (Proxy I32)
|
||||
ne :: forall m a b . (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b) => a -> b -> m (Proxy I32)
|
||||
ne a b = do
|
||||
produce a
|
||||
produce b
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> appendExpr [IRelOp BS32 INe]
|
||||
I64 -> appendExpr [IRelOp BS64 INe]
|
||||
F32 -> appendExpr [FRelOp BS32 FNe]
|
||||
F64 -> appendExpr [FRelOp BS64 FNe]
|
||||
return Proxy
|
||||
|
||||
lt_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
lt_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
lt_s = relOp ILtS
|
||||
|
||||
lt_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
lt_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
lt_u = relOp ILtS
|
||||
|
||||
gt_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
gt_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
gt_s = relOp IGtS
|
||||
|
||||
gt_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
gt_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
gt_u = relOp IGtU
|
||||
|
||||
le_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
le_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
le_s = relOp ILeS
|
||||
|
||||
le_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
le_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
le_u = relOp ILeS
|
||||
|
||||
ge_s :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
ge_s :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
ge_s = relOp IGeS
|
||||
|
||||
ge_u :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> GenFun (Proxy I32)
|
||||
ge_u :: (GenFunMonad m, Producer m a, Producer m b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => a -> b -> m (Proxy I32)
|
||||
ge_u = relOp IGeU
|
||||
|
||||
eqz :: (Producer a, IsInt (OutType a) ~ True) => a -> GenFun (Proxy I32)
|
||||
eqz :: forall m a . (GenFunMonad m, Producer m a, IsInt (OutType a) ~ True) => a -> m (Proxy I32)
|
||||
eqz a = do
|
||||
produce a
|
||||
case asValueType a of
|
||||
case asValueType @m a of
|
||||
I32 -> appendExpr [I32Eqz]
|
||||
I64 -> appendExpr [I64Eqz]
|
||||
_ -> error "Impossible by type constraint"
|
||||
return Proxy
|
||||
|
||||
i32c :: (Integral i) => i -> GenFun (Proxy I32)
|
||||
i32c :: (GenFunMonad m, Integral i) => i -> m (Proxy I32)
|
||||
i32c i = appendExpr [I32Const $ asWord32 $ fromIntegral i] >> return Proxy
|
||||
|
||||
i64c :: (Integral i) => i -> GenFun (Proxy I64)
|
||||
i64c :: (GenFunMonad m, Integral i) => i -> m (Proxy I64)
|
||||
i64c i = appendExpr [I64Const $ asWord64 $ fromIntegral i] >> return Proxy
|
||||
|
||||
f32c :: Float -> GenFun (Proxy F32)
|
||||
f32c :: (GenFunMonad m) => Float -> m (Proxy F32)
|
||||
f32c f = appendExpr [F32Const f] >> return Proxy
|
||||
|
||||
f64c :: Double -> GenFun (Proxy F64)
|
||||
f64c :: (GenFunMonad m) => Double -> m (Proxy F64)
|
||||
f64c d = appendExpr [F64Const d] >> return Proxy
|
||||
|
||||
extend_u :: (Producer i, OutType i ~ Proxy I32) => i -> GenFun (Proxy I64)
|
||||
extend_u :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I32) => i -> m (Proxy I64)
|
||||
extend_u small = do
|
||||
produce small
|
||||
appendExpr [I64ExtendUI32]
|
||||
return Proxy
|
||||
|
||||
extend_s :: (Producer i, OutType i ~ Proxy I32) => i -> GenFun (Proxy I64)
|
||||
extend_s :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I32) => i -> m (Proxy I64)
|
||||
extend_s small = do
|
||||
produce small
|
||||
appendExpr [I64ExtendUI32]
|
||||
return Proxy
|
||||
|
||||
wrap :: (Producer i, OutType i ~ Proxy I64) => i -> GenFun (Proxy I32)
|
||||
wrap :: (GenFunMonad m, Producer m i, OutType i ~ Proxy I64) => i -> m (Proxy I32)
|
||||
wrap big = do
|
||||
produce big
|
||||
appendExpr [I32WrapI64]
|
||||
return Proxy
|
||||
|
||||
load :: (ValueTypeable t, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load :: (GenFunMonad m, ValueTypeable t, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load t addr offset align = do
|
||||
produce addr
|
||||
case getValueType t of
|
||||
@@ -361,12 +418,12 @@ load t addr offset align = do
|
||||
F64 -> appendExpr [F64Load $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
return Proxy
|
||||
|
||||
load8_u :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load8_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load8_u t addr offset align = do
|
||||
produce addr
|
||||
case getValueType t of
|
||||
@@ -375,12 +432,12 @@ load8_u t addr offset align = do
|
||||
_ -> error "Impossible by type constraint"
|
||||
return Proxy
|
||||
|
||||
load8_s :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load8_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load8_s t addr offset align = do
|
||||
produce addr
|
||||
case getValueType t of
|
||||
@@ -389,12 +446,12 @@ load8_s t addr offset align = do
|
||||
_ -> error "Impossible by type constraint"
|
||||
return Proxy
|
||||
|
||||
load16_u :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load16_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load16_u t addr offset align = do
|
||||
produce addr
|
||||
case getValueType t of
|
||||
@@ -403,12 +460,12 @@ load16_u t addr offset align = do
|
||||
_ -> error "Impossible by type constraint"
|
||||
return Proxy
|
||||
|
||||
load16_s :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load16_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load16_s t addr offset align = do
|
||||
produce addr
|
||||
case getValueType t of
|
||||
@@ -417,104 +474,104 @@ load16_s t addr offset align = do
|
||||
_ -> error "Impossible by type constraint"
|
||||
return Proxy
|
||||
|
||||
load32_u :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load32_u :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load32_u t addr offset align = do
|
||||
produce addr
|
||||
appendExpr [I64Load32U $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
return Proxy
|
||||
|
||||
load32_s :: (ValueTypeable t, IsInt (Proxy t) ~ True, Producer addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
load32_s :: (GenFunMonad m, ValueTypeable t, IsInt (Proxy t) ~ True, Producer m addr, OutType addr ~ Proxy I32, Integral offset, Integral align)
|
||||
=> Proxy t
|
||||
-> addr
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun (Proxy t)
|
||||
-> m (Proxy t)
|
||||
load32_s t addr offset align = do
|
||||
produce addr
|
||||
appendExpr [I64Load32S $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
return Proxy
|
||||
|
||||
store :: (Producer addr, OutType addr ~ Proxy I32, Producer val, Integral offset, Integral align)
|
||||
store :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, Integral offset, Integral align)
|
||||
=> addr
|
||||
-> val
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun ()
|
||||
-> m ()
|
||||
store addr val offset align = do
|
||||
produce addr
|
||||
produce val
|
||||
case asValueType val of
|
||||
case asValueType @m val of
|
||||
I32 -> appendExpr [I32Store $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
I64 -> appendExpr [I64Store $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
F32 -> appendExpr [F32Store $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
F64 -> appendExpr [F64Store $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
|
||||
store8 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutType val) ~ True, Integral offset, Integral align)
|
||||
store8 :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, IsInt (OutType val) ~ True, Integral offset, Integral align)
|
||||
=> addr
|
||||
-> val
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun ()
|
||||
-> m ()
|
||||
store8 addr val offset align = do
|
||||
produce addr
|
||||
produce val
|
||||
case asValueType val of
|
||||
case asValueType @m val of
|
||||
I32 -> appendExpr [I32Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
I64 -> appendExpr [I64Store8 $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
_ -> error "Impossible by type constraint"
|
||||
|
||||
store16 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, IsInt (OutType val) ~ True, Integral offset, Integral align)
|
||||
store16 :: forall m addr val offset align . (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, IsInt (OutType val) ~ True, Integral offset, Integral align)
|
||||
=> addr
|
||||
-> val
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun ()
|
||||
-> m ()
|
||||
store16 addr val offset align = do
|
||||
produce addr
|
||||
produce val
|
||||
case asValueType val of
|
||||
case asValueType @m val of
|
||||
I32 -> appendExpr [I32Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
I64 -> appendExpr [I64Store16 $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
_ -> error "Impossible by type constraint"
|
||||
|
||||
store32 :: (Producer addr, OutType addr ~ Proxy I32, Producer val, OutType val ~ Proxy I64, Integral offset, Integral align)
|
||||
store32 :: (GenFunMonad m, Producer m addr, OutType addr ~ Proxy I32, Producer m val, OutType val ~ Proxy I64, Integral offset, Integral align)
|
||||
=> addr
|
||||
-> val
|
||||
-> offset
|
||||
-> align
|
||||
-> GenFun ()
|
||||
-> m ()
|
||||
store32 addr val offset align = do
|
||||
produce addr
|
||||
produce val
|
||||
appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)]
|
||||
|
||||
call :: (Returnable res) => Fn res -> [GenFun a] -> GenFun res
|
||||
call :: (GenFunMonad m, Returnable res) => Fn res -> [m a] -> m res
|
||||
call (Fn idx) args = sequence_ args >> appendExpr [Call idx] >> return returnableValue
|
||||
|
||||
br :: Label t -> GenFun ()
|
||||
br :: (GenFunMonad m) => Label t -> m ()
|
||||
br (Label labelDeep) = do
|
||||
deep <- ask
|
||||
appendExpr [Br $ deep - labelDeep]
|
||||
d <- deep
|
||||
appendExpr [Br $ d - labelDeep]
|
||||
|
||||
finish :: (Producer val) => val -> GenFun ()
|
||||
finish :: (GenFunMonad m, Producer m val) => val -> m ()
|
||||
finish val = do
|
||||
produce val
|
||||
appendExpr [Return]
|
||||
|
||||
newtype Label i = Label Natural deriving (Show, Eq)
|
||||
|
||||
when :: (Producer pred, OutType pred ~ Proxy I32)
|
||||
when :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32)
|
||||
=> pred
|
||||
-> GenFun ()
|
||||
-> GenFun ()
|
||||
-> m ()
|
||||
-> m ()
|
||||
when pred body = if' () pred body (return ())
|
||||
|
||||
for :: (Producer pred, OutType pred ~ Proxy I32) => GenFun () -> pred -> GenFun () -> GenFun () -> GenFun ()
|
||||
for :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32) => m () -> pred -> m () -> m () -> m ()
|
||||
for initer pred after body = do
|
||||
initer
|
||||
let loopBody = do
|
||||
@@ -524,7 +581,7 @@ for initer pred after body = do
|
||||
if' () pred (br loopLabel) (return ())
|
||||
if' () pred (loop () loopBody) (return ())
|
||||
|
||||
while :: (Producer pred, OutType pred ~ Proxy I32) => pred -> GenFun () -> GenFun ()
|
||||
while :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32) => pred -> m () -> m ()
|
||||
while pred body = do
|
||||
let loopBody = do
|
||||
body
|
||||
@@ -532,49 +589,53 @@ while pred body = do
|
||||
if' () pred (br loopLabel) (return ())
|
||||
if' () pred (loop () loopBody) (return ())
|
||||
|
||||
label :: GenFun (Label t)
|
||||
label = Label <$> ask
|
||||
label :: (GenFunMonad m) => m (Label t)
|
||||
label = Label <$> deep
|
||||
|
||||
if' :: (Producer pred, OutType pred ~ Proxy I32, Returnable res)
|
||||
if' :: (GenFunMonad m, Producer m pred, OutType pred ~ Proxy I32, Returnable res)
|
||||
=> res
|
||||
-> pred
|
||||
-> GenFun res
|
||||
-> GenFun res
|
||||
-> GenFun res
|
||||
-> m res
|
||||
-> m res
|
||||
-> m res
|
||||
if' res pred true false = do
|
||||
produce pred
|
||||
deep <- (+1) <$> ask
|
||||
appendExpr [If (asResultValue res) (genExpr deep $ true) (genExpr deep $ false)]
|
||||
t <- inner true
|
||||
f <- inner false
|
||||
appendExpr [If (asResultValue res) t f]
|
||||
return returnableValue
|
||||
|
||||
loop :: (Returnable res) => res -> GenFun res -> GenFun res
|
||||
loop :: (GenFunMonad m, Returnable res) => res -> m res -> m res
|
||||
loop res body = do
|
||||
deep <- (+1) <$> ask
|
||||
appendExpr [Loop (asResultValue res) (genExpr deep $ body)]
|
||||
b <- inner body
|
||||
appendExpr [Loop (asResultValue res) b]
|
||||
return returnableValue
|
||||
|
||||
block :: (Returnable res) => res -> GenFun res -> GenFun res
|
||||
block :: (GenFunMonad m, Returnable res) => res -> m res -> m res
|
||||
block res body = do
|
||||
deep <- (+1) <$> ask
|
||||
appendExpr [Block (asResultValue res) (genExpr deep $ body)]
|
||||
b <- inner body
|
||||
appendExpr [Block (asResultValue res) b]
|
||||
return returnableValue
|
||||
|
||||
trap :: Proxy t -> GenFun (Proxy t)
|
||||
trap :: (GenFunMonad m) => Proxy t -> m (Proxy t)
|
||||
trap t = do
|
||||
appendExpr [Unreachable]
|
||||
return t
|
||||
|
||||
unreachable :: GenFun ()
|
||||
unreachable :: (GenFunMonad m) => m ()
|
||||
unreachable = appendExpr [Unreachable]
|
||||
|
||||
class Consumer loc where
|
||||
class (GenFunMonad m) => Consumer m loc where
|
||||
type InputType loc
|
||||
infixr 2 .=
|
||||
(.=) :: (Producer expr) => loc -> expr -> GenFun ()
|
||||
(.=) :: (Producer m expr) => loc -> expr -> m ()
|
||||
|
||||
instance Consumer (Loc t) where
|
||||
instance (GenFunMonad m) => Consumer m (Loc t) where
|
||||
type InputType (Loc t) = Proxy t
|
||||
(.=) (Loc i) expr = produce expr >> appendExpr [SetLocal i]
|
||||
|
||||
instance Consumer (Glob t) where
|
||||
instance (GenFunMonad m) => Consumer m (Glob t) where
|
||||
type InputType (Glob t) = Proxy t
|
||||
(.=) (Glob i) expr = produce expr >> appendExpr [SetGlobal i]
|
||||
|
||||
typedef :: FuncType -> GenMod Natural
|
||||
@@ -601,7 +662,8 @@ instance Returnable () where
|
||||
funRec :: (Returnable res) => res -> (Fn res -> GenFun res) -> GenMod (Fn res)
|
||||
funRec res generator = do
|
||||
st@GenModState { target = m@Module { types, functions }, funcIdx } <- get
|
||||
let FuncDef { args, locals, instrs } = execState (runReaderT (generator (Fn funcIdx)) 0) $ FuncDef [] [] [] []
|
||||
let GenFun gen = generator (Fn funcIdx)
|
||||
let FuncDef { args, locals, instrs } = execState (runReaderT gen 0) $ FuncDef [] [] [] []
|
||||
let t = FuncType args (asResultValue res)
|
||||
let (idx, inserted) = Maybe.fromMaybe (length types, types ++ [t]) $ (\i -> (i, types)) <$> List.findIndex (== t) types
|
||||
put $ st {
|
||||
@@ -771,10 +833,10 @@ table min max = do
|
||||
}
|
||||
return $ Tbl 0
|
||||
|
||||
dataSegment :: (Producer offset, OutType offset ~ Proxy I32) => offset -> LBS.ByteString -> GenMod ()
|
||||
dataSegment :: (Integral offset) => offset -> LBS.ByteString -> GenMod ()
|
||||
dataSegment offset bytes =
|
||||
modify $ \(st@GenModState { target = m }) -> st {
|
||||
target = m { datas = datas m ++ [DataSegment 0 (genExpr 0 (produce offset)) bytes] }
|
||||
target = m { datas = datas m ++ [DataSegment 0 [I32Const $ fromIntegral offset] bytes] }
|
||||
}
|
||||
|
||||
asWord32 :: Int32 -> Word32
|
||||
|
||||
Reference in New Issue
Block a user