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
|
module Analysis.RootReplaced
( rootReplAnalysis, showRootRepl
, rootCyclicAnalysis, showRootCyclic
)
where
import Analysis.Types
import Analysis.ProgInfo
import FlatCurry.Types
import List
import Sort(sort)
type RootReplaced = ([QName],[Int])
showRootRepl :: AOutFormat -> RootReplaced -> String
showRootRepl AText ([],_) = "no root replacements"
showRootRepl ANote ([],_) = ""
showRootRepl AText (xs@(_:_),_) =
"root replacements: " ++ intercalate "," (map (\ (mn,fn) -> mn++"."++fn) xs)
showRootRepl ANote (xs@(_:_),_) = "[" ++ intercalate "," (map snd xs) ++ "]"
rootReplAnalysis :: Analysis RootReplaced
rootReplAnalysis = dependencyFuncAnalysis "RootReplaced" ([],[]) rrFunc
rrFunc :: FuncDecl -> [(QName,RootReplaced)] -> RootReplaced
rrFunc (Func _ _ _ _ rule) calledFuncs = rrFuncRule calledFuncs rule
rrFuncRule :: [(QName,RootReplaced)] -> Rule -> RootReplaced
rrFuncRule _ (External _) = ([],[])
rrFuncRule calledFuncs (Rule args rhs) = rrOfExp rhs
where
rrOfExp exp = case exp of
Var v -> maybe ([],[]) (\i -> ([],[i])) (elemIndex v args)
Lit _ -> ([],[])
Comb ct g gargs ->
if ct == FuncCall
then maybe (error $ "Abstract value of " ++ show g ++ " not found!")
(\ (grrs,gps) ->
foldr lub (if g `elem` grrs
then grrs
else insertBy (<=) g grrs, [])
(map (\pi -> rrOfExp (gargs!!pi)) gps))
(lookup g calledFuncs)
else ([],[])
Typed e _ -> rrOfExp e
Free _ e -> rrOfExp e
Let _ e -> rrOfExp e
Or e1 e2 -> lub (rrOfExp e1) (rrOfExp e2)
Case _ e bs -> foldr lub (rrOfExp e)
(map (\ (Branch _ be) -> rrOfExp be) bs)
lub (rr1,p1) (rr2,p2) = (sort (union rr1 rr2), sort (union p1 p2))
showRootCyclic :: AOutFormat -> Bool -> String
showRootCyclic AText False = "no cycles at the root"
showRootCyclic ANote False = ""
showRootCyclic AText True = "possible cyclic root replacement"
showRootCyclic ANote True = "root-cyclic"
rootCyclicAnalysis :: Analysis Bool
rootCyclicAnalysis =
combinedSimpleFuncAnalysis "RootCyclic" rootReplAnalysis rcFunc
rcFunc :: ProgInfo RootReplaced -> FuncDecl -> Bool
rcFunc _ (Func _ _ _ _ (External _)) = False
rcFunc rrinfo (Func qf _ _ _ (Rule _ _)) =
maybe True
(\rrfuncs -> qf `elem` (fst rrfuncs)
|| any (\rrf -> maybe True
(\fs -> rrf `elem` (fst fs))
(lookupProgInfo rrf rrinfo))
(fst rrfuncs))
(lookupProgInfo qf rrinfo)
|