forked from GitHub/haskell-wasm
add part of memory instructions
This commit is contained in:
Ilya Rezvov
+125
-1
@@ -9,7 +9,11 @@ module Language.Wasm.Parser (
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Encoding as TLEncoding
|
||||
import Numeric.Natural
|
||||
import qualified Data.Text.Lazy.Read as TLRead
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Numeric.Natural (Natural)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Language.Wasm.Lexer (
|
||||
Token (
|
||||
@@ -52,8 +56,35 @@ import Language.Wasm.Lexer (
|
||||
'return' { TKeyword "return" }
|
||||
'call' { TKeyword "call" }
|
||||
'call_indirect' { TKeyword "call_indirect" }
|
||||
'drop' { TKeyword "drop" }
|
||||
'select' { TKeyword "select" }
|
||||
'get_local' { TKeyword "get_local" }
|
||||
'set_local' { TKeyword "set_local" }
|
||||
'tee_local' { TKeyword "tee_local" }
|
||||
'get_global' { TKeyword "get_global" }
|
||||
'set_global' { TKeyword "set_global" }
|
||||
'i32.load' { TKeyword "i32.load" }
|
||||
'i64.load' { TKeyword "i64.load" }
|
||||
'f32.load' { TKeyword "f32.load" }
|
||||
'f64.load' { TKeyword "f64.load" }
|
||||
'i32.load8_s' { TKeyword "i32.load8_s" }
|
||||
'i32.load8_u' { TKeyword "i32.load8_u" }
|
||||
'i32.load16_s' { TKeyword "i32.load16_s" }
|
||||
'i32.load16_u' { TKeyword "i32.load16_u" }
|
||||
'i64.load8_s' { TKeyword "i64.load8_s" }
|
||||
'i64.load8_u' { TKeyword "i64.load8_u" }
|
||||
'i64.load16_s' { TKeyword "i64.load16_s" }
|
||||
'i64.load16_u' { TKeyword "i64.load16_u" }
|
||||
'i64.load32_s' { TKeyword "i64.load32_s" }
|
||||
'i64.load32_u' { TKeyword "i64.load32_u" }
|
||||
'i32.store' { TKeyword "i32.store" }
|
||||
'i64.store' { TKeyword "i64.store" }
|
||||
'f32.store' { TKeyword "f32.store" }
|
||||
'f64.store' { TKeyword "f64.store" }
|
||||
id { TId $$ }
|
||||
u32 { TIntLit (asUInt32 -> Just $$) }
|
||||
offset { TKeyword (asOffset -> Just $$) }
|
||||
align { TKeyword (asAlign -> Just $$) }
|
||||
|
||||
%%
|
||||
|
||||
@@ -105,7 +136,14 @@ funcidx :: { FuncIndex }
|
||||
typeidx :: { TypeIndex }
|
||||
: u32 { $1 }
|
||||
|
||||
localidx :: { LocalIndex }
|
||||
: u32 { $1 }
|
||||
|
||||
globalidx :: { GlobalIndex }
|
||||
: u32 { $1 }
|
||||
|
||||
plaininstr :: { PlainInstr }
|
||||
-- control instructions
|
||||
: 'unreachable' { Unreachable }
|
||||
| 'nop' { Nop }
|
||||
| 'br' labelidx { Br $2 }
|
||||
@@ -114,6 +152,34 @@ plaininstr :: { PlainInstr }
|
||||
| 'return' { Return }
|
||||
| 'call' funcidx { Call $2 }
|
||||
| 'call_indirect' typeuse { CallIndirect $2 }
|
||||
-- parametric instructions
|
||||
| 'drop' { Drop }
|
||||
| 'select' { Select }
|
||||
-- variable instructions
|
||||
| 'get_local' localidx { GetLocal $2 }
|
||||
| 'set_local' localidx { SetLocal $2 }
|
||||
| 'tee_local' localidx { TeeLocal $2 }
|
||||
| 'get_global' globalidx { GetGlobal $2 }
|
||||
| 'set_global' globalidx { SetGlobal $2 }
|
||||
-- memory instructions
|
||||
| 'i32.load' memarg4 { I32Load $2 }
|
||||
| 'i64.load' memarg8 { I64Load $2 }
|
||||
| 'f32.load' memarg4 { F32Load $2 }
|
||||
| 'f64.load' memarg8 { F64Load $2 }
|
||||
| 'i32.load8_s' memarg1 { I32Load8S $2 }
|
||||
| 'i32.load8_u' memarg1 { I32Load8U $2 }
|
||||
| 'i32.load16_s' memarg2 { I32Load16S $2 }
|
||||
| 'i32.load16_u' memarg2 { I32Load16U $2 }
|
||||
| 'i64.load8_s' memarg1 { I64Load8S $2 }
|
||||
| 'i64.load8_u' memarg1 { I64Load8U $2 }
|
||||
| 'i64.load16_s' memarg2 { I64Load16S $2 }
|
||||
| 'i64.load16_u' memarg2 { I64Load16U $2 }
|
||||
| 'i64.load32_s' memarg4 { I64Load32S $2 }
|
||||
| 'i64.load32_u' memarg4 { I64Load32U $2 }
|
||||
| 'i32.store' memarg4 { I32Store $2 }
|
||||
| 'i64.store' memarg8 { I64Store $2 }
|
||||
| 'f32.store' memarg4 { F32Store $2 }
|
||||
| 'f64.store' memarg8 { F64Store $2 }
|
||||
|
||||
typedef :: { TypeDef }
|
||||
: '(' 'type' opt(ident) functype ')' { TypeDef $3 $4 }
|
||||
@@ -123,6 +189,18 @@ typeuse :: { TypeUse }
|
||||
| '(' 'type' typeidx paramtypes resulttypes ')' { IndexedTypeUse $3 (Just $ FuncType $4 $5) }
|
||||
| paramtypes resulttypes { AnonimousTypeUse $ FuncType $1 $2 }
|
||||
|
||||
memarg1 :: { MemArg }
|
||||
: opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 1 $2) }
|
||||
|
||||
memarg2 :: { MemArg }
|
||||
: opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 2 $2) }
|
||||
|
||||
memarg4 :: { MemArg }
|
||||
: opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 4 $2) }
|
||||
|
||||
memarg8 :: { MemArg }
|
||||
: opt(offset) opt(align) { MemArg (fromMaybe 0 $1) (fromMaybe 8 $2) }
|
||||
|
||||
-- utils
|
||||
|
||||
rev_list(p)
|
||||
@@ -150,6 +228,19 @@ asUInt32 val
|
||||
| val >= 0, val < 2 ^ 32 = Just $ fromIntegral val
|
||||
| otherwise = Nothing
|
||||
|
||||
asOffset :: LBS.ByteString -> Maybe Natural
|
||||
asOffset str = do
|
||||
num <- TL.stripPrefix "offset=" $ TLEncoding.decodeUtf8 str
|
||||
fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)
|
||||
|
||||
asAlign :: LBS.ByteString -> Maybe Natural
|
||||
asAlign str = do
|
||||
num <- TL.stripPrefix "align=" $ TLEncoding.decodeUtf8 str
|
||||
fromIntegral . fst <$> eitherToMaybe (TLRead.decimal num)
|
||||
|
||||
eitherToMaybe :: Either left right -> Maybe right
|
||||
eitherToMaybe = either (const Nothing) Just
|
||||
|
||||
data ValueType =
|
||||
I32
|
||||
| I64
|
||||
@@ -180,8 +271,11 @@ data TableType = TableType Limit ElemType deriving (Show, Eq)
|
||||
type LabelIndex = Natural
|
||||
type FuncIndex = Natural
|
||||
type TypeIndex = Natural
|
||||
type LocalIndex = Natural
|
||||
type GlobalIndex = Natural
|
||||
|
||||
data PlainInstr =
|
||||
-- Control instructions
|
||||
Unreachable
|
||||
| Nop
|
||||
| Br LabelIndex
|
||||
@@ -190,6 +284,34 @@ data PlainInstr =
|
||||
| Return
|
||||
| Call FuncIndex
|
||||
| CallIndirect TypeUse
|
||||
-- Parametric instructions
|
||||
| Drop
|
||||
| Select
|
||||
-- Variable instructions
|
||||
| GetLocal LocalIndex
|
||||
| SetLocal LocalIndex
|
||||
| TeeLocal LocalIndex
|
||||
| GetGlobal GlobalIndex
|
||||
| SetGlobal GlobalIndex
|
||||
-- Memory instructions
|
||||
| I32Load MemArg
|
||||
| I64Load MemArg
|
||||
| F32Load MemArg
|
||||
| F64Load MemArg
|
||||
| I32Load8S MemArg
|
||||
| I32Load8U MemArg
|
||||
| I32Load16S MemArg
|
||||
| I32Load16U MemArg
|
||||
| I64Load8S MemArg
|
||||
| I64Load8U MemArg
|
||||
| I64Load16S MemArg
|
||||
| I64Load16U MemArg
|
||||
| I64Load32S MemArg
|
||||
| I64Load32U MemArg
|
||||
| I32Store MemArg
|
||||
| I64Store MemArg
|
||||
| F32Store MemArg
|
||||
| F64Store MemArg
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)
|
||||
@@ -199,6 +321,8 @@ data TypeUse =
|
||||
| AnonimousTypeUse FuncType
|
||||
deriving (Show, Eq)
|
||||
|
||||
data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq)
|
||||
|
||||
happyError tokens = error $ "Error occuried: " ++ show tokens
|
||||
|
||||
}
|
||||
Reference in New Issue
Block a user