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
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 {
-- funcInstances :: Vector FuncInst,
-- tableInstances :: Vector TableInst,
......
......@@ -21,6 +21,7 @@ import qualified GenericInterpreter as Generic
import Control.Arrow
import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Except
import Control.Arrow.Fail as Fail
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.StaticGlobalState
......@@ -51,11 +52,12 @@ import Language.Wasm.Structure hiding (exports, Const, Instruction, Fu
import Language.Wasm.Validate (ValidModule)
import Numeric.IEEE (copySign)
import Text.Printf
--trap :: IsException (Exc v) v c => c String x
--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) = ()
i32const = proc w32 -> returnA -< int32 w32
......@@ -71,63 +73,63 @@ instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
(BS64, ICtz, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ countTrailingZeros v
(BS64, IPopcnt, Wasm.VI64 v) -> returnA -< int64 $ fromIntegral $ popCount v
_ -> 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
(BS32, IAdd, Wasm.VI32 val1, Wasm.VI32 val2) -> sCont -< (int32 $ val1 + val2,z)
-- (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, IDivU, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int32 $ val1 `quot` val2
-- (BS32, IDivS, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0 || (val1 == 0x80000000 && val2 == 0xFFFFFFFF)
-- then eCont -< (op,x,y)
-- else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2)
-- (BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int32 $ val1 `rem` val2
-- (BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int32 $ asWord32 (asInt32 val1 `rem` asInt32 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, 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, 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, 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
--
-- (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, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2
-- (BS64, IDivU, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int64 $ val1 `quot` val2
-- (BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF)
-- then eCont -< (op,x,y)
-- else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
-- (BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int64 $ val1 `rem` val2
-- (BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
-- if val2 == 0
-- then eCont -< (op,x,y)
-- else returnA -< int64 $ asWord64 (asInt64 val1 `rem` asInt64 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, 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, 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, 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
-- _ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments."
iBinOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
(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, IMul, Wasm.VI32 val1, Wasm.VI32 val2) -> returnA -< int32 $ val1 * val2
(BS32, IDivU, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int32 $ val1 `quot` val2
(BS32, IDivS, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0 || (val1 == 0x80000000 && val2 == 0xFFFFFFFF)
then trap -< "iBinOp: division by zero."
else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2)
(BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int32 $ val1 `rem` val2
(BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int32 $ asWord32 (asInt32 val1 `rem` asInt32 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, 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, 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, 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
(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, IMul, Wasm.VI64 val1, Wasm.VI64 val2) -> returnA -< int64 $ val1 * val2
(BS64, IDivU, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int64 $ val1 `quot` val2
(BS64, IDivS, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0 || (val1 == 0x8000000000000000 && val2 == 0xFFFFFFFFFFFFFFFF)
then trap -< "iBinOp: division by zero."
else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
(BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int64 $ val1 `rem` val2
(BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then trap -< "iBinOp: division by zero."
else returnA -< int64 $ asWord64 (asInt64 val1 `rem` asInt64 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, 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, 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, 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
_ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments."
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, 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
i32WrapI64 = proc (Value v) -> case v of
(Wasm.VI64 val) -> returnA -< int32 $ fromIntegral $ val .&. 0xFFFFFFFF
_ -> 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) ->
if isNaN val || isInfinite val || val >= 2^32 || val <= -1
then eCont -< (bs1,bs2,Value v)
then trap -< errorTrunc
else returnA -< int32 $ truncate val
(BS32, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^32 || val <= -1
then eCont -< (bs1,bs2,Value v)
then trap -< errorTrunc
else returnA -< int32 $ truncate val
(BS64, BS32, Wasm.VF32 val) ->
if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then eCont -< (bs1,bs2,Value v)
then trap -< errorTrunc
else returnA -< int64 $ truncate val
(BS64, BS64, Wasm.VF64 val) ->
if isNaN val || isInfinite val || val >= 2^64 || val <= -1
then eCont -< (bs1,bs2,Value v)
then trap -< errorTrunc
else returnA -< int64 $ truncate val
_ -> 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) ->
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
(BS32, BS64, Wasm.VF64 val) ->
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
(BS64, BS32, Wasm.VF32 val) ->
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
(BS64, BS64, Wasm.VF64 val) ->
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
_ -> returnA -< error "iTruncFS: cannot apply operator to given argument."
i64ExtendSI32 = proc (Value v) -> case v of
......@@ -304,7 +310,7 @@ instance Arrow c => IsErr Err (ValueT Value c) where
err = arr id
type Result = (Error
[Char]
Err
(JoinVector Value,
(Tables,
(Memories,
......@@ -317,18 +323,13 @@ invokeExported :: StaticGlobalState Value
-> ModuleInstance
-> Text
-> [Value]
-> Error
Err
(JoinVector Value,
(Tables,
(Memories,
(StaticGlobalState Value, Error (Exc Value) (JoinList Value, [Value])))))
-> Result
invokeExported staticS mem tab modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
(Generic.invokeExported ::
ValueT Value
(ReaderT Generic.LabelArities
(ReaderT Generic.JumpTypes
(StackT Value
(ExceptT (Generic.Exc Value)
(StaticGlobalStateT Value
......@@ -337,7 +338,7 @@ invokeExported staticS mem tab modInst funcName args =
(TableT
(FrameT FrameData Value
(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))
......
......@@ -9,8 +9,7 @@
module Control.Arrow.Transformer.Abstract.Memory where
import Abstract (BaseValue(..))
import UnitAnalysisValue (Value(..),valueI32)
import Abstract (Size(..),Addr(..),Bytes(..))
import Control.Arrow
import Control.Arrow.Const
......@@ -37,28 +36,28 @@ import Data.Profunctor
newtype MemoryT c x y = MemoryT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
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)
instance ArrowTrans MemoryT where
-- lift' :: c x y -> MemoryT v c x y
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)
memread sCont eCont = proc (_,(),_,x) -> (sCont -< ((),x)) <> (eCont -< x)
memstore sCont eCont = proc (_,(),(),x) -> (sCont -< x) <> (eCont -< x)
memsize = arr $ const ()
memgrow sCont eCont = proc (_,(),x) -> (sCont -< ((),x)) <> (eCont -< x)
memread sCont eCont = proc (_,Addr,_,x) -> (sCont -< (Bytes,x)) <> (eCont -< x)
memstore sCont eCont = proc (_,Addr,Bytes,x) -> (sCont -< x) <> (eCont -< x)
memsize = arr $ const Size
memgrow sCont eCont = proc (_,Size,x) -> (sCont -< (Size,x)) <> (eCont -< x)
instance (ArrowChoice c, Profunctor c) => ArrowSize Value () (MemoryT c) where
valToSize = proc (Value v) -> case v of
(VI32 _) -> returnA -< ()
_ -> returnA -< error "valToSize: arguments needs to be an i32 integer."
sizeToVal = proc () -> returnA -< valueI32
--instance (ArrowChoice c, Profunctor c) => ArrowSize Value () (MemoryT c) where
-- valToSize = proc (Value v) -> case v of
-- (VI32 _) -> returnA -< ()
-- _ -> returnA -< error "valToSize: arguments needs to be an i32 integer."
-- sizeToVal = proc () -> returnA -< valueI32
instance (Arrow c, Profunctor c) => ArrowMemAddress base off () (MemoryT c) where
memaddr = arr $ const ()
--instance (Arrow c, Profunctor c) => ArrowMemAddress base off Addr (MemoryT c) where
-- memaddr = arr $ const Addr
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (MemoryT c)
......
......@@ -11,6 +11,7 @@ module Control.Arrow.Transformer.Abstract.Serialize where
import Abstract
import Data
import qualified TaintAnalysisValue as Taint
import UnitAnalysisValue
import Control.Arrow
......@@ -19,6 +20,7 @@ import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Logger
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.Order
import Control.Arrow.Reader
......@@ -34,30 +36,56 @@ import Control.Arrow.WasmFrame
import Control.Category
import Data.Coerce (coerce)
import Data.Order
import Data.Profunctor
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,
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,
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
instance (Profunctor c, Arrow c) => ArrowSerialize Value () ValueType LoadType StoreType (SerializeT c) where
decode sCont = proc ((),_,valTy,x) -> sCont -< (toTopVal valTy, x)
instance (Profunctor c, Arrow c) => ArrowSerialize Value Bytes ValueType LoadType StoreType (SerializeT Value c) where
decode sCont = proc (Bytes,_,valTy,x) -> sCont -< (toTopVal valTy, x)
where
toTopVal I32 = Value $ VI32 top
toTopVal I64 = Value $ VI64 top
toTopVal F32 = Value $ VF32 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
type Fix (SerializeT c x y) = Fix (Underlying (SerializeT c) x y)
tainted :: Arrow c => SerializeT v c x v -> SerializeT (Taint.Value v) c x (Taint.Value v)
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
import Abstract
import Data
import UnitAnalysisValue
import Control.Arrow
import Control.Arrow.Const
......@@ -39,18 +38,18 @@ import Data.Vector ((!), toList)
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,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowState s, ArrowStaticGlobalState val,
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' a = TableT (lift' a)
instance (ArrowChoice c, Profunctor c) => ArrowTable Value (TableT c) where
type JoinTable y (TableT c) = ArrowComplete y c
instance (ArrowChoice c, Profunctor c) => ArrowTable v (TableT v c) where
type JoinTable y (TableT v c) = ArrowComplete y c
readTable (TableT f) (TableT g) (TableT h) = TableT $ proc (ta,ix,x) -> do
(JoinVector tabs) <- ask -< ()
let (TableInst (Wasm.TableInstance _ tab)) = tabs ! ta
......@@ -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))
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
type Fix (TableT c x y) = Fix (Underlying (TableT c) x y)
instance (ArrowLift c, ArrowFix (Underlying (TableT v c) x y)) => ArrowFix (TableT v c x y) where
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
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.StaticGlobalState
import Control.Arrow.Store
import Control.Arrow.Table
import Control.Arrow.Trans
import Control.Arrow.WasmFrame
import Control.Category
import Data.Profunctor
newtype MemAddressT c x y = MemAddressT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowReader r, ArrowStaticGlobalState val, ArrowSize v sz,
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v, ArrowJoin)
instance ArrowTrans MemAddressT where
-- lift' :: c x y -> MemoryT v c x y
lift' = MemAddressT
instance (Arrow c, Profunctor c) => ArrowMemAddress base off Addr (MemAddressT c) where
memaddr = arr $ const Addr
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (MemAddressT c)
instance (ArrowLift c, ArrowFix (Underlying (MemAddressT c) x y)) => ArrowFix (MemAddressT c x y) where
type Fix (MemAddressT c x y) = Fix (Underlying (MemAddressT c) x y)
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.UnitSize where
import Abstract (BaseValue(..),Size(..))
import UnitAnalysisValue (Value(..),valueI32)
import qualified TaintAnalysisValue as Taint
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.Order
import Control.Arrow.Reader
import Control.Arrow.Serialize
import Control.Arrow.Size
import Control.Arrow.Stack
import Control.Arrow.StaticGlobalState
import Control.Arrow.Store
import Control.Arrow.Table
import Control.Arrow.Trans
import Control.Arrow.WasmFrame
import Control.Category
import Data.Coerce (coerce)
import Data.Profunctor
newtype SizeT v c x y = SizeT (c x y)
deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
ArrowStack st, ArrowReader r, ArrowStaticGlobalState val, ArrowMemory addr bytes s,
ArrowMemAddress base off addr,
ArrowSerialize val dat valTy datDecTy datEncTy, ArrowTable v, ArrowJoin)
instance ArrowTrans (SizeT v) where
-- lift' :: c x y -> MemoryT v c x y
lift' = SizeT
instance (ArrowChoice c, Profunctor c) => ArrowSize Value Size (SizeT Value c) where
valToSize = proc (Value v) -> case v of
(VI32 _) -> returnA -< Size
_ -> returnA -< error "valToSize: argument needs to be an i32 integer."
sizeToVal = proc Size -> returnA -< valueI32
untainted :: Arrow c => SizeT v c x v -> SizeT (Taint.Value v) c x (Taint.Value v)
untainted f = proc x -> do
v <- liftSizeT f -< x
returnA -< Taint.Value Taint.Untainted v
{-# INLINE untainted #-}
liftSizeT :: SizeT v c x y -> SizeT (Taint.Value v) c x y
liftSizeT = coerce
{-# INLINE liftSizeT #-}
instance (Arrow c, ArrowSize v Size (SizeT v c)) => ArrowSize (Taint.Value v) Size (SizeT (Taint.Value v) c) where
valToSize = proc (Taint.Value _t v) -> do
liftSizeT valToSize -< v
sizeToVal = proc Size ->
untainted sizeToVal -< Size
deriving instance (Arrow c, Profunctor c, ArrowComplete y c) => ArrowComplete y (SizeT v c)
instance (ArrowLift c, ArrowFix (Underlying (SizeT v c) x y)) => ArrowFix (SizeT v c x y) where
type Fix (SizeT v c x y) = Fix (Underlying (SizeT v c) x y)