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

make traps into failure

parent 90b1017b
Pipeline #129820 failed with stages
in 75 minutes and 8 seconds
......@@ -51,7 +51,6 @@ import Language.Wasm.Structure hiding (exports, Const, Instruction, Fu
import Language.Wasm.Validate (ValidModule)
import Numeric.IEEE (copySign)
import Text.Printf (printf)
--trap :: IsException (Exc v) v c => c String x
--trap = throw <<< exception <<^ Trap
......@@ -72,67 +71,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 = proc (bs,op,x@(Value v1),y@(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 operatorError -< (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 operatorError -< (op,x,y)
else returnA -< int32 $ asWord32 (asInt32 val1 `quot` asInt32 val2)
(BS32, IRemU, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0
then operatorError -< (op,x,y)
else returnA -< int32 $ val1 `rem` val2
(BS32, IRemS, Wasm.VI32 val1, Wasm.VI32 val2) ->
if val2 == 0
then operatorError -< (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 operatorError -< (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 operatorError -< (op,x,y)
else returnA -< int64 $ asWord64 (asInt64 val1 `quot` asInt64 val2)
(BS64, IRemU, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then operatorError -< (op,x,y)
else returnA -< int64 $ val1 `rem` val2
(BS64, IRemS, Wasm.VI64 val1, Wasm.VI64 val2) ->
if val2 == 0
then operatorError -< (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
_ -> operatorError -< (op,x,y)
where
operatorError = proc (op,v1,v2) -> returnA -< error $ printf "Binary operator %s failed on %s" (show op) (show (v1,v2))
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."
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
......@@ -305,6 +300,9 @@ instance (ArrowExcept (Exc Value) c) => IsException (Exc Value) Value (ValueT Va
exception = arr id
handleException = id
instance Arrow c => IsErr Err (ValueT Value c) where
err = arr id
type Result = (Error
[Char]
(JoinVector Value,
......@@ -320,7 +318,7 @@ invokeExported :: StaticGlobalState Value
-> Text
-> [Value]
-> Error
[Char]
Err
(JoinVector Value,
(Tables,
(Memories,
......@@ -338,7 +336,7 @@ invokeExported staticS mem tab modInst funcName args =
(SerializeT
(TableT
(FrameT FrameData Value
(FailureT String
(FailureT Err
(->)))))))))) (Text, [Value]) [Value]) (JoinVector Vec.empty,((0,modInst),(tab,(mem,(staticS,([],(Generic.LabelArities [],(funcName,args))))))))
......
......@@ -40,7 +40,6 @@ import Control.Arrow.WasmFrame
import Data.Hashable
import Data.Profunctor
import Data.String
import Data.Text.Lazy (Text)
import Data.Text.Prettyprint.Doc
import Data.Vector hiding (length, (++))
......@@ -58,22 +57,26 @@ import GHC.Generics
import GHC.Exts
-- the kind of exceptions that can be thrown
data Exc v = Trap String | Jump Natural [v] | CallReturn [v] deriving (Show, Eq, Generic)
data Exc v = Jump Natural [v] | CallReturn [v] deriving (Show, Eq, Generic)
data Err = Trap String | InvocationError String deriving (Show, Eq, Generic)
instance Hashable v => Hashable (Exc v)
instance Hashable Err
class ArrowExcept exc c => IsException exc v c | c -> v where
type family JoinExc y (c :: * -> * -> *) :: Constraint
exception :: c (Exc v) exc
handleException :: JoinExc y c => c (Exc v, x) y -> c (exc,x) y
--instance (Eq v) => Complete (Exc v) where
-- x ⊔ y | x == y = x
-- | otherwise = Top
--
--instance (Eq v) => PreOrd (Exc v) where
-- _ ⊑ Top = True
-- x ⊑ y | x == y = True
class IsErr err c | c -> err where
err :: c Err err
trap :: (Fail.Join x c, ArrowFail err c, IsErr err c) => c String x
trap = proc s -> fail <<< err -< (Trap s)
invocationError :: (Fail.Join x c, ArrowFail err c, IsErr err c) => c String x
invocationError = proc s -> fail <<< err -< (InvocationError s)
-- used for storing the return "arity" of nested labels
newtype LabelArities = LabelArities {labels :: [Natural]} deriving (Eq,Show,Generic)
......@@ -114,7 +117,7 @@ type ArrowDynamicComponents v addr bytes sz exc e c =
ArrowWasmMemory addr bytes sz v c,
IsVal v c,
ArrowExcept exc c, IsException exc v c,
ArrowFail e c, IsString e,
ArrowFail e c, IsErr e c,
ArrowFix (c [Instruction Natural] ()),
?fixpointAlgorithm :: FixpointAlgorithm (Fix (c [Instruction Natural] ())))
......@@ -127,7 +130,7 @@ class Show v => IsVal v c | c -> v where
f32const :: c Float v
f64const :: c Double v
iUnOp :: c (BitSize, IUnOp, v) v
iBinOp :: JoinVal v c => c (BitSize, IBinOp, v, v) v
iBinOp :: (JoinVal v c) => c (IBinOp, v, v, x) y -> c (v, x) y -> c (BitSize, IBinOp, v, v, x) y
i32eqz :: c v v
i64eqz :: c v v
iRelOp :: c (BitSize, IRelOp, v, v) v
......@@ -166,6 +169,7 @@ invokeExported ::
JoinVal () c, JoinVal v c, Show v,
Fail.Join [v] c,
Fail.Join () c,
Fail.Join v c,
JoinTable () c)
=> c (Text, [v]) [v]
invokeExported = proc (funcName, args) -> do
......@@ -174,7 +178,7 @@ invokeExported = proc (funcName, args) -> do
case find (\(ExportInstance n _) -> n == funcName) (exports modInst) of
-- if found -> invoke
Just (ExportInstance _ (ExternFunction addr)) -> invokeExternal -< (addr, args)
_ -> fail -< fromString $ printf "Function with name %s was not found in module's exports" (show funcName)
_ -> invocationError -< printf "Function with name %s was not found in module's exports" (show funcName)
invokeExternal ::
( ArrowChoice c,
......@@ -184,6 +188,7 @@ invokeExternal ::
JoinVal () c, JoinVal v c, Show v,
Exc.Join () c,
Fail.Join () c,
Fail.Join v c,
JoinTable () c)
=> c (Int, [v]) [v]
invokeExternal = proc (funcAddr, args) ->
......@@ -209,13 +214,13 @@ invokeExternal = proc (funcAddr, args) ->
-- execute f if arguments match paramTys
withCheckedType f = proc (paramTys, args, x) -> do
if length paramTys /= length args
then fail -< fromString $ printf "Wrong number of arguments in external invocation. Expected %d but got %d" (length paramTys) (length args)
then invocationError -< printf "Wrong number of arguments in external invocation. Expected %d but got %d" (length paramTys) (length args)
else returnA -< ()
Arr.zipWith
(proc (arg, ty) ->
ifHasType
(arr $ const ())
(proc (arg, ty) -> fail -< fromString $ printf "Wrong argument type in external invocation. Expected %s but got %s" (show ty) (show arg))
(proc (arg, ty) -> invocationError -< printf "Wrong argument type in external invocation. Expected %s but got %s" (show ty) (show arg))
-< (arg, ty, (arg, ty)))
-< (args, paramTys)
f -< x
......@@ -224,11 +229,13 @@ invokeExternal = proc (funcAddr, args) ->
eval ::
( ArrowChoice c,
ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
Fail.Join () c,
JoinExc () c,
Mem.Join () c,
JoinVal () c, JoinVal v c, Show v,
Exc.Join () c,
JoinTable () c)
JoinTable () c,
Fail.Join v c)
=> c [Instruction Natural] ()
eval = fix $ \eval' -> proc is -> do
--stack <- getStack -< ()
......@@ -269,13 +276,14 @@ evalControlInst ::
( ArrowChoice c, Profunctor c,
ArrowStaticComponents v c,
ArrowDynamicComponents v addr bytes sz exc e c,
Fail.Join () c,
JoinVal () c,
JoinExc () c,
Exc.Join () c,
JoinTable () c)
=> c [Instruction Natural] () -> c (Instruction Natural) ()
evalControlInst eval' = proc i -> case i of
Unreachable _ -> throw <<< exception -< Trap "Execution of unreachable instruction"
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])
......@@ -320,15 +328,16 @@ evalControlInst eval' = proc i -> case i of
funcAddr <- pop -< ()
readTable
(invokeChecked eval')
(proc (ta,ix,_) -> throw <<< exception -< Trap $ printf "Index %s out of bounds for table address %s" (show ix) (show ta))
(proc (ta,ix,_) -> throw <<< exception -< Trap $ printf "Index %s uninitialized for table address %s" (show ix) (show ta))
(proc (ta,ix,_) -> trap -< printf "Index %s out of bounds for table address %s" (show ix) (show ta))
(proc (ta,ix,_) -> trap -< printf "Index %s uninitialized for table address %s" (show ix) (show ta))
-< (tableAddr, funcAddr, ftExpect)
invokeChecked ::
( ArrowChoice c,
ArrowStaticComponents v c,
--ArrowGlobalState v m c,
IsVal v c, ArrowExcept exc c, IsException exc v c, JoinExc () c, Exc.Join () c)
IsVal v c, ArrowExcept exc c, IsException exc v c, JoinExc () c, Exc.Join () c, Fail.Join () c,
ArrowFail err c, IsErr err c)
=> c [Instruction Natural] () -> c (Int, FuncType) ()
invokeChecked eval' = proc (addr, ftExpect) ->
readFunction
......@@ -341,7 +350,7 @@ invokeChecked eval' = proc (addr, ftExpect) ->
withCheckedType f = proc (ftActual, ftExpect, x) ->
if ftActual == ftExpect
then f -< x
else throw <<< exception -< Trap $ printf "Mismatched function type in indirect call. Expected %s, actual %s." (show ftExpect) (show ftActual)
else trap -< printf "Mismatched function type in indirect call. Expected %s, actual %s." (show ftExpect) (show ftActual)
-- invoke function with code code within module instance funcModInst
-- the function execution can finish by different reasons:
......@@ -374,7 +383,7 @@ invoke eval' = catch
CallReturn vs -> do
pushn -< vs
eval' -< []
Trap _ -> throw <<< exception -< exc
--Trap _ -> throw <<< exception -< exc
Jump _ _ -> returnA -< error "invalid module: tried to jump through a function boundary")
-< (e,()))
where
......@@ -458,7 +467,7 @@ evalParametricInst = proc i -> case i of
evalMemoryInst ::
( ArrowChoice c,
ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
Mem.Join () c)
Mem.Join () c, Fail.Join () c)
=> c (Instruction Natural) ()
evalMemoryInst = proc i -> case i of --withCurrentMemory $ proc (m,i) -> case i of
I32Load (MemArg off _) _ -> load 4 L_I32 I32 -< off
......@@ -507,7 +516,7 @@ memoryIndex = proc () -> do
load ::
( ArrowChoice c,
ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
Mem.Join () c)
Mem.Join () c, Fail.Join () c)
=> Int -> LoadType -> ValueType -> c Natural ()
load byteSize loadType valType = proc off -> do
base <- pop -< ()
......@@ -518,13 +527,13 @@ load byteSize loadType valType = proc off -> do
decode
(push <<^ fst)
-< (bytes, loadType, valType, ()))
(proc addr -> throw <<< exception -< Trap $ printf "Memory access out of bounds: Cannot read %d bytes at address %s in current memory" byteSize (show addr))
(proc addr -> trap -< printf "Memory access out of bounds: Cannot read %d bytes at address %s in current memory" byteSize (show addr))
-< (memIndex, addr, byteSize, addr)
store ::
( ArrowChoice c,
ArrowStaticComponents v c, ArrowDynamicComponents v addr bytes sz exc e c,
Mem.Join () c)
Mem.Join () c, Fail.Join () c)
=> StoreType -> ValueType -> c Natural ()
store storeType valType = proc off -> do
v <- pop -< ()
......@@ -535,7 +544,7 @@ store storeType valType = proc off -> do
memIndex <- memoryIndex -< ()
memstore
(arr $ const ())
(proc (addr,bytes) -> throw <<< exception -< Trap $ printf "Memory access out of bounds: Cannot write %s at address %s in current memory" (show bytes) (show addr))
(proc (addr,bytes) -> trap -< printf "Memory access out of bounds: Cannot write %s at address %s in current memory" (show bytes) (show addr))
-< (memIndex, addr, bytes, (addr, bytes)))
-< (v, valType, storeType, off)
......@@ -562,7 +571,8 @@ evalVariableInst = proc i -> case i of
evalNumericInst ::
( ArrowChoice c, ArrowStack v c, ArrowExcept exc c, IsException exc v c, IsVal v c, Show v, JoinVal v c)
( ArrowChoice c, ArrowStack v c, ArrowExcept exc c, IsException exc v c, IsVal v c, Show v, JoinVal v c,
Fail.Join v c, IsErr err c, ArrowFail err c)
=> c (Instruction Natural) v
evalNumericInst = proc i -> case i of
I32Const lit _ -> i32const -< lit
......@@ -575,8 +585,9 @@ evalNumericInst = proc i -> case i of
IBinOp bs op _ -> do
(v1,v2) <- pop2 -< ()
iBinOp
-- (proc (op,v1,v2) -> throw <<< exception -< Trap $ printf "Binary operator %s failed on %s" (show op) (show (v1,v2)))
-< (bs, op, v1, v2)
(proc (op,v1,v2,_) -> trap -< printf "Binary operator %s failed on %s" (show op) (show (v1,v2)))
(proc (v,_) -> returnA -< v)
-< (bs, op, v1, v2, ())
I32Eqz _ -> do
v <- pop -< ()
i32eqz -< v
......@@ -601,12 +612,12 @@ evalNumericInst = proc i -> case i of
ITruncFU bs1 bs2 _ -> do
v <- pop -< ()
iTruncFU
(proc (bs1,bs2,v) -> throw <<< exception -< Trap $ printf "Truncation operator from %s to %s failed on %s" (show bs1) (show bs2) (show v))
(proc (bs1,bs2,v) -> trap -< printf "Truncation operator from %s to %s failed on %s" (show bs1) (show bs2) (show v))
-< (bs1,bs2,v)
ITruncFS bs1 bs2 _ -> do
v <- pop -< ()
iTruncFS
(proc (bs1,bs2,v) -> throw <<< exception -< Trap $ printf "Truncation operator from %s to %s failed on %s" (show bs1) (show bs2) (show v))
(proc (bs1,bs2,v) -> trap -< printf "Truncation operator from %s to %s failed on %s" (show bs1) (show bs2) (show v))
-< (bs1,bs2,v)
I64ExtendSI32 _ -> do
v <- pop -< ()
......
......@@ -14,8 +14,10 @@ module TaintAnalysis where
import Abstract
import Data(joinList1'')
import GenericInterpreter
import qualified UnitAnalysis as Abs
import Control.Arrow
import Control.Arrow.Except
import Control.Arrow.Order
import Control.Arrow.Transformer.Value
......@@ -24,6 +26,7 @@ import Language.Wasm.Structure (BitSize(..), IBinOp(..), IRelOp(..), V
FUnOp(..), FBinOp(..), FRelOp(..))
import Data.Hashable
import Data.HashSet as HashSet
import Data.Order
import Data.Text.Prettyprint.Doc as Pretty
import GHC.Generics
......@@ -65,10 +68,29 @@ liftValueT :: ValueT v c x y -> ValueT (Value v) c x y
liftValueT = coerce
{-# INLINE liftValueT #-}
unliftValueT :: ValueT (Value v) c x y -> ValueT v c x y
unliftValueT = coerce
{-# INLINE unliftValueT #-}
liftValueT1 :: (ValueT v c x y -> ValueT v c x' y') -> (ValueT (Value v) c x y -> ValueT (Value v) c x' y')
liftValueT1 = coerce
{-# INLINE liftValueT1 #-}
--instance (ArrowExcept (Exc Value) c, ArrowChoice c) => IsException (Exc Value) (Value v) (ValueT (Value v) c) where
-- exception = proc (Exc (Value v)) ->
-- liftValueT exception -< (Exc v)
instance (Hashable v, ArrowExcept (Abs.Exc (Value v)) c, ArrowChoice c) => IsException (Abs.Exc (Value v)) (Value v) (ValueT (Value v) c) where
type JoinExc y (ValueT (Value v) c) = ArrowComplete y (ValueT (Value v) c)
exception = arr $ Abs.Exc . HashSet.singleton
handleException f = proc (Abs.Exc excs,x) ->
joinList1'' f -< (HashSet.toList excs,x)
--instance (ArrowExcept (Exc (Value v)) c) => IsException (Exc (Value v)) (Value v) (ValueT (Value v) c) where
-- type JoinExc y (ValueT (Value v) c) = ()
-- exception = arr id
-- handleException = id
instance (JoinVal v (ValueT v c), IsVal v (ValueT v c), ArrowChoice c) => IsVal (Value v) (ValueT (Value v) c) where
type JoinVal y (ValueT (Value v) c) = JoinVal y (ValueT v c)
......@@ -81,9 +103,11 @@ instance (JoinVal v (ValueT v c), IsVal v (ValueT v c), ArrowChoice c) => IsVal
v' <- liftValueT iUnOp -< (bs,op,v)
returnA -< Value t v'
iBinOp = proc (bs,op,Value t1 v1, Value t2 v2) -> do
v <- liftValueT iBinOp -< (bs,op,v1,v2)
returnA -< Value (t1 t2) v
iBinOp eCont sCont = proc (bs,op,Value t1 v1, Value t2 v2,x) ->
liftValueT (iBinOp
(proc (op,v1,v2,(t1,t2,_,x)) -> (unliftValueT eCont) -< (op,Value t1 v1,Value t2 v2,x))
(proc (v,(_,_,t,x)) -> (unliftValueT sCont) -< (Value t v,x)))
-< (bs,op,v1,v2,(t1,t2,t1 t2,x))
iRelOp = proc (bs,op,Value t1 v1, Value t2 v2) -> do
v <- liftValueT iRelOp -< (bs,op,v1,v2)
......@@ -97,13 +121,17 @@ instance (JoinVal v (ValueT v c), IsVal v (ValueT v c), ArrowChoice c) => IsVal
v' <- liftValueT i64eqz -< v
returnA -< Value t v'
-- ifHasType f g = proc (Value v,t,x) -> do
-- case (v,t) of
-- (VI32 _, I32) -> f -< x
-- (VI64 _, I64) -> f -< x
-- (VF32 _, F32) -> f -< x
-- (VF64 _, F64) -> f -< x
-- _ -> g -< x
i32ifNeqz f g = proc (Value _t v, x) ->
liftValueT (i32ifNeqz
(unliftValueT f)
(unliftValueT g))
-< (v, x)
ifHasType f g = proc (Value _t v,valTy,x) -> do
liftValueT (ifHasType
(unliftValueT f)
(unliftValueT g))
-< (v,valTy,x)
-- fUnOp = proc (bs,op,Value v) -> case (bs,op,v) of
-- (BS32, FAbs, VF32 _) -> returnA -< valueF32
......
......@@ -16,7 +16,7 @@ module UnitAnalysis where
import Abstract
import Data
import GenericInterpreter hiding (Exc)
import GenericInterpreter hiding (Exc,Err)
import qualified GenericInterpreter as Generic
import UnitAnalysisValue
......@@ -51,7 +51,7 @@ import Data.Abstract.Terminating
import Data.Hashable
import Data.HashSet as HashSet
import Data.Order
import Data.Abstract.DiscretePowerset
import Data.Abstract.DiscretePowerset as Pow
import Data.Abstract.Error as Error
import Data.Abstract.Except
import qualified Data.Abstract.Widening as W
......@@ -61,14 +61,14 @@ import qualified Data.Vector as Vec
import Language.Wasm.Interpreter (ModuleInstance)
import qualified Language.Wasm.Interpreter as Wasm
--import Language.Wasm.Structure hiding (exports, Const)
import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
--import Control.Arrow.Except (ArrowExcept)
newtype Exc v = Exc (HashSet (Generic.Exc v)) deriving (Eq, Show, Hashable, PreOrd, Complete)
newtype Err = Err (Pow Generic.Err) deriving (Eq, Show, Hashable, PreOrd, Complete)
instance (Show v) => Pretty (Exc v) where pretty = viaShow
instance (Show n) => Pretty (Instruction n) where pretty = viaShow
......@@ -88,13 +88,6 @@ mapList f = proc (as,x) -> do
b <- f -< (a,x)
returnA -< b:bs
--joinList1'' f = proc (acc,bs) -> do
-- case bs of
-- [] -> returnA -< acc
-- (b:bss) -> do
-- newA <- f -< (acc,b)
-- joinList f -< (newA,bss)
tailA :: (ArrowChoice c) => c () [a] -> c () [a]
tailA f = proc () -> do
aList <- f -< ()
......@@ -111,6 +104,9 @@ instance (ArrowExcept (Exc Value) c, ArrowChoice c) => IsException (Exc Value) V
--joinList _j -< (_init,ys)
joinList1'' f -< (HashSet.toList excs,x)
instance Arrow c => IsErr Err (ValueT Value c) where
err = arr $ Err . Pow.singleton
type In = (JoinVector Value,
((Natural, ModuleInstance),
(Tables,
......@@ -119,7 +115,7 @@ type In = (JoinVector Value,
type Out = Terminating
(Error
(Pow String)
Err
(JoinVector Value,
--(Tables,
(StaticGlobalState Value,
......@@ -128,7 +124,7 @@ type Out = Terminating
type Result = (CFG (Instruction Natural), Terminating
(Error
(Pow String)
Err
(JoinVector Value,
--(Tables,
(StaticGlobalState Value,
......@@ -157,8 +153,7 @@ invokeExported initialStore tab modInst funcName args =
(SerializeT
(TableT
(FrameT FrameData Value
(ErrorT (Pow String)
--(LoggerT String
(ErrorT Err
(TerminatingT
(FixT
(ComponentT Component In
......
......@@ -23,7 +23,6 @@ import Language.Wasm.Structure (BitSize(..), IBinOp(..), IRelOp(..), V
import Data.Hashable
import Data.Order
import Data.Text.Prettyprint.Doc as Pretty
import Text.Printf (printf)
newtype Value = Value (BaseValue () () () ()) deriving (Eq, Show, Hashable, PreOrd, Complete, Pretty)
......@@ -49,42 +48,39 @@ instance ArrowChoice c => IsVal Value (ValueT Value c) where