1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
------------------------------------------------------------------------
--- Implementation of the analysis computations on the server side
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version January 2015
------------------------------------------------------------------------
-- analysis computations on the server side
module ServerFunctions where
import FlatCurry.Types (QName)
import FlatCurry.Goodies (progImports)
import Socket(Socket(..),listenOnFresh,sClose,waitForSocketAccept)
import IO(Handle(..),hClose,hFlush,hGetLine,hPutStrLn,hWaitForInput,hWaitForInputs)
import ReadShowTerm(readQTerm,showQTerm)
import System(system,sleep)
import Directory(doesFileExist,getModificationTime)
import Maybe(fromMaybe)
import List(delete)
import Time(ClockTime)
import Analysis
import GenericProgInfo
import AnalysisDependencies
import XML(showXmlDoc,xml)
import Configuration(debugMessage,waitTime)
data WorkerMessage = Task String String | ChangePath String | StopWorker
-- Master loop for communication with workers
-- Argument 1: handles for workers that are currently free
-- Argument 2: handles for workers that are currently busy
-- Argument 3: the analysis name
-- Argument 4: the name of the main module
-- Argument 5: the modules to be analyzed (with their dependencies)
-- Argument 6: names of modules that are ready be to analyzed (since their
-- imports are already analyzed)
-- Result: Nothing (in case of successful work) or (Just <error>)
masterLoop :: [Handle] -> [Handle] -> String -> String
-> [(String,[String])] -> [String] -> IO (Maybe String)
masterLoop _ [] _ _ [] [] = do
debugMessage 2 "Master loop: terminated"
return Nothing
masterLoop _ (b:busyWorker) ananame mainModule [] [] = do
debugMessage 2 "Master loop: waiting for worker result"
inputHandle <- hWaitForInputs (b:busyWorker) waitTime
if inputHandle/=0
then return (Just "No input from any worker received")
else do
let handle = b
input <- hGetLine handle
debugMessage 2 ("Master loop: got message: "++input)
let Task ananame2 moduleName2 = readQTerm input
if ananame==ananame2 && moduleName2==mainModule
then return Nothing
else return (Just "Received analysis does not match requested analysis")
masterLoop idleWorker busyWorker ananame mainModule
modulesToDo@(_:_) [] = do
debugMessage 3 ("Master loop: modules to do: "++(showQTerm modulesToDo))
let modulesToDo2 = filter ((not . null) . snd) modulesToDo
waitList = map fst (filter (null . snd) modulesToDo)
if null waitList
then do
debugMessage 2 "Master loop: waiting for workers to finish"
inputHandle <- hWaitForInputs busyWorker waitTime
if inputHandle<0
then return (Just "No input from any worker received")
else do
let handle = busyWorker !! inputHandle
input <- hGetLine handle
debugMessage 2 ("Master loop: got message: "++input)
let Task ananame2 moduleName2 = readQTerm input
if ananame==ananame2
then do
let modulesToDo3 = reduceDependencies modulesToDo2 [moduleName2]
busyWorker2= deleteIndex inputHandle busyWorker
masterLoop (handle:idleWorker) busyWorker2 ananame
mainModule modulesToDo3 waitList
else
return
(Just "Received analysis does not match requested analysis type")
else masterLoop idleWorker busyWorker ananame mainModule modulesToDo2
waitList
masterLoop (handle:idleWorker) busyWorker ananame mainModule modulesToDo
(modName:waitList) = do
debugMessage 2 "Master loop: worker available, send task to a worker..."
let newTask = showQTerm (Task ananame modName)
hPutStrLn handle newTask
hFlush handle
debugMessage 2 ("Master loop: send message: "++newTask)
masterLoop idleWorker (handle:busyWorker) ananame mainModule
modulesToDo waitList
masterLoop [] busyWorker ananame mainModule modulesToDo
waits@(modName:waitList) = do
debugMessage 2 $ "Waiting for worker to analyze modules: "++show waits
inputHandle <- hWaitForInputs busyWorker waitTime
if inputHandle<0
then return (Just "No input from any worker received")
else do
let handle = busyWorker !! inputHandle
input <- hGetLine handle
debugMessage 2 ("Master loop: got message: "++input)
let Task _ finishedmodule = readQTerm input
newTask = showQTerm (Task ananame modName)
hPutStrLn handle newTask
hFlush handle
debugMessage 2 ("Master loop: send message: "++newTask)
let modulesToDo2 = reduceDependencies modulesToDo [finishedmodule]
masterLoop [] busyWorker ananame mainModule modulesToDo2 waitList
deleteIndex :: Int -> [a] -> [a]
deleteIndex _ [] = []
deleteIndex n (x:xs) | n==0 = xs
| otherwise = x : deleteIndex (n-1) xs
-----------------------------------------------------------------------
|
