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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.StgToJS.Deps
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io>
-- Luite Stegeman <luite.stegeman@iohk.io>
-- Sylvain Henry <sylvain.henry@iohk.io>
-- Josh Meredith <josh.meredith@iohk.io>
-- Stability : experimental
--
-- Module to calculate the transitive dependencies of a module
-----------------------------------------------------------------------------
module GHC.StgToJS.Deps
( genDependencyData
)
where
import GHC.Prelude
import GHC.StgToJS.Object as Object
import GHC.StgToJS.Types
import GHC.StgToJS.Ids
import GHC.JS.Syntax
import GHC.Types.Id
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
import Data.Array
import Data.Either
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
data DependencyDataCache = DDC
{ ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit
, ddcId :: !(IntMap Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules)
, ddcOther :: !(Map OtherSymb Object.ExportedFun)
}
-- | Generate module dependency data
--
-- Generate the object's dependency data, taking care that package and module names
-- are only stored once
genDependencyData
:: HasDebugCallStack
=> Module
-> [LinkableUnit]
-> G Object.Deps
genDependencyData mod units = do
-- [(blockindex, blockdeps, required, exported)]
ds <- evalStateT (mapM (uncurry oneDep) blocks)
(DDC IM.empty IM.empty M.empty)
return $ Object.Deps
{ depsModule = mod
, depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ]
, depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds
, depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds)
}
where
-- Id -> Block
unitIdExports :: UniqFM Id Int
unitIdExports = listToUFM $
concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks
-- OtherSymb -> Block
unitOtherExports :: Map OtherSymb Int
unitOtherExports = M.fromList $
concatMap (\(u,n) -> map (,n)
(map (OtherSymb mod)
(luOtherExports u)))
blocks
blocks :: [(LinkableUnit, Int)]
blocks = zip units [0..]
-- generate the list of exports and set of dependencies for one unit
oneDep :: LinkableUnit
-> Int
-> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun])
oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do
(edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
(edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
(edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps
expi <- mapM lookupExportedId (filter isExportedId idExports)
expo <- mapM lookupExportedOther otherExports
-- fixme thin deps, remove all transitive dependencies!
let bdeps = Object.BlockDeps
(IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp)
(S.toList . S.fromList $ edi++edo++edp)
return (n, bdeps, req, expi++expo)
idModule :: Id -> Maybe Module
idModule i = nameModule_maybe (getName i) >>= \m ->
guard (m /= mod) >> return m
lookupPseudoIdFun :: Int -> Unique
-> StateT DependencyDataCache G (Either Object.ExportedFun Int)
lookupPseudoIdFun _n u =
case lookupUFM_Directly unitIdExports u of
Just k -> return (Right k)
_ -> panic "lookupPseudoIdFun"
-- get the function for an Id from the cache, add it if necessary
-- result: Left Object.ExportedFun if function refers to another module
-- Right blockNumber if function refers to current module
--
-- assumes function is internal to the current block if it's
-- from teh current module and not in the unitIdExports map.
lookupIdFun :: Int -> Id
-> StateT DependencyDataCache G (Either Object.ExportedFun Int)
lookupIdFun n i = case lookupUFM unitIdExports i of
Just k -> return (Right k)
Nothing -> case idModule i of
Nothing -> return (Right n)
Just m ->
let k = getKey . getUnique $ i
addEntry :: StateT DependencyDataCache G Object.ExportedFun
addEntry = do
(TxtI idTxt) <- lift (identForId i)
lookupExternalFun (Just k) (OtherSymb m idTxt)
in if m == mod
then pprPanic "local id not found" (ppr m)
else Left <$> do
mr <- gets (IM.lookup k . ddcId)
maybe addEntry return mr
-- get the function for an OtherSymb from the cache, add it if necessary
lookupOtherFun :: OtherSymb
-> StateT DependencyDataCache G (Either Object.ExportedFun Int)
lookupOtherFun od@(OtherSymb m idTxt) =
case M.lookup od unitOtherExports of
Just n -> return (Right n)
Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt)
Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<<
gets (M.lookup od . ddcOther))
lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun
lookupExportedId i = do
(TxtI idTxt) <- lift (identForId i)
lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt)
lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun
lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod
-- lookup a dependency to another module, add to the id cache if there's
-- an id key, otherwise add to other cache
lookupExternalFun :: Maybe Int
-> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun
lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do
let mk = getKey . getUnique $ m
mpk = moduleUnit m
exp_fun = Object.ExportedFun m (LexicalFastString idTxt)
addCache = do
ms <- gets ddcModule
let !cache' = IM.insert mk mpk ms
modify (\s -> s { ddcModule = cache'})
pure exp_fun
f <- do
mbm <- gets (IM.member mk . ddcModule)
case mbm of
False -> addCache
True -> pure exp_fun
case mbIdKey of
Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) })
Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) })
return f
|
