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

Compute CFG in UnitAnalysis

parent 8a0672c2
Pipeline #118997 passed with stages
in 75 minutes and 51 seconds
......@@ -202,6 +202,75 @@ data Instruction index =
| FReinterpretI BitSize Label
deriving (Show, Eq, Generic)
instance HasLabel (Instruction i) where
label e = case e of
Unreachable l -> l
Nop l -> l
Block _ _ l -> l
Loop _ _ l -> l
If _ _ _ l -> l
Br _ l -> l
BrIf _ l -> l
BrTable _ _ l -> l
Return l -> l
Call _ l -> l
CallIndirect _ l -> l
Drop l -> l
Select l -> l
GetLocal _ l -> l
SetLocal _ l -> l
TeeLocal _ l -> l
GetGlobal _ l -> l
SetGlobal _ l -> l
I32Load _ l -> l
I64Load _ l -> l
F32Load _ l -> l
F64Load _ l -> l
I32Load8S _ l -> l
I32Load8U _ l -> l
I32Load16S _ l -> l
I32Load16U _ l -> l
I64Load8S _ l -> l
I64Load8U _ l -> l
I64Load16S _ l -> l
I64Load16U _ l -> l
I64Load32S _ l -> l
I64Load32U _ l -> l
I32Store _ l -> l
I64Store _ l -> l
F32Store _ l -> l
F64Store _ l -> l
I32Store8 _ l -> l
I32Store16 _ l -> l
I64Store8 _ l -> l
I64Store16 _ l -> l
I64Store32 _ l -> l
CurrentMemory l -> l
GrowMemory l -> l
I32Const _ l -> l
I64Const _ l -> l
F32Const _ l -> l
F64Const _ l -> l
IUnOp _ _ l -> l
IBinOp _ _ l -> l
I32Eqz l -> l
I64Eqz l -> l
IRelOp _ _ l -> l
FUnOp _ _ l -> l
FBinOp _ _ l -> l
FRelOp _ _ l -> l
I32WrapI64 l -> l
ITruncFU _ _ l -> l
ITruncFS _ _ l -> l
I64ExtendSI32 l -> l
I64ExtendUI32 l -> l
FConvertIU _ _ l -> l
FConvertIS _ _ l -> l
F32DemoteF64 l -> l
F64PromoteF32 l -> l
IReinterpretF _ l -> l
FReinterpretI _ l -> l
type LInstruction = State Label (Instruction Natural)
unreachable :: LInstruction
......
......@@ -28,6 +28,7 @@ import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix as Fix
import Control.Arrow.Fix.Chaotic (innermost)
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.MemAddress
import Control.Arrow.Memory
import Control.Arrow.MemSizable
......@@ -46,6 +47,7 @@ import Control.Arrow.Transformer.Abstract.Error
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable
import Control.Arrow.Transformer.Abstract.Fix.Component
import Control.Arrow.Transformer.Abstract.Fix.ControlFlow
import qualified Control.Arrow.Transformer.Abstract.Fix.Stack as Fix
import Control.Arrow.Transformer.Abstract.Memory
import Control.Arrow.Transformer.Abstract.Serialize
......@@ -211,33 +213,27 @@ type Out = Terminating
Except (Exc Value) (JoinList Value, ()))))
type Result = Terminating
type Result = (CFG (Instruction Natural), Terminating
(Error
(Pow String)
(JoinVector Value,
--(Tables,
(StaticGlobalState Value,
Except (Exc Value) (JoinList Value, [Value]))))
Except (Exc Value) (JoinList Value, [Value])))))
invokeExported :: StaticGlobalState Value
-> Tables
-> ModuleInstance
-> Text
-> [Value]
-> Terminating
(Error
(Pow String)
(JoinVector Value,
--(Tables,
(StaticGlobalState Value,
Except (Exc Value) (JoinList Value, [Value]))))
-> Result
invokeExported store tab modInst funcName args =
let ?cacheWidening = W.finite in
--let ?fixpointAlgorithm = Function.fix in -- TODO: we need something else here
--let algo = (trace p1 p2) . (Fix.filter isRecursive $ innermost) in
let algo = Fix.filter isRecursive $ innermost in
let algo = (recordControlFlowGraph' getExpression) . (Fix.filter isRecursive $ innermost) in
let ?fixpointAlgorithm = fixpointAlgorithm algo in
snd $ Trans.run
(\(cfg,(_,res)) -> (cfg,res)) $ Trans.run
(Generic.invokeExported ::
ValueT Value
(ReaderT Generic.LabelArities
......@@ -255,7 +251,8 @@ invokeExported store tab modInst funcName args =
(ComponentT Component In
(Fix.StackT Fix.Stack In
(CacheT Cache In Out
(->))))))))))))))) (Text, [Value]) [Value]) (JoinVector $ Vec.empty,((0,modInst),(tab,(store,([],(Generic.LabelArities [],(funcName, args)))))))
(ControlFlowT (Instruction Natural)
(->)))))))))))))))) (Text, [Value]) [Value]) (JoinVector $ Vec.empty,((0,modInst),(tab,(store,([],(Generic.LabelArities [],(funcName, args)))))))
where
isRecursive (_,(_,(_,(_,(_,(_,inst)))))) = case inst of
Loop {} : _ -> True
......@@ -267,6 +264,8 @@ invokeExported store tab modInst funcName args =
p2 (Terminating (Error.Success (stack, (_,rest)))) = pretty rest
p2 x = pretty x
getExpression (_,(_,(_,(_,(_,(_,exprs)))))) = case exprs of e:_ -> Just e; _ -> Nothing
instantiateAbstract :: ValidModule -> IO (Either String (ModuleInstance, StaticGlobalState Value, Tables))
instantiateAbstract valMod = do res <- instantiate valMod alpha (\_ _ -> ()) TableInst
return $ fmap (\(m,s,_,tab) -> (m,s,JoinVector tab)) res
......
......@@ -58,18 +58,20 @@ runFunc modName funcName args = do
return $ invokeExported staticS tabs modInst (pack funcName) args
succResult :: Result -> [Value]
succResult (Terminating (Success (_,(_,(Exc.Success (_,result)))))) = result
succResult (_,(Terminating (Success (_,(_,(Exc.Success (_,result))))))) = result
excResult :: Result -> Exc.Except (U.Exc Value) [Value]
excResult (Terminating (Success (_,(_,(Exc.Success (_,result)))))) = Exc.Success result
excResult (Terminating (Success (_,(_,(Exc.SuccessOrFail e (_,result)))))) = Exc.SuccessOrFail e result
excResult (Terminating (Success (_,(_,(Exc.Fail e))))) = Exc.Fail e
excResult (_,(Terminating (Success (_,(_,(Exc.Success (_,result))))))) = Exc.Success result
excResult (_,(Terminating (Success (_,(_,(Exc.SuccessOrFail e (_,result))))))) = Exc.SuccessOrFail e result
excResult (_,(Terminating (Success (_,(_,(Exc.Fail e)))))) = Exc.Fail e
spec :: Spec
spec = do
it "run fact" $ do
result <- runFunc "fact" "fac-rec" [Value $ VI64 ()]
let cfg = fst result
--putStrLn $ show cfg
(succResult result) `shouldBe` [Value $ VI64 ()]
-- validMod <- readModule "test/samples/fact.wast"
-- Right (modInst, store) <- instantiate validMod
......@@ -105,6 +107,11 @@ spec = do
(Exc.SuccessOrFail _ [Value (VI32 ())]) -> True
_ -> False)
it "run test-unreachable" $ do
result <- runFunc "simple" "test-unreachable" []
let cfg = fst result
--putStrLn $ show cfg
(succResult result) `shouldBe` [Value $ VI32 ()]
-- it "run non-terminating" $ do
-- validMod <- readModule "test/samples/simple.wast"
-- Right (modInst, store) <- instantiate validMod
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment