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
192
193
194
195
|
module Haddock.InterfaceFile (
InterfaceFile(..),
writeInterfaceFile,
readInterfaceFile,
hmod2interface
) where
import Haddock.Types
import Haddock.Exception
import Data.List
import Data.Word
import Data.Array
import Data.IORef
import qualified Data.Map as Map
import System.IO
import Control.Monad
import Binary
import Name
import UniqSupply
import UniqFM
import IfaceEnv
import Module
import Packages
import SrcLoc
import HscTypes
import FastMutInt
import InstEnv
import HsDoc
data InterfaceMod = InterfaceMod {
imModule :: Module,
imFilename :: FilePath,
imExportItems :: [ExportItem DocName]
}
data InterfaceFile = InterfaceFile {
ifDocEnv :: DocEnv
-- ifModules :: [InterfaceMod]
}
instance Binary InterfaceFile where
put_ bh (InterfaceFile x) = put_ bh (Map.toList x)
get bh = do
env <- get bh
return (InterfaceFile (Map.fromList env))
hmod2interface hmod = InterfaceMod {
imModule = hmod_mod hmod,
imFilename = hmod_orig_filename hmod,
imExportItems = hmod_rn_export_items hmod
}
binaryInterfaceMagic = 0xD0Cface :: Word32
binaryInterfaceVersion = 0 :: Word16
initBinMemSize = (1024*1024) :: Int
writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
writeInterfaceFile filename iface = do
bh <- openBinMem initBinMemSize
put_ bh binaryInterfaceMagic
put_ bh binaryInterfaceVersion
-- remember where the dictionary pointer will go
dict_p_p <- tellBin bh
put_ bh dict_p_p
-- remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
-- Make some intial state
ud <- newWriteState
-- put the main thing
bh <- return $ setUserData bh ud
put_ bh iface
-- write the symtab pointer at the fornt of the file
symtab_p <- tellBin bh
putAt bh symtab_p_p symtab_p
seekBin bh symtab_p
-- write the symbol table itself
symtab_next <- readFastMutInt (ud_symtab_next ud)
symtab_map <- readIORef (ud_symtab_map ud)
putSymbolTable bh symtab_next symtab_map
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt (ud_dict_next ud)
dict_map <- readIORef (ud_dict_map ud)
putDictionary bh dict_next dict_map
-- snd send the result to the file
writeBinMem bh filename
return ()
readInterfaceFile :: FilePath -> IO InterfaceFile
readInterfaceFile filename = do
bh <- readBinMem filename
magic <- get bh
when (magic /= binaryInterfaceMagic) $ throwE $
"Magic number mismatch: couldn't load interface file: " ++ filename
version <- get bh
when (version /= binaryInterfaceVersion) $ throwE $
"Interface file is of wrong version: " ++ filename
-- get the dictionary
dict_p <- get bh
data_p <- tellBin bh
seekBin bh dict_p
dict <- getDictionary bh
seekBin bh data_p
-- initialise the user-data field of bh
ud <- newReadState dict
bh <- return (setUserData bh ud)
-- get the symbol table
symtab_p <- get bh
data_p <- tellBin bh
seekBin bh symtab_p
-- (construct an empty name cache)
u <- mkSplitUniqSupply 'a' -- ??
let nc = initNameCache u []
(_, symtab) <- getSymbolTable bh nc
seekBin bh data_p
-- set the symbol table
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
-- load the actual data
iface <- get bh
return iface
-------------------------------------------------------------------------------
-- Symbol table
-------------------------------------------------------------------------------
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
getSymbolTable bh namecache = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
let
arr = listArray (0,sz-1) names
(namecache', names) =
mapAccumR (fromOnDiskName arr) namecache od_names
--
return (namecache', arr)
type OnDiskName = (PackageId, ModuleName, OccName)
fromOnDiskName
:: Array Int Name
-> NameCache
-> OnDiskName
-> (NameCache, Name)
fromOnDiskName arr nc (pid, mod_name, occ) =
let
mod = mkModule pid mod_name
cache = nsNames nc
in
case lookupOrigNameCache cache mod occ of
Just name -> (nc, name)
Nothing ->
let
us = nsUniqs nc
uniq = uniqFromSupply us
name = mkExternalName uniq mod occ noSrcLoc
new_cache = extendNameCache cache mod occ name
in
case splitUniqSupply us of { (us',_) ->
( nc{ nsUniqs = us', nsNames = new_cache }, name )
}
serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName bh name symtab = do
let mod = nameModule name
put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
|
