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

taint analysis

parent acbd31b1
Pipeline #130361 passed with stages
in 74 minutes and 47 seconds
...@@ -63,6 +63,10 @@ instance Complete TableInst where ...@@ -63,6 +63,10 @@ instance Complete TableInst where
instance Hashable TableInst instance Hashable TableInst
data Size = Size deriving (Eq,Show)
data Addr = Addr deriving (Eq,Show)
data Bytes = Bytes deriving (Eq,Show)
--data GlobalState v = GlobalState { --data GlobalState v = GlobalState {
-- funcInstances :: Vector FuncInst, -- funcInstances :: Vector FuncInst,
-- tableInstances :: Vector TableInst, -- tableInstances :: Vector TableInst,
......
...@@ -21,6 +21,7 @@ import qualified GenericInterpreter as Generic ...@@ -21,6 +21,7 @@ import qualified GenericInterpreter as Generic
import Control.Arrow import Control.Arrow
import qualified Control.Arrow.Trans as Trans import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Except import Control.Arrow.Except
import Control.Arrow.Fail as Fail
import Control.Arrow.Transformer.Stack import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.StaticGlobalState import Control.Arrow.Transformer.StaticGlobalState
...@@ -51,11 +52,12 @@ import Language.Wasm.Structure hiding (exports, Const, Instruction, Fu ...@@ -51,11 +52,12 @@ import Language.Wasm.Structure hiding (exports, Const, Instruction, Fu
import Language.Wasm.Validate (ValidModule) import Language.Wasm.Validate (ValidModule)
import Numeric.IEEE (copySign) import Numeric.IEEE (copySign)
import Text.Printf
--trap :: IsException (Exc v) v c => c String x --trap :: IsException (Exc v) v c => c String x
--trap = throw <<< exception <<^ Trap --trap = throw <<< exception <<^ Trap
instance (ArrowChoice c) => IsVal Value (ValueT Value c) where instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (ValueT Value c) where
type JoinVal y (ValueT Value c) = () type JoinVal y (ValueT Value c) = ()
i32const = proc w32 -> returnA -< int32 w32 i32const = proc w32 -> returnA -< int32 w32
...@@ -71,63 +73,63 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where ...@@ -71,63 +73,63 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
(BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v (BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v
(BS64, IPopcnt, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ popCount v (BS64, IPopcnt, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ popCount v
_ -> returnA -< error "iUnOp: cannot apply operator to arguements" _ -> returnA -< error "iUnOp: cannot apply operator to arguements"
iBinOp eCont sCont = proc (bs,op,x@(Value v1),y@(Value v2),z) -> case (bs,op,v1,v2) of iBinOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
(BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> sCont -< (int32 $ val1 + val2,z) (BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 + val2
-- (BS32, ISub, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 - val2 (BS32, ISub, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 - val2
-- (BS32, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 * val2 (BS32, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 * val2
-- (BS32, IDivU, Wasm.VI32 val1, Wasm.VI32 val2) -> (BS32, IDivU, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int32 $ val1 `quot` val2 else returnA -< int32 $ val1 `quot` val2
-- (BS32, IDivS, Wasm.VI32 val1, Wasm.VI32 val2) -> (BS32, IDivS, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0 || (val1 == 0x80000000 && val2 == 0xFFFFFFFF) if val2 == 0 || (val1 == 0x80000000 && val2 == 0xFFFFFFFF)
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2) else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2)
-- (BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) -> (BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int32 $ val1 `rem` val2 else returnA -< int32 $ val1 `rem` val2
-- (BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) -> (BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int32 $ asWord32 (asInt32 val1 `rem` asInt32 val2) else returnA -< int32 $ asWord32 (asInt32 val1 `rem` asInt32 val2)
-- (BS32, IAnd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .&. val2 (BS32, IAnd, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .&. val2
-- (BS32, IOr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .|. val2 (BS32, IOr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 .|. val2
-- (BS32, IXor, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `xor` val2 (BS32, IXor, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `xor` val2
-- (BS32, IShl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftL` (fromIntegral val2 `rem` 32) (BS32, IShl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftL` (fromIntegral val2 `rem` 32)
-- (BS32, IShrU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftR` (fromIntegral val2 `rem` 32) (BS32, IShrU, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `shiftR` (fromIntegral val2 `rem` 32)
-- (BS32, IShrS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ asWord32 $ asInt32 val1 `shiftR` (fromIntegral val2 `rem` 32) (BS32, IShrS, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ asWord32 $ asInt32 val1 `shiftR` (fromIntegral val2 `rem` 32)
-- (BS32, IRotl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateL` fromIntegral val2 (BS32, IRotl, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateL` fromIntegral val2
-- (BS32, IRotr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateR` fromIntegral val2 (BS32, IRotr, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 `rotateR` fromIntegral val2
--
-- (BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 + val2 (BS64, IAdd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 + val2
-- (BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 - val2 (BS64, ISub, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 - val2
-- (BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2 (BS64, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2
-- (BS64, IDivU, Wasm.VI64 val1, Wasm.VI64 val2) -> (BS64, IDivU, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int64 $ val1 `quot` val2 else returnA -< int64 $ val1 `quot` val2
-- (BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) -> (BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF) if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF)
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2) else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
-- (BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) -> (BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int64 $ val1 `rem` val2 else returnA -< int64 $ val1 `rem` val2
-- (BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) -> (BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0 if val2 == 0
-- then eCont -< (op,x,y) then trap -< "iBinOp: division by zero."
-- else returnA -< int64 $ asWord64 (asInt64 val1 `rem` asInt64 val2) else returnA -< int64 $ asWord64 (asInt64 val1 `rem` asInt64 val2)
-- (BS64, IAnd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .&. val2 (BS64, IAnd, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .&. val2
-- (BS64, IOr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .|. val2 (BS64, IOr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 .|. val2
-- (BS64, IXor, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `xor` val2 (BS64, IXor, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `xor` val2
-- (BS64, IShl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftL` (fromIntegral val2 `rem` 64) (BS64, IShl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftL` (fromIntegral val2 `rem` 64)
-- (BS64, IShrU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftR` (fromIntegral val2 `rem` 64) (BS64, IShrU, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `shiftR` (fromIntegral val2 `rem` 64)
-- (BS64, IShrS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ asWord64 $ asInt64 val1 `shiftR` (fromIntegral val2 `rem` 64) (BS64, IShrS, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ asWord64 $ asInt64 val1 `shiftR` (fromIntegral val2 `rem` 64)
-- (BS64, IRotl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateL` fromIntegral val2 (BS64, IRotl, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateL` fromIntegral val2
-- (BS64, IRotr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateR` fromIntegral val2 (BS64, IRotr, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 `rotateR` fromIntegral val2
-- _ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments." _ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments."
iRelOp = proc (bs,op,Value v1, Value v2) -> case (bs,op,v1,v2) of iRelOp = proc (bs,op,Value v1, Value v2) -> case (bs,op,v1,v2) of
(BS32, IEq, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 == val2 then 1 else 0 (BS32, IEq, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 == val2 then 1 else 0
(BS32, INe, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0 (BS32, INe, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ if val1 /= val2 then 1 else 0
...@@ -221,40 +223,44 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where ...@@ -221,40 +223,44 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
i32WrapI64 = proc (Value v) -> case v of i32WrapI64 = proc (Value v) -> case v of
(Wasm.VI64 val) -> returnA -< int32 $ fromIntegral $ val .&. 0xFFFFFFFF (Wasm.VI64 val) -> returnA -< int32 $ fromIntegral $ val .&. 0xFFFFFFFF
_ -> returnA -< error "i32WrapI64: cannot apply operator to given argument." _ -> returnA -< error "i32WrapI64: cannot apply operator to given argument."
iTruncFU eCont = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of iTruncFU = proc (bs1,bs2,x@(Value v)) -> do
let errorTrunc = printf "iTruncFU: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) -> (BS32, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^32 || val <= -1 if isNaN val || isInfinite val || val >= 2^32 || val <= -1
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 val) -> (BS32, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^32 || val <= -1 if isNaN val || isInfinite val || val >= 2^32 || val <= -1
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 val) -> (BS64, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^64 || val <= -1 if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int64 $ truncate val else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 val) -> (BS64, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^64 || val <= -1 if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int64 $ truncate val else returnA -< int64 $ truncate val
_ -> returnA -< error "iTruncFU: cannot apply operator to given argument." _ -> returnA -< error "iTruncFU: cannot apply operator to given argument."
iTruncFS eCont = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of iTruncFS = proc (bs1,bs2,x@(Value v)) -> do
let errorTrunc = printf "iTruncFS: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
case (bs1,bs2,v) of
(BS32, BS32, Wasm.VF32 val) -> (BS32, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^31 || val < -2^31 if isNaN val || isInfinite val || val >= 2^31 || val < -2^31
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 val) -> (BS32, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^31 || val < -2^31 if isNaN val || isInfinite val || val >= 2^31 || val < -2^31
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int32 $ truncate val else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 val) -> (BS64, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63 if isNaN val || isInfinite val || val >= 2^63 || val < -2^63
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int64 $ truncate val else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 val) -> (BS64, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^63 || val < -2^63 if isNaN val || isInfinite val || val >= 2^63 || val < -2^63
then eCont -< (bs1,bs2,Value v) then trap -< errorTrunc
else returnA -< int64 $ truncate val else returnA -< int64 $ truncate val
_ -> returnA -< error "iTruncFS: cannot apply operator to given argument." _ -> returnA -< error "iTruncFS: cannot apply operator to given argument."
i64ExtendSI32 = proc (Value v) -> case v of i64ExtendSI32 = proc (Value v) -> case v of
...@@ -304,7 +310,7 @@ instance Arrow c => IsErr Err (ValueT Value c) where ...@@ -304,7 +310,7 @@ instance Arrow c => IsErr Err (ValueT Value c) where
err = arr id err = arr id
type Result = (Error type Result = (Error
[Char] Err
(JoinVector Value, (JoinVector Value,
(Tables, (Tables,
(Memories, (Memories,
...@@ -317,18 +323,13 @@ invokeExported :: StaticGlobalState Value ...@@ -317,18 +323,13 @@ invokeExported :: StaticGlobalState Value
-> ModuleInstance -> ModuleInstance
-> Text -> Text
-> [Value] -> [Value]
-> Error -> Result
Err
(JoinVector Value,
(Tables,
(Memories,
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value])))))
invokeExported staticS mem tab modInst funcName args = invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in let ?fixpointAlgorithm = Function.fix in
Trans.run Trans.run
(Generic.invokeExported :: (Generic.invokeExported ::
ValueT Value ValueT Value
(ReaderT Generic.LabelArities (ReaderT Generic.JumpTypes
(StackT Value (StackT Value
(ExceptT (Generic.Exc Value) (ExceptT (Generic.Exc Value)
(StaticGlobalStateT Value (StaticGlobalStateT Value
...@@ -337,7 +338,7 @@ invokeExported staticS mem tab modInst funcName args = ...@@ -337,7 +338,7 @@ invokeExported staticS mem tab modInst funcName args =
(TableT (TableT
(FrameT FrameData Value (FrameT FrameData Value
(FailureT Err (FailureT Err
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],(Generic.LabelArities [],(funcName,args)))))))) (->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],(Generic.JumpTypes [],(funcName,args))))))))
instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables)) instantiateConcrete :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Memories, Tables))
......
...@@ -9,8 +9,7 @@ ...@@ -9,8 +9,7 @@
module Control.Arrow.Transformer.Abstract.Memory where module Control.Arrow.Transformer.Abstract.Memory where
import Abstract (BaseValue(..)) import Abstract (Size(..),Addr(..),Bytes(..))
import UnitAnalysisValue (Value(..),valueI32)
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
...@@ -37,28 +36,28 @@ import Data.Profunctor ...@@ -37,28 +36,28 @@ import Data.Profunctor
newtype MemoryT c x y = MemoryT (c x y) newtype MemoryT c x y = MemoryT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val, ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowReader r, ArrowStaticGlobalState val, ArrowStack st, ArrowReader r, ArrowStaticGlobalState val, ArrowSize v sz, ArrowMemAddress base off addr,
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v, ArrowJoin) ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v, ArrowJoin)
instance ArrowTrans MemoryT where instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y -- lift' :: c x y -> MemoryT v c x y
lift' = MemoryT lift' = MemoryT
instance (Profunctor c, ArrowChoice c) => ArrowMemory () () () (MemoryT c) where instance (Profunctor c, ArrowChoice c) => ArrowMemory Addr Bytes Size (MemoryT c) where
type Join y (MemoryT c) = ArrowComplete y (MemoryT c) type Join y (MemoryT c) = ArrowComplete y (MemoryT c)
memread sCont eCont = proc (_,(),_,x) -> (sCont -< ((),x)) <> (eCont -< x) memread sCont eCont = proc (_,Addr,_,x) -> (sCont -< (Bytes,x)) <> (eCont -< x)
memstore sCont eCont = proc (_,(),(),x) -> (sCont -< x) <> (eCont -< x) memstore sCont eCont = proc (_,Addr,Bytes,x) -> (sCont -< x) <> (eCont -< x)
memsize = arr $ const () memsize = arr $ const Size
memgrow sCont eCont = proc (_,(),x) -> (sCont -< ((),x)) <> (eCont -< x) memgrow sCont eCont = proc (_,Size,x) -> (sCont -< (Size,x)) <> (eCont -< x)
instance (ArrowChoice c, Profunctor c) => ArrowSize Value () (MemoryT c) where --instance (ArrowChoice c, Profunctor c) => ArrowSize Value () (MemoryT c) where
valToSize = proc (Value v) -> case v of -- valToSize = proc (Value v) -> case v of
(VI32 _) -> returnA -< () -- (VI32 _) -> returnA -< ()
_ -> returnA -< error "valToSize: arguments needs to be an i32 integer." -- _ -> returnA -< error "valToSize: arguments needs to be an i32 integer."
sizeToVal = proc () -> returnA -< valueI32 -- sizeToVal = proc () -> returnA -< valueI32
instance (Arrow c, Profunctor c) => ArrowMemAddress base off () (MemoryT c) where --instance (Arrow c, Profunctor c) => ArrowMemAddress base off Addr (MemoryT c) where
memaddr = arr $ const () -- memaddr = arr $ const Addr
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (MemoryT c) deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (MemoryT c)
......
...@@ -11,6 +11,7 @@ module Control.Arrow.Transformer.Abstract.Serialize where ...@@ -11,6 +11,7 @@ module Control.Arrow.Transformer.Abstract.Serialize where
import Abstract import Abstract
import Data import Data
import qualified TaintAnalysisValue as Taint
import UnitAnalysisValue import UnitAnalysisValue
import Control.Arrow import Control.Arrow
...@@ -19,6 +20,7 @@ import Control.Arrow.Except ...@@ -19,6 +20,7 @@ import Control.Arrow.Except
import Control.Arrow.Fail import Control.Arrow.Fail
import Control.Arrow.Fix import Control.Arrow.Fix
import Control.Arrow.Logger import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory import Control.Arrow.Memory
import Control.Arrow.Order import Control.Arrow.Order
import Control.Arrow.Reader import Control.Arrow.Reader
...@@ -34,30 +36,56 @@ import Control.Arrow.WasmFrame ...@@ -34,30 +36,56 @@ import Control.Arrow.WasmFrame
import Control.Category import Control.Category
import Data.Coerce (coerce)
import Data.Order import Data.Order
import Data.Profunctor import Data.Profunctor
import Language.Wasm.Structure (ValueType(..)) import Language.Wasm.Structure (ValueType(..))
newtype SerializeT c x y = SerializeT (c x y) newtype SerializeT v c x y = SerializeT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val, ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowLogger l, ArrowState s, ArrowStaticGlobalState v, ArrowReader m, ArrowTable v, ArrowStack st, ArrowLogger l, ArrowState s, ArrowStaticGlobalState v, ArrowReader m, ArrowTable v,
ArrowMemory addr bytes sz, ArrowSize v sz, ArrowJoin) ArrowMemory addr bytes sz, ArrowSize v sz, ArrowJoin, ArrowMemAddress base off addr)
instance ArrowTrans SerializeT where instance ArrowTrans (SerializeT v) where
lift' = SerializeT lift' = SerializeT
instance (Profunctor c, Arrow c) => ArrowSerialize Value () ValueType LoadType StoreType (SerializeT c) where instance (Profunctor c, Arrow c) => ArrowSerialize Value Bytes ValueType LoadType StoreType (SerializeT Value c) where
decode sCont = proc ((),_,valTy,x) -> sCont -< (toTopVal valTy, x) decode sCont = proc (Bytes,_,valTy,x) -> sCont -< (toTopVal valTy, x)
where where
toTopVal I32 = Value $ VI32 top toTopVal I32 = Value $ VI32 top
toTopVal I64 = Value $ VI64 top toTopVal I64 = Value $ VI64 top
toTopVal F32 = Value $ VF32 top toTopVal F32 = Value $ VF32 top
toTopVal F64 = Value $ VF64 top toTopVal F64 = Value $ VF64 top
encode sCont = proc (_,_,_,x) -> sCont -< ((),x) encode sCont = proc (_,_,_,x) -> sCont -< (Bytes,x)
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (SerializeT c)
instance (ArrowLift c, ArrowFix (Underlying (SerializeT c) x y)) => ArrowFix (SerializeT c x y) where tainted :: Arrow c => SerializeT v c x v -> SerializeT (Taint.Value v) c x (Taint.Value v)
type Fix (SerializeT c x y) = Fix (Underlying (SerializeT c) x y) tainted f = proc x -> do
v <- liftSerializeT f -< x
returnA -< Taint.Value Taint.Untainted v
{-# INLINE tainted #-}
liftSerializeT :: SerializeT v c x y -> SerializeT (Taint.Value v) c x y
liftSerializeT = coerce
{-# INLINE liftSerializeT #-}
unliftSerializeT :: SerializeT (Taint.Value v) c x y -> SerializeT v c x y
unliftSerializeT = coerce
{-# INLINE unliftSerializeT #-}
instance (Arrow c, ArrowSerialize v Bytes ValueType LoadType StoreType (SerializeT v c)) => ArrowSerialize (Taint.Value v) Bytes ValueType LoadType StoreType (SerializeT (Taint.Value v) c) where
decode sCont = proc (bytes,datDecTy,valTy,x) ->
liftSerializeT (decode
(proc (v,x) -> (unliftSerializeT sCont) -< (Taint.Value Taint.Tainted v,x)))
-< (bytes,datDecTy,valTy,x)
encode sCont = proc (Taint.Value _t v,valTy,datEncTy,x) ->
liftSerializeT (encode
(unliftSerializeT sCont))
-< (v,valTy,datEncTy,x)
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (SerializeT v c)
instance (ArrowLift c, ArrowFix (Underlying (SerializeT v c) x y)) => ArrowFix (SerializeT v c x y) where
type Fix (SerializeT v c x y) = Fix (Underlying (SerializeT v c) x y)
...@@ -11,7 +11,6 @@ module Control.Arrow.Transformer.Abstract.Table where ...@@ -11,7 +11,6 @@ module Control.Arrow.Transformer.Abstract.Table where
import Abstract import Abstract
import Data import Data
import UnitAnalysisValue
import Control.Arrow import Control.Arrow
import Control.Arrow.Const import Control.Arrow.Const
...@@ -39,18 +38,18 @@ import Data.Vector ((!), toList) ...@@ -39,18 +38,18 @@ import Data.Vector ((!), toList)
import qualified Language.Wasm.Interpreter as Wasm import qualified Language.Wasm.Interpreter as Wasm
newtype TableT c x y = TableT (ReaderT Tables c x y) newtype TableT v c x y = TableT (ReaderT Tables c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift, deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val, ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowState s, ArrowStaticGlobalState val, ArrowStack st, ArrowState s, ArrowStaticGlobalState val,
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowJoin) ArrowSerialize val dat valTy datDecTy datEncTy, ArrowJoin)
instance ArrowTrans TableT where instance ArrowTrans (TableT v) where
-- lift' :: c x y -> MemoryT v c x y -- lift' :: c x y -> MemoryT v c x y
lift' a = TableT (lift' a) lift' a = TableT (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowTable Value (TableT c) where instance (ArrowChoice c, Profunctor c) => ArrowTable v (TableT v c) where
type JoinTable y (TableT c) = ArrowComplete y c type JoinTable y (TableT v c) = ArrowComplete y c
readTable (TableT f) (TableT g) (TableT h) = TableT $ proc (ta,ix,x) -> do readTable (TableT f) (TableT g) (TableT h) = TableT $ proc (ta,ix,x) -> do
(JoinVector tabs) <- ask -< () (JoinVector tabs) <- ask -< ()
let (TableInst (Wasm.TableInstance _ tab)) = tabs ! ta let (TableInst (Wasm.TableInstance _ tab)) = tabs ! ta
...@@ -60,7 +59,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowTable Value (TableT c) where ...@@ -60,7 +59,7 @@ instance (ArrowChoice c, Profunctor c) => ArrowTable Value (TableT c) where
then (joinList1'' f -< (funcs,x)) <> (g -< (ta,ix,x)) <> (h -< (ta,ix,x)) then (joinList1'' f -< (funcs,x)) <> (g -< (ta,ix,x)) <> (h -< (ta,ix,x))
else (joinList1'' f -< (funcs,x)) <> (g -< (ta,ix,x)) else (joinList1'' f -< (funcs,x)) <> (g -< (ta,ix,x))
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (TableT c) deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (TableT v c)
instance (ArrowLift c, ArrowFix (Underlying (TableT c) x y)) => ArrowFix (TableT c x y) where instance (ArrowLift c, ArrowFix (Underlying (TableT v c) x y)) => ArrowFix (TableT v c x y) where
type Fix (TableT c x y) = Fix (Underlying (TableT c) x y) type Fix (TableT v c x y) = Fix (Underlying (TableT v c) x y)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.UnitMemAddress where
import Abstract (Addr(..))
import Control.Arrow
import Control.Arrow.Const