NameEnv.hs 4.49 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,
niteria's avatar
niteria committed
19
        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
filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
91
anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool
92
mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
93
disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool
94

95
nameEnvElts x         = eltsUFM x
96
emptyNameEnv          = emptyUFM
97
isEmptyNameEnv        = isNullUFM
98
unitNameEnv x y       = unitUFM x y
99 100 101
extendNameEnv x y z   = addToUFM x y z
extendNameEnvList x l = addListToUFM x l
lookupNameEnv x y     = lookupUFM x y
102
alterNameEnv          = alterUFM
103
mkNameEnv     l       = listToUFM l
104 105 106
elemNameEnv x y          = elemUFM x y
plusNameEnv x y          = plusUFM x y
plusNameEnv_C f x y      = plusUFM_C f x y
107
extendNameEnv_C f x y z  = addToUFM_C f x y z
108
mapNameEnv f x           = mapUFM f x
109 110 111 112 113 114
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
115 116
anyNameEnv f x          = foldUFM ((||) . f) False x
disjointNameEnv x y     = isNullUFM (intersectUFM x y)
117

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