NameEnv.hs 5.05 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 26 27 28 29
        DNameEnv,

        emptyDNameEnv,
        lookupDNameEnv,
        mapDNameEnv,
        alterDNameEnv,
30 31
        -- ** Dependency analysis
        depAnal
32 33 34 35
    ) where

#include "HsVersions.h"

36
import Digraph
Simon Marlow's avatar
Simon Marlow committed
37
import Name
38
import Unique
39
import UniqFM
40
import UniqDFM
Simon Marlow's avatar
Simon Marlow committed
41
import Maybes
42

Austin Seipp's avatar
Austin Seipp committed
43 44 45
{-
************************************************************************
*                                                                      *
46
\subsection{Name environment}
Austin Seipp's avatar
Austin Seipp committed
47 48 49
*                                                                      *
************************************************************************
-}
50

51
depAnal :: (node -> [Name])      -- Defs
52 53 54 55 56 57 58 59 60 61 62
        -> (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
63
    mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))
64 65

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

Austin Seipp's avatar
Austin Seipp committed
68 69 70
{-
************************************************************************
*                                                                      *
71
\subsection{Name environment}
Austin Seipp's avatar
Austin Seipp committed
72 73 74
*                                                                      *
************************************************************************
-}
75

76
type NameEnv a = UniqFM a       -- Domain is Name
77

78
emptyNameEnv       :: NameEnv a
79
isEmptyNameEnv     :: NameEnv a -> Bool
80 81
mkNameEnv          :: [(Name,a)] -> NameEnv a
nameEnvElts        :: NameEnv a -> [a]
82
nameEnvUniqueElts  :: NameEnv a -> [(Unique, a)]
83
alterNameEnv       :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
84
extendNameEnv_C    :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
85
extendNameEnv_Acc  :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b
86 87 88
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
89
extendNameEnvList  :: NameEnv a -> [(Name,a)] -> NameEnv a
Simon Marlow's avatar
Simon Marlow committed
90
extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a
91
delFromNameEnv     :: NameEnv a -> Name -> NameEnv a
92
delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a
93 94 95
elemNameEnv        :: Name -> NameEnv a -> Bool
unitNameEnv        :: Name -> a -> NameEnv a
lookupNameEnv      :: NameEnv a -> Name -> Maybe a
96
lookupNameEnv_NF   :: NameEnv a -> Name -> a
97
filterNameEnv      :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
98
anyNameEnv         :: (elt -> Bool) -> NameEnv elt -> Bool
99
mapNameEnv         :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
100
disjointNameEnv    :: NameEnv a -> NameEnv a -> Bool
101

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

125
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142

-- Deterministic NameEnv
-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need
-- DNameEnv.
type DNameEnv a = UniqDFM a

emptyDNameEnv :: DNameEnv a
emptyDNameEnv = emptyUDFM

lookupDNameEnv :: DNameEnv a -> Name -> Maybe a
lookupDNameEnv = lookupUDFM

mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b
mapDNameEnv = mapUDFM

alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a
alterDNameEnv = alterUDFM