diff --git a/src/Search/Search.hs b/src/Search/Search.hs index 043d5be508178a48bde35050c3845b06dbdedd86..d7793c7aafcb6fa8b7589b60ef9de0fb2b927c5a 100644 --- a/src/Search/Search.hs +++ b/src/Search/Search.hs @@ -55,22 +55,25 @@ makeLenses ''State insertEdge :: G.Node -> G.Node -> EdgeLabel -> StateGraph -> StateGraph insertEdge from to label = over _graph (insEdge' (from, to, label)) -addVertex :: VertexLabel -> State -> State +-- | Returns (seen, newState) where seen indicates if the +-- vertex was already known. +addVertex :: VertexLabel -> State -> (Bool, State) addVertex vert s = let - vertexNode = case M.lookup vert (s ^. vertices) of - Just node -> node - Nothing -> head (G.newNodes 1 (s ^. foundGraph._graph)) + (vertexNode, seen) = case M.lookup vert (s ^. vertices) of + Just node -> (node, True) + Nothing -> (head (G.newNodes 1 (s ^. foundGraph._graph)), False) newGraph = if G.gelem vertexNode (s^.foundGraph._graph) then s^.foundGraph else s^.foundGraph & _graph %~ G.insNode (vertexNode, vert) + s' = s & foundGraph .~ insertEdge (s^.currentVertex) vertexNode (s^.currentSyscall) newGraph + & vertices %~ M.insert vert vertexNode + & currentVertex .~ vertexNode + & currentSyscall .~ Nothing -- Always reset, as we already inserted the target in - s & foundGraph .~ insertEdge (s^.currentVertex) vertexNode (s^.currentSyscall) newGraph - & vertices %~ M.insert vert vertexNode - & currentVertex .~ vertexNode - & currentSyscall .~ Nothing -- Always reset, as we already inserted the target + (seen, s') data NextStep = Restart | Continue Bool @@ -143,9 +146,13 @@ killProcess handle = do oneProgRun :: FilePath -> DebugOutput -> IORef State -> Maybe [Bool] -> IO () oneProgRun prog debug state trace = do + when debug $ do + hPutStrLn stderr "New run" + when (isJust trace) $ + hPutStrLn stderr ("Tracing path: " <> show (fromJust trace)) (Just pstdin, Just pstdout, _, handle) <- createProcess (proc prog []) { std_in = CreatePipe, std_out = CreatePipe } case trace of - Just trace' -> tracePath debug pstdin pstdout state trace' + Just trace' -> tracePath debug pstdin pstdout state trace' (reverse trace') _ -> return () let loop = handleLine debug pstdout state >>= \case @@ -157,7 +164,7 @@ oneProgRun prog debug state trace = do case next of Restart -> killProcess handle >> mapM_ hClose [pstdin, pstdout] Continue x' -> do - makeDecision pstdin state x' + makeDecision debug pstdin state x' loop EOF -> do @@ -171,23 +178,39 @@ oneProgRun prog debug state trace = do exitFailure mapM_ hClose [pstdin, pstdout] + Loop -> do + when debug $ hPutStrLn stderr "Restart because of loop" + killProcess handle >> mapM_ hClose [pstdin, pstdout] + _ -> loop loop - -tracePath :: DebugOutput -> Handle -> Handle -> IORef State -> [Bool] -> IO () -tracePath _ _ _ _ [] = return () -tracePath debug pstdin pstdout state (decision:ds) = +tracePath :: DebugOutput -> Handle -> Handle -> IORef State -> [Bool] -> [Bool] -> IO () +tracePath debug pstdin pstdout state [] completeTrace = + handleLine debug pstdout state >>= \case + EOF -> error "premature eof" -- FIXME + Decision x -> do + when debug $ hPutStrLn stderr ("Decision: " ++ show x) + s <- readIORef state + let (Continue False, s') = handleDecision x completeTrace s + writeIORef state s' + makeDecision debug pstdin state False + NewVertex _ -> error "vertex should not be new" + _ -> tracePath debug pstdin pstdout state [] completeTrace +tracePath debug pstdin pstdout state (decision:ds) completeTrace = handleLine debug pstdout state >>= \case EOF -> error "premature eof" -- FIXME Decision _ -> do - makeDecision pstdin state decision - tracePath debug pstdin pstdout state ds - _ -> tracePath debug pstdin pstdout state (decision:ds) - -makeDecision :: Handle -> IORef State -> Bool -> IO () -makeDecision pstdin state decision = do + makeDecision debug pstdin state decision + tracePath debug pstdin pstdout state ds completeTrace + NewVertex _ -> error "vertex should not be new" + _ -> tracePath debug pstdin pstdout state (decision:ds) completeTrace + +makeDecision :: DebugOutput -> Handle -> IORef State -> Bool -> IO () +makeDecision debug pstdin state decision = do + when debug $ + hPutStrLn stderr ("Deciding " <> show decision) T.hPutStrLn pstdin $ formatDecision $ DecisionInput decision hFlush pstdin modifyIORef state (\s -> s & curTrace %~ (decision :) ) @@ -195,6 +218,7 @@ makeDecision pstdin state decision = do data LineOut = NewVertex VertexLabel | Syscall Text Text -- ^ First is syscall name, second is ABB | Decision DecisionNumber + | Loop | EOF parseLine :: DebugOutput -> Handle -> IO LineOut @@ -219,8 +243,15 @@ parseLine debug handle = do handleLine :: DebugOutput -> Handle -> IORef State -> IO LineOut handleLine debug pstdin state = parseLine debug pstdin >>= \case NewVertex vert -> do - modifyIORef state (addVertex vert) - return (NewVertex vert) + s <- readIORef state + let (seen, s') = addVertex vert s + writeIORef state s' + when debug $ + hPutStrLn stderr ("Node count: " <> show (M.size (s'^.vertices))) + if seen then + return Loop + else + return (NewVertex vert) line@(Syscall syscall abb) -> do modifyIORef state (\s -> s & currentSyscall .~ Just (EdgeLabel syscall abb)) return line