Commit 103c5d15 authored by Katharina Brandl's avatar Katharina Brandl
Browse files

Added labels to instructions

parent b71bd1c7
Pipeline #114986 passed with stages
in 75 minutes and 43 seconds
......@@ -55,7 +55,8 @@ instance (ArrowChoice c, Profunctor c) => ArrowStack v (StackT v c) where
st <- get -< ()
put -< []
y <- f -< x
put -< st
stNew <- get -< ()
put -< stNew ++ st
returnA -< y
--pop2 = StackT $ modify $ arr $ \((),v2:v1:st) -> ((v1,v2), st)
--popn = StackT $ modify $ arr $ \(n,st) -> splitAt (fromIntegral n) st
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.Abstract.Powerset where
......@@ -23,6 +24,7 @@ import qualified Data.HashSet as H
import Data.Foldable (foldl',toList)
import Data.List (intercalate)
import Data.Order
import Data.Text.Prettyprint.Doc
import GHC.Generics (Generic)
......@@ -46,6 +48,9 @@ instance UpperBounded a => UpperBounded (Pow a) where
instance Show a => Show (Pow a) where
show (Pow a) = "{" ++ intercalate ", " (show <$> toList a) ++ "}"
instance Pretty a => Pretty (Pow a) where
pretty (Pow a) = braces $ hsep (punctuate "," (pretty <$> toList a))
instance (Eq a, Hashable a) => Hashable (Pow a) where
hashWithSalt salt x = hashWithSalt salt (toHashSet x)
......
......@@ -19,6 +19,7 @@ dependencies:
- bytestring
- primitive
- list-singleton
- prettyprinter
library:
ghc-options: -Wall
......@@ -37,3 +38,4 @@ tests:
dependencies:
- hspec
- sturdy-wasm
- prettyprinter
......@@ -5,7 +5,8 @@
module Abstract where
import Concrete (TableInst, GlobInst, FuncInst)
import Data
import Concrete (TableInst, GlobInst)
import GenericInterpreter hiding (Top)
import Control.Arrow
......@@ -16,6 +17,7 @@ import Data.Abstract.FreeCompletion hiding (Top)
import qualified Data.Abstract.FreeCompletion as FC
import Data.Hashable
import Data.Order
import Data.Text.Prettyprint.Doc
import Data.Vector (Vector)
import qualified Data.Vector as Vec
......@@ -40,6 +42,8 @@ instance UpperBounded IsZero where
data BaseValue ai32 ai64 af32 af64 = VI32 ai32 | VI64 ai64 | VF32 af32 | VF64 af64 deriving (Show, Eq, Generic)
instance (Hashable ai32, Hashable ai64, Hashable af32, Hashable af64) => Hashable (BaseValue ai32 ai64 af32 af64)
instance (Show ai32, Show ai64, Show af32, Show af64) => Pretty (BaseValue ai32 ai64 af32 af64) where
pretty = viaShow
instance (PreOrd ai32, PreOrd ai64, PreOrd af32, PreOrd af64) => PreOrd (BaseValue ai32 ai64 af32 af64) where
(VI32 v1) (VI32 v2) = v1 v2
......@@ -61,6 +65,8 @@ data GlobalState v = GlobalState {
globalInstances:: Vector (FreeCompletion (GlobInst v))
} deriving (Show,Eq,Generic)
instance (Show v) => Pretty (GlobalState v) where pretty = viaShow
instance (Hashable v) => Hashable (GlobalState v)
instance (PreOrd v) => PreOrd (GlobalState v) where
......
......@@ -4,21 +4,22 @@
module Concrete where
import Data
import Data.Abstract.FreeCompletion
import Data.Hashable
import Data.Order
import Data.Text.Prettyprint.Doc
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
import Language.Wasm.Structure hiding (exports, Const, Function, Expression, Instruction)
import GHC.Generics
newtype Value = Value Wasm.Value deriving (Show, Eq)
data Mut = Const | Mutable deriving (Show, Eq, Generic)
instance Hashable Mut
......@@ -37,17 +38,6 @@ emptyGlobalState = GlobalState {
globalInstances = Vec.empty
}
data FuncInst =
FuncInst {
funcType :: FuncType,
moduleInstance :: ModuleInstance,
code :: Function
}
| HostInst {
funcType :: FuncType
--hostCode :: HostFunction v c
} deriving (Show,Eq, Generic)
instance (Hashable v) => Hashable (Vector v) where
hashWithSalt salt v = hashWithSalt salt (Vec.toList v)
......@@ -70,6 +60,7 @@ instance Hashable FuncInst
instance Hashable FuncType
instance Hashable ModuleInstance
deriving instance Generic ModuleInstance
instance Pretty ModuleInstance where pretty = viaShow
instance Hashable TableInst
instance Hashable Wasm.TableInstance
deriving instance Generic Wasm.TableInstance
......
......@@ -11,6 +11,7 @@
module ConcreteInterpreter where
import Data
import Concrete
import GenericInterpreter hiding (eval,evalNumericInst,evalParametricInst,invokeExported,store)
import qualified GenericInterpreter as Generic
......@@ -30,10 +31,13 @@ import Control.Arrow.Transformer.Concrete.GlobalState
import Control.Arrow.Transformer.Concrete.Serialize
import Control.Arrow.Transformer.Concrete.WasmFrame
import Control.Monad.State
import Data.Concrete.Error
import qualified Data.Function as Function
import Data.IORef
import Data.Label
import qualified Data.Primitive.ByteArray as ByteArray
import Data.Text.Lazy (Text)
import Data.Vector (Vector)
......@@ -42,7 +46,8 @@ import Data.Word
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports, Const)
import Language.Wasm.Structure hiding (exports, Const, Instruction, Function,Expression)
import qualified Language.Wasm.Structure as Wasm
import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
......@@ -187,16 +192,14 @@ instantiate valMod = do
where
storeToGlobalState (Wasm.Store funcI tableI memI globalI) = do
let funcs = generate $ Vec.mapM convertFuncInst funcI
mems <- Vec.mapM convertMem memI
globs <- Vec.mapM convertGlobals globalI
return $ GlobalState (Vec.map convertFuncs funcI)
return $ GlobalState funcs --(Vec.map convertFuncs funcI)
(Vec.map TableInst tableI)
mems
globs
convertFuncs (Wasm.FunctionInstance t m c) = FuncInst t m c
convertFuncs (Wasm.HostInstance t _) = HostInst t
convertMem (Wasm.MemoryInstance (Limit _ n) mem) = do
memStore <- readIORef mem
size <- ByteArray.getSizeofMutableByteArray memStore
......
......@@ -22,9 +22,11 @@ import Control.Arrow.Transformer.Writer
import qualified Data.Order as O
import Data.Profunctor
import Language.Wasm.Structure hiding (exports)
import Language.Wasm.Structure hiding (exports, Function)
import Language.Wasm.Interpreter (ModuleInstance(..))
import Data
......
......@@ -34,12 +34,13 @@ import Control.Arrow.Writer
import Data.Hashable
import Data.Order
import Data.Profunctor
import Data.Text.Prettyprint.Doc
import Data.Coerce
import GHC.Generics
import GHC.Exts
newtype AbsList v = AbsList [v] deriving (Show,Eq,Generic)
newtype AbsList v = AbsList [v] deriving (Show,Eq,Generic,Pretty)
instance (Hashable v) => Hashable (AbsList v)
......@@ -87,10 +88,11 @@ instance (ArrowChoice c, Profunctor c) => ArrowStack v (StackT v c) where
[] -> g -< x
_ -> f -< x
localFreshStack (StackT f) = StackT $ proc x -> do
st <- get -< ()
(AbsList st) <- get -< ()
put -< []
y <- f -< x
put -< st
(AbsList stNew) <- get -< ()
put -< AbsList $ stNew ++ st
returnA -< y
--pop2 = StackT $ modify $ arr $ \((),v2:v1:st) -> ((v1,v2), st)
--popn = StackT $ modify $ arr $ \(n,st) -> splitAt (fromIntegral n) st
......
......@@ -33,11 +33,12 @@ import Data.Hashable
import Data.Monoidal (shuffle1)
import Data.Order
import Data.Profunctor
import Data.Text.Prettyprint.Doc
import qualified Data.Vector as Vec
import GHC.Generics
newtype Vector v = Vector (Vec.Vector v) deriving (Show,Eq,Generic)
newtype Vector v = Vector (Vec.Vector v) deriving (Show,Eq,Generic,Pretty)
instance (Hashable v) => Hashable (Vector v)
---- hashWithSalt salt (Vector v) = hashWithSalt salt (Vec.toList v)
......
......@@ -46,6 +46,7 @@ import Numeric.Natural (Natural)
--import GenericInterpreter (LoadType,StoreType)
import Concrete
import Data
newtype GlobalStateT v c x y = GlobalStateT (StateT (GlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
......
......@@ -44,6 +44,7 @@ import Numeric.Natural (Natural)
--import GenericInterpreter (LoadType,StoreType)
import Concrete
import Data
newtype GlobalState2T v c x y = GlobalState2T (StateT (GlobalState v) c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
......@@ -62,7 +63,7 @@ instance ArrowTrans (GlobalState2T v) where
lift' a = GlobalState2T (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v MemInst (GlobalState2T v c) where
readGlobal =
readGlobal =
GlobalState2T $ proc i -> do
GlobalState{globalInstances=vec} <- get -< ()
let (GlobInst _ val) = vec ! i
......@@ -74,7 +75,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v MemInst (GlobalStat
if m == Const
then returnA -< error $ "writing to constant global " ++ (show i)
else put -< store{globalInstances=vec // [(i, GlobInst m v)]}
-- funcCont :: ReaderT Int (StateT (GlobalState v) c) ((FuncType, ModuleInstance, Function),x) y
-- we need ReaderT Int (StateT (GlobalState v) c) (Int, x) y
readFunction (GlobalState2T funcCont) =
......@@ -89,10 +90,10 @@ instance (ArrowChoice c, Profunctor c) => ArrowGlobalState v MemInst (GlobalStat
fetchMemory = GlobalState2T $ proc i -> do
GlobalState{memInstances=mems} <- get -< ()
returnA -< mems ! i
storeMemory = GlobalState2T $ proc (i,m) -> do
gs@GlobalState{memInstances=mems} <- get -< ()
put -< gs{memInstances=mems // [(i,m)]}
put -< gs{memInstances=mems // [(i,m)]}
instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (GlobalState2T v c) where
memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
......
{-# LANGUAGE DeriveGeneric #-}
module Data where
--import Control.DeepSeq (NFData)
import Control.Monad.State
import Data.Label
import Data.Text.Prettyprint.Doc
import GHC.Generics (Generic)
import Data.Vector (Vector)
import Data.Word (Word32, Word64)
import Numeric.Natural (Natural)
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure (ResultType, MemArg, BitSize, IUnOp(..), IBinOp(..), IRelOp(..),
FUnOp(..), FBinOp(..), FRelOp(..), FuncType, TypeIndex, LocalsType)
import qualified Language.Wasm.Structure as Wasm
data Mut = Const | Mutable deriving (Show, Eq, Generic)
instance (Show v) => Pretty (Vector v) where pretty = viaShow
data FuncInst =
FuncInst {
funcType :: FuncType,
moduleInstance :: ModuleInstance,
code :: Function
}
| HostInst {
funcType :: FuncType
--hostCode :: HostFunction v c
} deriving (Show,Eq, Generic)
data Function = Function {
funcT :: TypeIndex,
localTypes :: LocalsType,
funcBody :: Expression
} deriving (Show, Eq, Generic)
type Expression = [Instruction Natural]
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 }
| Br index Label
| BrIf index Label
| BrTable [index] index Label
| Return Label
| Call index Label
| CallIndirect index Label
-- Parametric instructions
| Drop Label
| Select Label
-- Variable instructions
| GetLocal index Label
| SetLocal index Label
| TeeLocal index Label
| GetGlobal index Label
| SetGlobal index Label
-- Memory instructions
| I32Load MemArg Label
| I64Load MemArg Label
| F32Load MemArg Label
| F64Load MemArg Label
| I32Load8S MemArg Label
| I32Load8U MemArg Label
| I32Load16S MemArg Label
| I32Load16U MemArg Label
| I64Load8S MemArg Label
| I64Load8U MemArg Label
| I64Load16S MemArg Label
| I64Load16U MemArg Label
| I64Load32S MemArg Label
| I64Load32U MemArg Label
| I32Store MemArg Label
| I64Store MemArg Label
| F32Store MemArg Label
| F64Store MemArg Label
| I32Store8 MemArg Label
| I32Store16 MemArg Label
| I64Store8 MemArg Label
| I64Store16 MemArg Label
| I64Store32 MemArg Label
| CurrentMemory Label
| GrowMemory Label
-- Numeric instructions
| I32Const Word32 Label
| I64Const Word64 Label
| F32Const Float Label
| F64Const Double Label
| IUnOp BitSize IUnOp Label
| IBinOp BitSize IBinOp Label
| I32Eqz Label
| I64Eqz Label
| IRelOp BitSize IRelOp Label
| FUnOp BitSize FUnOp Label
| FBinOp BitSize FBinOp Label
| FRelOp BitSize FRelOp Label
| I32WrapI64 Label
| ITruncFU {- Int Size -} BitSize {- Float Size -} BitSize Label
| ITruncFS {- Int Size -} BitSize {- Float Size -} BitSize Label
| I64ExtendSI32 Label
| I64ExtendUI32 Label
| FConvertIU {- Float Size -} BitSize {- Int Size -} BitSize Label
| FConvertIS {- Float Size -} BitSize {- Int Size -} BitSize Label
| F32DemoteF64 Label
| F64PromoteF32 Label
| IReinterpretF BitSize Label
| FReinterpretI BitSize Label
deriving (Show, Eq, Generic)
type LInstruction = State Label (Instruction Natural)
unreachable :: LInstruction
unreachable = Unreachable <$> fresh
nop :: LInstruction
nop = Nop <$> fresh
block :: ResultType -> [LInstruction] -> LInstruction
block rt body = Block rt <$> sequence body <*> fresh
loop :: ResultType -> [LInstruction] -> LInstruction
loop rt body = Loop rt <$> sequence body <*> fresh
if_ :: ResultType -> [LInstruction] -> [LInstruction] -> LInstruction
if_ rt bTrue bFalse = If rt <$> sequence bTrue <*> sequence bFalse <*> fresh
br :: Natural -> LInstruction
br i = Br i <$> fresh
brIf :: Natural -> LInstruction
brIf i = BrIf i <$> fresh
brTable :: [Natural] -> Natural -> LInstruction
brTable is i = BrTable is i <$> fresh
return_ :: LInstruction
return_ = Return <$> fresh
call :: Natural -> LInstruction
call i = Call i <$> fresh
callIndirect :: Natural -> LInstruction
callIndirect i = CallIndirect i <$> fresh
drop_ :: LInstruction
drop_ = Drop <$> fresh
select :: LInstruction
select = Select <$> fresh
getLocal :: Natural -> LInstruction
getLocal i = GetLocal i <$> fresh
setLocal :: Natural -> LInstruction
setLocal i = SetLocal i <$> fresh
teeLocal :: Natural -> LInstruction
teeLocal i = TeeLocal i <$> fresh
getGlobal :: Natural -> LInstruction
getGlobal i = GetGlobal i <$> fresh
setGlobal :: Natural -> LInstruction
setGlobal i = SetGlobal i <$> fresh
i32Load :: MemArg -> LInstruction
i32Load m = I32Load m <$> fresh
i64Load :: MemArg -> LInstruction
i64Load m = I64Load m <$> fresh
f32Load :: MemArg -> LInstruction
f32Load m = F32Load m <$> fresh
f64Load :: MemArg -> LInstruction
f64Load m = F64Load m <$> fresh
i32Store :: MemArg -> LInstruction
i32Store m = I32Store m <$> fresh
i64Store :: MemArg -> LInstruction
i64Store m = I64Store m <$> fresh
f32Store :: MemArg -> LInstruction
f32Store m = F32Store m <$> fresh
f64Store :: MemArg -> LInstruction
f64Store m = F64Store m <$> fresh
i32Const :: Word32 -> LInstruction
i32Const w32 = I32Const w32 <$> fresh
i64Const :: Word64 -> LInstruction
i64Const w64 = I64Const w64 <$> fresh
f32Const :: Float -> LInstruction
f32Const f = F32Const f <$> fresh
f64Const :: Double -> LInstruction
f64Const d = F64Const d <$> fresh
iUnOp :: BitSize -> IUnOp -> LInstruction
iUnOp bs op = IUnOp bs op <$> fresh
iBinOp :: BitSize -> IBinOp -> LInstruction
iBinOp bs op = IBinOp bs op <$> fresh
i32Eqz :: LInstruction
i32Eqz = I32Eqz <$> fresh
i64Eqz :: LInstruction
i64Eqz = I64Eqz <$> fresh
iRelOp :: BitSize -> IRelOp -> LInstruction
iRelOp bs op = IRelOp bs op <$> fresh
fUnOp :: BitSize -> FUnOp -> LInstruction
fUnOp bs op = FUnOp bs op <$> fresh
fBinOp :: BitSize -> FBinOp -> LInstruction
fBinOp bs op = FBinOp bs op <$> fresh
fRelOp :: BitSize -> FRelOp -> LInstruction
fRelOp bs op = FRelOp bs op <$> fresh
i32WrapI64 :: LInstruction
i32WrapI64 = I32WrapI64 <$> fresh
iTruncFU :: BitSize -> BitSize -> LInstruction
iTruncFU b1 b2 = ITruncFU b1 b2 <$> fresh
iTruncFS :: BitSize -> BitSize -> LInstruction
iTruncFS b1 b2 = ITruncFS b1 b2 <$> fresh
i64ExtendSI32 :: LInstruction
i64ExtendSI32 = I64ExtendSI32 <$> fresh
i64ExtendUI32 :: LInstruction
i64ExtendUI32 = I64ExtendUI32 <$> fresh
convertInstruction :: Wasm.Instruction Natural -> LInstruction
convertInstruction i = case i of
Wasm.Unreachable -> unreachable
Wasm.Nop -> nop
Wasm.Block rt body -> block rt (map convertInstruction body)
Wasm.Loop rt body -> loop rt (map convertInstruction body)
Wasm.If rt t f -> if_ rt (map convertInstruction t) (map convertInstruction f)
Wasm.Br i -> br i
Wasm.BrIf i -> brIf i
Wasm.BrTable is i -> brTable is i
Wasm.Return -> return_
Wasm.Call i -> call i
Wasm.Drop -> drop_
Wasm.Select -> select
Wasm.GetLocal i -> getLocal i
Wasm.SetLocal i -> setLocal i
Wasm.TeeLocal i -> teeLocal i
Wasm.GetGlobal i -> getGlobal i
Wasm.SetGlobal i -> setGlobal i
Wasm.I32Load m -> i32Load m
Wasm.I64Load m -> i64Load m
Wasm.F32Load m -> f32Load m
Wasm.F64Load m -> f64Load m
Wasm.I32Store m -> i32Store m
Wasm.I64Store m -> i64Store m
Wasm.F32Store m -> f32Store m
Wasm.F64Store m -> f64Store m
Wasm.I32Const w32 -> i32Const w32
Wasm.I64Const w64 -> i64Const w64
Wasm.F32Const f -> f32Const f
Wasm.F64Const d -> f64Const d
Wasm.IUnOp bs op -> iUnOp bs op
Wasm.IBinOp bs op -> iBinOp bs op
Wasm.I32Eqz -> i32Eqz
Wasm.I64Eqz -> i64Eqz
Wasm.IRelOp bs op -> iRelOp bs op
Wasm.FUnOp bs op -> fUnOp bs op
Wasm.FBinOp bs op -> fBinOp bs op
Wasm.FRelOp bs op -> fRelOp bs op
convertExpr :: Wasm.Expression -> [LInstruction]
convertExpr = map convertInstruction
convertFunc :: Wasm.Function -> State Label Function
convertFunc (Wasm.Function ft lt bd) = Function ft lt <$> sequence (convertExpr bd)
convertFuncInst :: Wasm.FunctionInstance -> State Label FuncInst
convertFuncInst (Wasm.FunctionInstance t m c) = FuncInst t m <$> convertFunc c
This diff is collapsed.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
......@@ -13,7 +15,8 @@ module UnitAnalysis where
import Abstract
import qualified Abstract as A
import Concrete (LoadType, StoreType, FuncInst(..), GlobInst(..), TableInst(..), Mut(..))
import Concrete (LoadType, StoreType, GlobInst(..), TableInst(..))
import Data
import GenericInterpreter hiding (Exc)
import qualified GenericInterpreter as Generic
......@@ -47,7 +50,7 @@ import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.DebuggableStack
import Control.Arrow.Transformer.Abstract.Logger
import Control.Arrow.Transformer.Abstract.Stack (AbsList)
import Control.Arrow.Transformer.Abstract.Stack (AbsList, StackT)
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
......@@ -63,25 +66,34 @@ import qualified Data.Function as Function
import Data.Hashable
import Data.HashSet as HashSet
import Data.IORef
import Data.Label
import Data.Order
import Data.Abstract.DiscretePowerset
import Data.Abstract.Error
import Data.Abstract.Error as Error
import Data.Abstract.Except
import qualified Data.Abstract.Powerset as Pow
import qualified Data.Abstract.Widening as W
import Data.Profunctor
import Data.Text.Lazy (Text)
import Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Vector as Vec
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding