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
|
{-
Kaya - My favourite toy language.
Copyright (C) 2004, 2005 Edwin Brady
This file is distributed under the terms of the GNU General
Public Licence. See COPYING for licence.
-}
module CallGraph where
-- Implements a call graph, showing which functions call which others
import Language
import List
-- List of names paired with the names that function calls
type CG = [(Name, [Name])]
makeCG :: Program -> CG
makeCG ((FunBind (_,_,n,_,_,Defined exp) _ _):xs)
= (n,((nub.getCalls) exp) \\ [n]):(makeCG xs)
makeCG ((FunBind (_,_,n,_,_,_) _ _):xs)
= (n,[]):(makeCG xs)
makeCG (_:xs) = makeCG xs
makeCG [] = []
-- nameLT defines a partial order on names. A name is less than (more
-- specialised than) another name if it is called by the other name.
nameLT :: CG -> Name -> Name -> Bool
nameLT cg x y = lunameLT x (lookup y cg)
where lunameLT x Nothing = False
lunameLT x (Just ns) = x `elem` ns
getCalls :: Eq n => Expr n -> [n]
getCalls = foldsubexpr eqn (++) []
where eqn (Global n _ _) = [n]
eqn x = getCalls x
-- Sort a program so that (as far as possible) each function calls no
-- function further on in the list of bindings - this can't work for
-- mutual recursive functions, but can for others, and may help with
-- optimisations (especially those which work across a whole module).
sortprog :: Program -> Program
sortprog p = sp p
where cg = makeCG p
sp [] = []
sp (x:xs) = pi x (sp xs)
pi x [] = [x]
pi x (y:ys) | attop x = (x:y:ys) -- in another module, put it first
-- FIXME: Too slow. In future, maybe just do this if
-- certain optimisation flags are turned on, but currently
-- it's not used.
-- | nameLT cg (name x) (name y) = (x:y:ys)
| otherwise = (y:(pi x ys))
-- If it's not a defined function, leave it where it is.
attop (FunBind (_,_,n,_,_,Defined _) _ _) = False
attop _ = True
name (FunBind (_,_,n,_,_,_) _ _) = n
name _ = UN ""
dumpCG :: CG -> String
dumpCG [] = ""
dumpCG (x:xs) = dumpEntry x ++ "\n" ++ dumpCG xs
where dumpEntry (n,ns) = showuser n ++ " calls:\n\t" ++ showlist ns ++ "\n"
showlist [] = "[Nothing]"
showlist [x] = showuser x
showlist (x:xs) = showuser x ++ ", "++showlist xs
|
