NameEnv.hs 4.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
\section[NameEnv]{@NameEnv@: name environments}
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE CPP #-}
9
module NameEnv (
10 11 12 13 14
        -- * Var, Id and TyVar environments (maps)
        NameEnv,

        -- ** Manipulating these environments
        mkNameEnv,
15 16
        emptyNameEnv, isEmptyNameEnv,
        unitNameEnv, nameEnvElts, nameEnvUniqueElts,
17
        extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
Simon Marlow's avatar
Simon Marlow committed
18
        extendNameEnvList, extendNameEnvList_C,
19
        foldNameEnv, filterNameEnv, anyNameEnv,
20 21
        plusNameEnv, plusNameEnv_C, alterNameEnv,
        lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
22
        elemNameEnv, mapNameEnv, disjointNameEnv,
23 24 25

        -- ** Dependency analysis
        depAnal
26 27 28 29
    ) where

#include "HsVersions.h"

30
import Digraph
Simon Marlow's avatar
Simon Marlow committed
31
import Name
32
import Unique
33
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
34
import Maybes
35

Austin Seipp's avatar
Austin Seipp committed
36 37 38
{-
************************************************************************
*                                                                      *
39
\subsection{Name environment}
Austin Seipp's avatar
Austin Seipp committed
40 41 42
*                                                                      *
************************************************************************
-}
43

44
depAnal :: (node -> [Name])      -- Defs
45 46 47 48 49 50 51 52 53 54 55
        -> (node -> [Name])      -- Uses
        -> [node]
        -> [SCC node]
-- Peform dependency analysis on a group of definitions,
-- where each definition may define more than one Name
--
-- The get_defs and get_uses functions are called only once per node
depAnal get_defs get_uses nodes
  = stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
  where
    keyed_nodes = nodes `zip` [(1::Int)..]
Icelandjack's avatar
Icelandjack committed
56
    mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))
57 58

    key_map :: NameEnv Int   -- Maps a Name to the key of the decl that defines it
59
    key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
60

Austin Seipp's avatar
Austin Seipp committed
61 62 63
{-
************************************************************************
*                                                                      *
64
\subsection{Name environment}
Austin Seipp's avatar
Austin Seipp committed
65 66 67
*                                                                      *
************************************************************************
-}
68

69
type NameEnv a = UniqFM a       -- Domain is Name
70

71
emptyNameEnv       :: NameEnv a
72
isEmptyNameEnv     :: NameEnv a -> Bool
73 74
mkNameEnv          :: [(Name,a)] -> NameEnv a
nameEnvElts        :: NameEnv a -> [a]
75
nameEnvUniqueElts  :: NameEnv a -> [(Unique, a)]
76
alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
77
extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
78
extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b
79 80 81
extendNameEnv      :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv        :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C      :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
82
extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a
Simon Marlow's avatar
Simon Marlow committed
83
extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a
84
delFromNameEnv     :: NameEnv a -> Name -> NameEnv a
85
delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a
86 87 88
elemNameEnv        :: Name -> NameEnv a -> Bool
unitNameEnv        :: Name -> a -> NameEnv a
lookupNameEnv      :: NameEnv a -> Name -> Maybe a
89
lookupNameEnv_NF   :: NameEnv a -> Name -> a
90 91
foldNameEnv        :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
92
anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool
93
mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
94
disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool
95

96
nameEnvElts x         = eltsUFM x
97
emptyNameEnv          = emptyUFM
98
isEmptyNameEnv        = isNullUFM
99
unitNameEnv x y       = unitUFM x y
100 101 102
extendNameEnv x y z   = addToUFM x y z
extendNameEnvList x l = addListToUFM x l
lookupNameEnv x y     = lookupUFM x y
103
alterNameEnv          = alterUFM
104
mkNameEnv     l       = listToUFM l
105 106 107 108
elemNameEnv x y          = elemUFM x y
foldNameEnv a b c        = foldUFM a b c
plusNameEnv x y          = plusUFM x y
plusNameEnv_C f x y      = plusUFM_C f x y
109
extendNameEnv_C f x y z  = addToUFM_C f x y z
110
mapNameEnv f x           = mapUFM f x
111 112 113 114 115 116
nameEnvUniqueElts x      = ufmToList x
extendNameEnv_Acc x y z a b  = addToUFM_Acc x y z a b
extendNameEnvList_C x y z = addListToUFM_C x y z
delFromNameEnv x y      = delFromUFM x y
delListFromNameEnv x y  = delListFromUFM x y
filterNameEnv x y       = filterUFM x y
117 118
anyNameEnv f x          = foldUFM ((||) . f) False x
disjointNameEnv x y     = isNullUFM (intersectUFM x y)
119

120
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)