Commit e8ae0cea authored by Katharina Brandl's avatar Katharina Brandl
Browse files

update to use new parser

parent 5d9bd0e6
Pipeline #148731 failed with stages
in 78 minutes and 21 seconds
......@@ -19,5 +19,5 @@ extra-deps:
- git: https://github.com/svenkeidel/husk-scheme/
commit: ca59598b11065eb29a45af7ffca27fc42a49abe5
- git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git
commit: 91c54c4440977805ef20494278db185545df541a
commit: 79a51ce931b183267ab4ac483d7dbaa724df7863
- knob-0.1.1
......@@ -25,8 +25,9 @@ import Numeric.Natural (Natural)
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure (ResultType, MemArg, BitSize, IUnOp(..), IBinOp(..), IRelOp(..),
FUnOp(..), FBinOp(..), FRelOp(..), FuncType, TypeIndex, LocalsType)
import Language.Wasm.Structure (MemArg, BitSize, IUnOp(..), IBinOp(..), IRelOp(..),
FUnOp(..), FBinOp(..), FRelOp(..), FuncType, TypeIndex, LocalsType,
BlockType)
import qualified Language.Wasm.Structure as Wasm
import Language.Wasm.Validate (ValidModule)
......@@ -141,9 +142,9 @@ data Instruction index =
-- Control instructions
Unreachable Label
| Nop Label
| Block { resultType :: ResultType, body :: Expression, lbl :: Label }
| Loop { resultType :: ResultType, body :: Expression, lbl :: Label }
| If { resultType :: ResultType, true :: Expression, false :: Expression, lbl :: Label }
| Block { blockType :: BlockType, body :: Expression, lbl :: Label }
| Loop { blockType :: BlockType, body :: Expression, lbl :: Label }
| If { blockType :: BlockType, true :: Expression, false :: Expression, lbl :: Label }
| Br index Label
| BrIf index Label
| BrTable [index] index Label
......@@ -286,11 +287,11 @@ unreachable :: LInstruction
unreachable = Unreachable <$> fresh
nop :: LInstruction
nop = Nop <$> fresh
block :: ResultType -> [LInstruction] -> LInstruction
block :: BlockType -> [LInstruction] -> LInstruction
block rt bdy = Block rt <$> sequence bdy <*> fresh
loop :: ResultType -> [LInstruction] -> LInstruction
loop :: BlockType -> [LInstruction] -> LInstruction
loop rt bdy = Loop rt <$> sequence bdy <*> fresh
if_ :: ResultType -> [LInstruction] -> [LInstruction] -> LInstruction
if_ :: BlockType -> [LInstruction] -> [LInstruction] -> LInstruction
if_ rt bTrue bFalse = If rt <$> sequence bTrue <*> sequence bFalse <*> fresh
br :: Natural -> LInstruction
br i = Br i <$> fresh
......@@ -439,10 +440,10 @@ instantiate :: ValidModule
instantiate valMod alpha toMem toTable = do
res <- Wasm.instantiate emptyStore emptyImports valMod
case res of
Right (modInst, store) -> do
(Right modInst, store) -> do
(staticState,tables,mems) <- storeToGlobalState store
return $ Right (modInst, staticState, tables, mems)
Left e -> return $ Left e
(Left e, _) -> return $ Left e
where
storeToGlobalState (Wasm.Store funcI tableI memI globalI) = do
......@@ -456,7 +457,7 @@ instantiate valMod alpha toMem toTable = do
convertMem (Wasm.MemoryInstance (Wasm.Limit _ n) mem) = do
memStore <- readIORef mem
size <- ByteArray.getSizeofMutableByteArray memStore
list <- mapM (\x -> ByteArray.readByteArray memStore x) [0 .. (size-1)]
list <- mapM (ByteArray.readByteArray memStore) [0 .. (size-1)]
let sizeConverted = fmap fromIntegral n
return $ toMem sizeConverted list
--return $ MemInst sizeConverted $ Vec.fromList list
......@@ -496,6 +497,7 @@ instance Hashable FUnOp
instance Hashable FBinOp
instance Hashable FRelOp
instance Hashable Wasm.ExternalValue
instance Hashable BlockType
deriving instance Generic ModuleInstance
......
......@@ -38,13 +38,14 @@ import Control.Arrow.Globals
import Control.Arrow.WasmFrame
import Data.Hashable
import Data.Maybe(maybeToList)
import Data.Profunctor
import Data.Text.Lazy (Text)
import Data.Vector hiding (length, (++))
import Data.Word
import Language.Wasm.Structure (ValueType(..), BitSize, IUnOp(..), IBinOp(..), IRelOp(..),
FUnOp(..), FBinOp(..), FRelOp(..), MemArg(..), FuncType(..), ResultType)
FUnOp(..), FBinOp(..), FRelOp(..), MemArg(..), FuncType(..), ResultType, BlockType(..))
import Language.Wasm.Interpreter (ModuleInstance(..), emptyModInstance, ExportInstance(..), ExternalValue(..))
import Numeric.Natural (Natural)
......@@ -248,14 +249,22 @@ evalControlInst ::
evalControlInst eval' = proc i -> case i of
Unreachable _ -> trap -< "Execution of unreachable instruction"
Nop _ -> returnA -< ()
Block rt is _ -> label eval' eval' -< (rt, is, [])
Loop rt is l -> label eval' eval' -< (rt, is, [Loop rt is l])
If rt isNZero isZero _ -> do
Block bt is _ -> do
(FuncType paramTys resultTys) <- expandType -< bt
popn -< fromIntegral (length paramTys)
label eval' eval' -< (resultTys, is, [])
Loop bt is l -> do
(FuncType paramTys resultTys) <- expandType -< bt
popn -< fromIntegral (length paramTys)
label eval' eval' -< (resultTys, is, [Loop bt is l])
If bt isNZero isZero _ -> do
v <- pop -< ()
(FuncType paramTys resultTys) <- expandType -< bt
popn -< fromIntegral (length paramTys)
i32ifNeqz
(proc (rt, isNZero, _) -> label eval' eval' -< (rt, isNZero, []))
(proc (rt, _, isZero) -> label eval' eval' -< (rt, isZero, []))
-< (v, (rt, isNZero, isZero))
-< (v, (resultTys, isNZero, isZero))
Br ix _ -> branch -< ix
BrIf ix _ -> do
v <- pop -< ()
......@@ -285,6 +294,17 @@ evalControlInst eval' = proc i -> case i of
(proc (ta,ix,_) -> trap -< printf "Index %s uninitialized for table address %s" (show ix) (show ta))
-< (tableAddr, funcAddr, ftExpect)
expandType :: (ArrowChoice c, ArrowStaticComponents v c) => c BlockType FuncType
expandType = proc bt -> case bt of
Inline mVal -> returnA -< FuncType [] (maybeToList mVal)
TypeIndex idx -> do
(_, modInst) <- frameData -< ()
let ft = funcTypes modInst ! fromIntegral idx
returnA -< ft
invokeChecked ::
( ArrowChoice c,
ArrowStaticComponents v c,
......
......@@ -25,6 +25,6 @@ spec = do
content <- LBS.readFile path
let Right m = parse content
let Right validMod = validate m
Right (modInst, store) <- instantiate emptyStore emptyImports validMod
(Right modInst, store) <- instantiate emptyStore emptyImports validMod
Just result <- invokeExport store modInst (pack "fac-rec") [VI64 2]
result `shouldBe` [VI64 2]
(module
;; Recursive factorial
(func (export "fac-rec") (param i64) (result i64)
(if (result i64) (i64.eq (get_local 0) (i64.const 0))
(if (result i64) (i64.eq (local.get 0) (i64.const 0))
(then (i64.const 1))
(else
(i64.mul (get_local 0) (call 0 (i64.sub (get_local 0) (i64.const 1))))
(i64.mul (local.get 0) (call 0 (i64.sub (local.get 0) (i64.const 1))))
)
)
)
;; Recursive factorial named
(func $fac-rec-named (export "fac-rec-named") (param $n i64) (result i64)
(if (result i64) (i64.eq (get_local $n) (i64.const 0))
(if (result i64) (i64.eq (local.get $n) (i64.const 0))
(then (i64.const 1))
(else
(i64.mul
(get_local $n)
(call $fac-rec-named (i64.sub (get_local $n) (i64.const 1)))
(local.get $n)
(call $fac-rec-named (i64.sub (local.get $n) (i64.const 1)))
)
)
)
......@@ -24,12 +24,12 @@
;; Recursive factorial named
(func $fac-rec-named-32 (export "fac-rec-named-32") (param $n i32) (result i32)
(if (result i32) (i32.eq (get_local $n) (i32.const 0))
(if (result i32) (i32.eq (local.get $n) (i32.const 0))
(then (i32.const 1))
(else
(i32.mul
(get_local $n)
(call $fac-rec-named-32 (i32.sub (get_local $n) (i32.const 1)))
(local.get $n)
(call $fac-rec-named-32 (i32.sub (local.get $n) (i32.const 1)))
)
)
)
......@@ -38,80 +38,80 @@
;; Iterative factorial
(func (export "fac-iter") (param i64) (result i64)
(local i64 i64)
(set_local 1 (get_local 0))
(set_local 2 (i64.const 1))
(local.set 1 (local.get 0))
(local.set 2 (i64.const 1))
(block
(loop
(if
(i64.eq (get_local 1) (i64.const 0))
(i64.eq (local.get 1) (i64.const 0))
(then (br 2))
(else
(set_local 2 (i64.mul (get_local 1) (get_local 2)))
(set_local 1 (i64.sub (get_local 1) (i64.const 1)))
(local.set 2 (i64.mul (local.get 1) (local.get 2)))
(local.set 1 (i64.sub (local.get 1) (i64.const 1)))
)
)
(br 0)
)
)
(get_local 2)
(local.get 2)
)
;; Iterative factorial named
(func (export "fac-iter-named") (param $n i64) (result i64)
(local $i i64)
(local $res i64)
(set_local $i (get_local $n))
(set_local $res (i64.const 1))
(local.set $i (local.get $n))
(local.set $res (i64.const 1))
(block $done
(loop $loop
(if
(i64.eq (get_local $i) (i64.const 0))
(i64.eq (local.get $i) (i64.const 0))
(then (br $done))
(else
(set_local $res (i64.mul (get_local $i) (get_local $res)))
(set_local $i (i64.sub (get_local $i) (i64.const 1)))
(local.set $res (i64.mul (local.get $i) (local.get $res)))
(local.set $i (i64.sub (local.get $i) (i64.const 1)))
)
)
(br $loop)
)
)
(get_local $res)
(local.get $res)
)
;; Iterative factorial named
(func (export "fac-iter-named-32") (param $n i32) (result i32)
(local $i i32)
(local $res i32)
(set_local $i (get_local $n))
(set_local $res (i32.const 1))
(local.set $i (local.get $n))
(local.set $res (i32.const 1))
(block $done
(loop $loop
(if
(i32.eq (get_local $i) (i32.const 0))
(i32.eq (local.get $i) (i32.const 0))
(then (br $done))
(else
(set_local $res (i32.mul (get_local $i) (get_local $res)))
(set_local $i (i32.sub (get_local $i) (i32.const 1)))
(local.set $res (i32.mul (local.get $i) (local.get $res)))
(local.set $i (i32.sub (local.get $i) (i32.const 1)))
)
)
(br $loop)
)
)
(get_local $res)
(local.get $res)
)
;; Optimized factorial.
(func (export "fac-opt") (param i64) (result i64)
(local i64)
(set_local 1 (i64.const 1))
(local.set 1 (i64.const 1))
(block
(br_if 0 (i64.lt_s (get_local 0) (i64.const 2)))
(br_if 0 (i64.lt_s (local.get 0) (i64.const 2)))
(loop
(set_local 1 (i64.mul (get_local 1) (get_local 0)))
(set_local 0 (i64.add (get_local 0) (i64.const -1)))
(br_if 0 (i64.gt_s (get_local 0) (i64.const 1)))
(local.set 1 (i64.mul (local.get 1) (local.get 0)))
(local.set 0 (i64.add (local.get 0) (i64.const -1)))
(br_if 0 (i64.gt_s (local.get 0) (i64.const 1)))
)
)
(get_local 1)
(local.get 1)
)
)
(module
(memory 1)
(table anyfunc
(table funcref
(elem
$noop
)
......@@ -10,7 +10,7 @@
(type $out-i32 (func (result i32)))
(func (export "const") (param i32) (result i32)
(get_local 0)
(local.get 0)
)
(func $noop (export "noop") (result i32)
......@@ -30,57 +30,57 @@
)
(func $fac-rec (export "fac-rec") (param i64) (result i64)
get_local 0
local.get 0
i64.const 0
i64.eq
(if (result i64)
(then
i64.const 1)
(else
get_local 0
get_local 0
local.get 0
local.get 0
i64.const 1
i64.sub
call $fac-rec
i64.mul)))
(func (export "fac-iter") (param i64) (result i64) (local i64 i64)
get_local 0
set_local 1
local.get 0
local.set 1
i64.const 1
set_local 2
local.set 2
(block
(loop
get_local 1
local.get 1
i64.const 0
i64.eq
(if
(then
br 2)
(else
get_local 1
get_local 2
local.get 1
local.get 2
i64.mul
set_local 2
get_local 1
local.set 2
local.get 1
i64.const 1
i64.sub
set_local 1
local.set 1
)
)
br 0
)
)
get_local 2
local.get 2
)
(func (export "half-fac") (param i32) (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then (i32.const 1))
(else (i32.const 0))))
(func (export "half-fac-64") (param i64) (result i64)
(if (result i64) (i64.eq (get_local 0) (i64.const 0))
(if (result i64) (i64.eq (local.get 0) (i64.const 0))
(then (i64.const 1))
(else (i64.const 0))))
......@@ -92,7 +92,7 @@
(func (export "maybe-non-terminating") (param i32) (result i32)
(block
(loop
(br_if 1 (i32.eq (get_local 0) (i32.const 42)))
(br_if 1 (i32.eq (local.get 0) (i32.const 42)))
(br 0)
)
)
......@@ -101,7 +101,7 @@
(func (export "test-mem") (param i32) (result i32)
i32.const 0
get_local 0
local.get 0
i32.store
i32.const 0
i32.load
......@@ -133,7 +133,7 @@
(func (export "test-br3") (param i32) (result i32)
(block (result i32)
(block (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then
i32.const 42
br 0
......@@ -150,7 +150,7 @@
(func (export "test-br-and-return") (param i32) (result i32)
(block (result i32)
(block (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then
i32.const 42
return
......@@ -195,7 +195,7 @@
)
(func (export "test-unreachable5") (param i32) (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then
i32.const 42
br 1
......@@ -210,7 +210,7 @@
(func (export "test-br-and-return3") (param i32) (result i32)
(block (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then
i32.const 42
br 1
......@@ -227,7 +227,7 @@
(func (export "test-br-and-return2") (param i32) (result i32)
(block (result i32)
(block (result i32)
(if (result i32) (i32.eq (get_local 0) (i32.const 0))
(if (result i32) (i32.eq (local.get 0) (i32.const 0))
(then
i32.const 42
return
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment