WorkerFunctions.curry 17.7 KB
Newer Older
1
2
3
4
5
--------------------------------------------------------------------------
--- Operations to implement the client workers.
--- In particular, it contains some simple fixpoint computations.
---
--- @author Heiko Hoffmann, Michael Hanus
Michael Hanus's avatar
Michael Hanus committed
6
--- @version December 2018
7
8
--------------------------------------------------------------------------

Michael Hanus's avatar
Michael Hanus committed
9
module CASS.WorkerFunctions where
10
11

import FiniteMap
Michael Hanus's avatar
Michael Hanus committed
12
13
14
15
import IOExts
import List         ( partition )
import Maybe        ( fromJust )
import System       ( getCPUTime )
16

Michael Hanus's avatar
Michael Hanus committed
17
18
19
20
21
22
import Analysis.Files
import Analysis.Logging  ( debugMessage, debugString )
import Analysis.Types    ( Analysis(..), isSimpleAnalysis, isCombinedAnalysis
                         , analysisName, startValue)
import Analysis.ProgInfo ( ProgInfo, combineProgInfo, emptyProgInfo
                         , publicProgInfo, lookupProgInfo, lists2ProgInfo
Michael Hanus's avatar
Michael Hanus committed
23
24
25
26
                         , equalProgInfo, publicListFromProgInfo, showProgInfo )
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
Michael Hanus's avatar
Michael Hanus committed
27
import Data.SCC          ( scc )
Michael Hanus's avatar
Michael Hanus committed
28
import Data.Set.RBTree as Set ( SetRBT, member, empty, insert, null )
Michael Hanus's avatar
Michael Hanus committed
29

Michael Hanus's avatar
Michael Hanus committed
30
import CASS.Configuration
Michael Hanus's avatar
Michael Hanus committed
31
import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes )
Michael Hanus's avatar
Michael Hanus committed
32

33
34
35
36
37
38
39
40
41
42
43
-----------------------------------------------------------------------
-- Datatype to store already read ProgInfos for modules.

type ProgInfoStore a = [(String,ProgInfo a)]

newProgInfoStoreRef :: IO (IORef (ProgInfoStore _))
newProgInfoStoreRef = newIORef []

-----------------------------------------------------------------------
--- Analyze a list of modules (in the given order) with a given analysis.
--- The analysis results are stored in the corresponding analysis result files.
Michael Hanus's avatar
Michael Hanus committed
44
analysisClient :: Eq a => Analysis a -> [String] -> IO ()
45
46
47
48
49
analysisClient analysis modnames = do
  store <- newIORef []
  fpmethod <- getFPMethod
  mapIO_ (analysisClientWithStore store analysis fpmethod) modnames

Michael Hanus's avatar
Michael Hanus committed
50
analysisClientWithStore :: Eq a => IORef (ProgInfoStore a) -> Analysis a -> String
51
52
                        -> String -> IO ()
analysisClientWithStore store analysis fpmethod moduleName = do
Michael Hanus's avatar
Michael Hanus committed
53
54
55
56
57
58
  prog        <- readNewestFlatCurry moduleName
  withprelude <- getWithPrelude
  let progimports = progImports prog
      importList  = if withprelude=="no" then filter (/="Prelude") progimports
                                         else progimports
      ananame     = analysisName analysis
59
60
61
62
  importInfos <-
    if isSimpleAnalysis analysis
    then return emptyProgInfo
    else getInterfaceInfosWS store (analysisName analysis) importList
63
  debugString 1 $ "Analysis time for " ++ ananame ++ "/" ++ moduleName ++ ": "
64
65
66
67
68
69
70
71
72
  starttime <- getCPUTime
  startvals <- getStartValues analysis prog
  result <-
     if isCombinedAnalysis analysis
     then execCombinedAnalysis analysis prog importInfos
                                startvals moduleName fpmethod
     else runAnalysis analysis prog importInfos startvals fpmethod
  storeAnalysisResult ananame moduleName result
  stoptime <- getCPUTime
73
  debugMessage 1 $ show (stoptime-starttime) ++ " msecs"
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
  loadinfos <- readIORef store
  writeIORef store ((moduleName,publicProgInfo result):loadinfos)


-- Loads analysis results for a list of modules where already read results
-- are stored in an IORef.
getInterfaceInfosWS :: IORef (ProgInfoStore a) -> String -> [String]
                    -> IO (ProgInfo a)
getInterfaceInfosWS _ _ [] = return emptyProgInfo
getInterfaceInfosWS store anaName (mod:mods) = do
  loadinfos <- readIORef store
  modInfo <- maybe (loadAndStoreAnalysis loadinfos) return
                   (lookup mod loadinfos)
  modsInfo <- getInterfaceInfosWS store anaName mods
  return (combineProgInfo modInfo modsInfo)
 where
  loadAndStoreAnalysis loadinfos = do
    info <- loadPublicAnalysis anaName mod
    writeIORef store ((mod,info):loadinfos)
    return info


-----------------------------------------------------------------------

--- Compute the start (bottom) values for a dependency analysis.
getStartValues :: Analysis a -> Prog -> IO [(QName,a)]
getStartValues analysis prog =
  if isSimpleAnalysis analysis
  then return []
  else do
    let startvals = case analysis of 
          DependencyFuncAnalysis _ _ _ -> 
            map (\func->(funcName func,startValue analysis)) 
                (progFuncs prog)
          CombinedDependencyFuncAnalysis _ _ _ _ _ -> 
            map (\func->(funcName func,startValue analysis))
                (progFuncs prog)
          DependencyTypeAnalysis _ _ _ -> 
            map (\typeDecl->(typeName typeDecl,startValue analysis))
                (progTypes prog)
          CombinedDependencyTypeAnalysis _ _ _ _ _ -> 
            map (\typeDecl->(typeName typeDecl,startValue analysis)) 
                (progTypes prog)
117
          _ -> error "Internal error in WorkerFunctions.getStartValues"
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
    return startvals

--- Compute a ProgInfo from a given list of infos for each function name w.r.t.
--- a given program.
funcInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a
funcInfos2ProgInfo prog infos = lists2ProgInfo $
   map2 (\fdecl -> let fname = funcName fdecl
                    in (fname, fromJust (lookup fname infos)))
        (partition isVisibleFunc (progFuncs prog))

--- Compute a ProgInfo from a given list of infos for each type name w.r.t.
--- a given program.
typeInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a
typeInfos2ProgInfo prog infos = lists2ProgInfo $
   map2 (\tdecl -> let tname = typeName tdecl
                    in (tname, fromJust (lookup tname infos)))
        (partition isVisibleType (progTypes prog))

Michael Hanus's avatar
Michael Hanus committed
136
137
map2 :: (a -> b) -> ([a], [a]) -> ([b], [b])
map2 f (xs,ys) = (map f xs, map f ys)
138
139
140

--- Update a given value list (second argument) w.r.t. new values given
--- in the first argument list.
Michael Hanus's avatar
Michael Hanus committed
141
updateList :: Eq a => [(a,b)] -> [(a,b)] -> [(a,b)]
142
143
144
145
updateList [] oldList = oldList
updateList ((key,newValue):newList) oldList =
  updateList newList (updateValue (key,newValue) oldList)

Michael Hanus's avatar
Michael Hanus committed
146
updateValue :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
147
148
149
150
151
152
updateValue _ [] = []
updateValue (key1,newValue) ((key2,value2):list) = 
  if key1==key2 then (key1,newValue):list
                else (key2,value2):(updateValue (key1,newValue) list)

-----------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
153
execCombinedAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)]
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
                     -> String -> String -> IO (ProgInfo a)
execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod =
 case analysis of
  CombinedSimpleFuncAnalysis _ ananame _ runWithBaseAna -> do
    anaFunc <- runWithBaseAna moduleName
    runAnalysis (SimpleFuncAnalysis ananame anaFunc)
                prog importInfos startvals fpmethod
  CombinedSimpleTypeAnalysis _ ananame _ runWithBaseAna -> do
    anaFunc <- runWithBaseAna moduleName
    runAnalysis (SimpleTypeAnalysis ananame anaFunc)
                prog importInfos startvals fpmethod
  CombinedDependencyFuncAnalysis _ ananame _ startval runWithBaseAna -> do
    anaFunc <- runWithBaseAna moduleName
    runAnalysis (DependencyFuncAnalysis ananame startval anaFunc)
                prog importInfos startvals fpmethod
  CombinedDependencyTypeAnalysis _ ananame _ startval runWithBaseAna -> do
    anaFunc <- runWithBaseAna moduleName
    runAnalysis (DependencyTypeAnalysis ananame startval anaFunc)
                prog importInfos startvals fpmethod
173
  _ -> error "Internal error in WorkerFunctions.execCombinedAnalysis"
174
175
176

-----------------------------------------------------------------------
--- Run an analysis but load default values (e.g., for external operations)
Michael Hanus's avatar
Michael Hanus committed
177
--- before and do not analyse the operations or types for these defaults.
Michael Hanus's avatar
Michael Hanus committed
178
runAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String
179
180
181
182
            -> IO (ProgInfo a)
runAnalysis analysis prog importInfos startvals fpmethod = do
  deflts <- loadDefaultAnalysisValues (analysisName analysis) (progName prog)
  let defaultFuncs =
Michael Hanus's avatar
Michael Hanus committed
183
        updProgFuncs (filter (\fd -> funcName fd `elem`    map fst deflts)) prog
184
185
186
      definedFuncs =
        updProgFuncs (filter (\fd -> funcName fd `notElem` map fst deflts)) prog
      defaultTypes =
Michael Hanus's avatar
Michael Hanus committed
187
        updProgTypes (filter (\fd -> typeName fd `elem`    map fst deflts)) prog
188
189
190
191
192
193
194
195
      definedTypes =
        updProgTypes (filter (\fd -> typeName fd `notElem` map fst deflts)) prog
  let (progWithoutDefaults,defaultproginfo) = case analysis of
        SimpleFuncAnalysis _ _ ->
         (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts)
        SimpleTypeAnalysis _ _ ->
         (definedTypes, typeInfos2ProgInfo defaultTypes deflts)
        SimpleConstructorAnalysis _ _ -> -- there are no external constructors
Michael Hanus's avatar
Michael Hanus committed
196
         if Prelude.null deflts then (prog,emptyProgInfo)
197
198
199
200
201
         else error "SimpleConstructorAnalysis with default values!"
        DependencyFuncAnalysis _ _ _ ->
         (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts)
        DependencyTypeAnalysis _ _ _ ->
         (definedTypes, typeInfos2ProgInfo defaultTypes deflts)
Michael Hanus's avatar
Michael Hanus committed
202
        SimpleModuleAnalysis _ _ ->
Michael Hanus's avatar
Michael Hanus committed
203
         if Prelude.null deflts then (definedFuncs, emptyProgInfo)
Michael Hanus's avatar
Michael Hanus committed
204
205
                        else error defaultNotEmptyError
        DependencyModuleAnalysis _ _ ->
Michael Hanus's avatar
Michael Hanus committed
206
         if Prelude.null deflts then (definedFuncs, emptyProgInfo)
Michael Hanus's avatar
Michael Hanus committed
207
                        else error defaultNotEmptyError
208
        _ -> error "Internal error in WorkerFunctions.runAnalysis"
209
210
211
212
  let result = executeAnalysis analysis progWithoutDefaults
                               (combineProgInfo importInfos defaultproginfo)
                               startvals fpmethod
  return $ combineProgInfo defaultproginfo result
Michael Hanus's avatar
Michael Hanus committed
213
214
215
216
 where
  defaultNotEmptyError = "Default analysis information for analysis '" ++
                         analysisName analysis ++ "' and module '" ++
                         progName prog ++ "' not empty!"
217
218
219
220

--- Executes an anlysis on a given program w.r.t. an imported ProgInfo
--- and some start values (for dependency analysis).
--- The fixpoint iteration method to be applied is passed as the last argument.
Michael Hanus's avatar
Michael Hanus committed
221
222
executeAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)]
                -> String
223
                -> ProgInfo a
Michael Hanus's avatar
Michael Hanus committed
224
225
226
227
228
229
230
231
232
233
234
235

-- The results of a module analysis for module `m` are encoded as
-- a `ProgInfo` with a single entry for the qualified name `m.m`.
executeAnalysis (SimpleModuleAnalysis _ anaFunc) prog _ _ _ =
 let pname = progName prog
 in lists2ProgInfo ([((pname,pname), anaFunc prog)], [])
executeAnalysis (DependencyModuleAnalysis _ anaFunc) prog impproginfos _ _ =
 let pname       = progName prog
     importinfos = map (\ (qn,a) -> (fst qn,a))
                       (publicListFromProgInfo impproginfos)
 in lists2ProgInfo ([((pname,pname), anaFunc prog importinfos)], [])

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
executeAnalysis (SimpleFuncAnalysis _ anaFunc) prog _ _ _ = 
  (lists2ProgInfo . map2 (\func -> (funcName func, anaFunc func))
                  . partition isVisibleFunc . progFuncs) prog

executeAnalysis (SimpleTypeAnalysis _ anaFunc) prog _ _ _ = 
  (lists2ProgInfo . map2 (\typ -> (typeName typ,anaFunc typ))
                  . partition isVisibleType . progTypes) prog

executeAnalysis (SimpleConstructorAnalysis _ anaFunc) prog _ _ _ = 
  (lists2ProgInfo
    . map2 (\ (cdecl,tdecl) -> (consName cdecl, anaFunc cdecl tdecl))
    . partition isVisibleCons
    . concatMap (\t -> map (\c->(c,t)) (consDeclsOfType t))
    . progTypes) prog
 where
  isVisibleCons (consDecl,_) = consVisibility consDecl == Public

executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
                importInfos startvals fpmethod = case fpmethod of
  "simple" ->
    let declsWithDeps = map2 addCalledFunctions
                             (partition isVisibleFunc (progFuncs prog))
        startinfo = funcInfos2ProgInfo prog startvals
     in simpleIteration anaFunc funcName declsWithDeps importInfos startinfo
  "wlist" ->
    let declsWithDeps = map addCalledFunctions (progFuncs prog)
     in funcInfos2ProgInfo prog $ fmToList $ 
Michael Hanus's avatar
Michael Hanus committed
263
          wlIteration anaFunc funcName declsWithDeps [] (empty (<))
264
265
266
267
268
269
270
                      importInfos (listToFM (<) startvals)
  "wlistscc" ->
    let declsWithDeps = map addCalledFunctions (progFuncs prog)
        -- compute strongly connected components w.r.t. func dependencies:
        sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps
     in funcInfos2ProgInfo prog $ fmToList $ 
          foldr (\scc sccstartvals ->
Michael Hanus's avatar
Michael Hanus committed
271
                   wlIteration anaFunc funcName scc [] (empty (<))
272
273
274
                               importInfos sccstartvals)
                (listToFM (<) startvals)
                (reverse sccDecls)
Michael Hanus's avatar
Michael Hanus committed
275
  _ -> error unknownFixpointMessage
276
277
278
279
280
281
282
283
284
285
286

executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
                importInfos startvals fpmethod = case fpmethod of
  "simple" ->
    let declsWithDeps = map2 addUsedTypes
                             (partition isVisibleType (progTypes prog))
        startinfo = typeInfos2ProgInfo prog startvals
     in simpleIteration anaType typeName declsWithDeps importInfos startinfo
  "wlist" ->
    let declsWithDeps = map addUsedTypes (progTypes prog)
     in typeInfos2ProgInfo prog $ fmToList $ 
Michael Hanus's avatar
Michael Hanus committed
287
          wlIteration anaType typeName declsWithDeps [] (empty (<))
288
289
290
291
292
293
294
                      importInfos (listToFM (<) startvals)
  "wlistscc" ->
    let declsWithDeps = map addUsedTypes (progTypes prog)
        -- compute strongly connected components w.r.t. type dependencies:
        sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps
     in typeInfos2ProgInfo prog $ fmToList $ 
          foldr (\scc sccstartvals ->
Michael Hanus's avatar
Michael Hanus committed
295
                   wlIteration anaType typeName scc [] (empty (<))
296
297
298
                               importInfos sccstartvals)
                (listToFM (<) startvals)
                (reverse sccDecls)
Michael Hanus's avatar
Michael Hanus committed
299
  _ -> error unknownFixpointMessage
300
301
302
303
304
305
306
307
308
-- These cases are handled elsewhere:
executeAnalysis (CombinedSimpleFuncAnalysis _ _ _ _) _ _ _ _ =
  error "Internal error in WorkerFunctions.executeAnalysis"
executeAnalysis (CombinedSimpleTypeAnalysis _ _ _ _) _ _ _ _ =
  error "Internal error in WorkerFunctions.executeAnalysis"
executeAnalysis (CombinedDependencyFuncAnalysis _ _ _ _ _) _ _ _ _ =
  error "Internal error in WorkerFunctions.executeAnalysis"
executeAnalysis (CombinedDependencyTypeAnalysis _ _ _ _ _) _ _ _ _ =
  error "Internal error in WorkerFunctions.executeAnalysis"
309

Michael Hanus's avatar
Michael Hanus committed
310
311
unknownFixpointMessage :: String
unknownFixpointMessage = "Unknown value for 'fixpoint' in configuration file!"
312
313
314
315
316
317
318
319
320
321

--- Add the directly called functions to each function declaration.
addCalledFunctions :: FuncDecl -> (FuncDecl,[QName])
addCalledFunctions func = (func, callsDirectly func)

--- Add the directly used type constructors to each type declaration.
addUsedTypes :: TypeDecl -> (TypeDecl,[QName])
addUsedTypes tdecl = (tdecl, dependsDirectlyOnTypes tdecl)

--- Gets all constructors of datatype declaration.
Michael Hanus's avatar
Michael Hanus committed
322
consDeclsOfType :: TypeDecl -> [ConsDecl]
323
324
325
326
327
328
329
330
331
332
333
consDeclsOfType (Type _ _ _ consDecls) = consDecls
consDeclsOfType (TypeSyn _ _ _ _) = []

-----------------------------------------------------------------------
--- Fixpoint iteration to compute analysis information. The arguments are:
--- * analysis operation
--- * operation to get name of a declaration
--- * list of public and private declarations together with their direct deps
--- * ProgInfo for imported entities
--- * current ProgInfo
--- Result: fixpoint ProgInfo
Michael Hanus's avatar
Michael Hanus committed
334
simpleIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
                -> ([(t,[QName])],[(t,[QName])])
                -> ProgInfo a -> ProgInfo a -> ProgInfo a
simpleIteration analysis nameOf declsWithDeps importInfos currvals =
  let completeProgInfo = combineProgInfo currvals importInfos

      newvals =
        map2 (\ (decl,calls) ->
               (nameOf decl,
                analysis decl
                         (map (\qn -> (qn,fromJust -- information must known!
                                          (lookupProgInfo qn completeProgInfo)))
                               calls)))
             declsWithDeps

      newproginfo = lists2ProgInfo newvals

  in if equalProgInfo currvals newproginfo
     then currvals
     else simpleIteration analysis nameOf declsWithDeps importInfos newproginfo

Michael Hanus's avatar
Michael Hanus committed
355
wlIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName)
356
357
358
359
360
361
            -> [(t,[QName])] -> [(t,[QName])] -> SetRBT QName
            -> ProgInfo a -> FM QName a -> FM QName a
--wlIteration analysis nameOf declsToDo declsDone changedEntities
--            importInfos currvals

wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals =
Michael Hanus's avatar
Michael Hanus committed
362
  if Set.null changedEntities
363
364
365
  then currvals -- no todos, no changed values, so we are done:
  else -- all declarations processed, compute todos for next round:
       let (declsToDo,declsDone) =
Michael Hanus's avatar
Michael Hanus committed
366
              partition (\ (_,calls) -> any (`member` changedEntities) calls)
367
                        alldecls
Michael Hanus's avatar
Michael Hanus committed
368
        in wlIteration analysis nameOf declsToDo declsDone (empty (<))
369
370
371
372
373
374
375
376
377
378
379
380
381
382
                       importInfos currvals
-- process a single declaration:
wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone
            changedEntities importInfos currvals =
  let decname = nameOf decl

      lookupVal qn = maybe (fromJust (lookupFM currvals qn)) id
                           (lookupProgInfo qn importInfos)
      oldval = lookupVal decname
      newval = analysis decl (map (\qn -> (qn, lookupVal qn)) calls)
   in if oldval==newval
      then wlIteration analysis nameOf decls (decldeps:declsDone)
                       changedEntities importInfos currvals
      else wlIteration analysis nameOf decls (decldeps:declsDone)
Michael Hanus's avatar
Michael Hanus committed
383
                       (insert decname changedEntities) importInfos
384
385
386
387
388
389
390
391
392
393
394
395
396
                       (updFM currvals decname (const newval))


---------------------------------------------------------------------
-- Auxiliaries

isVisibleFunc :: FuncDecl -> Bool
isVisibleFunc funcDecl = funcVisibility funcDecl == Public

isVisibleType :: TypeDecl -> Bool
isVisibleType typeDecl = typeVisibility typeDecl == Public

---------------------------------------------------------------------