Fix space leak in BinIface.getSymbolTable
[ghc.git] / compiler / iface / BinIface.hs
1 {-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
2
3 --
4 -- (c) The University of Glasgow 2002-2006
5 --
6
7 {-# OPTIONS_GHC -O #-}
8 -- We always optimise this, otherwise performance of a non-optimised
9 -- compiler is severely affected
10
11 -- | Binary interface file support.
12 module BinIface (
13 writeBinIface,
14 readBinIface,
15 getSymtabName,
16 getDictFastString,
17 CheckHiWay(..),
18 TraceBinIFaceReading(..)
19 ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import TcRnMonad
26 import PrelInfo ( isKnownKeyName, lookupKnownKeyName )
27 import IfaceEnv
28 import HscTypes
29 import Module
30 import Name
31 import DynFlags
32 import UniqFM
33 import UniqSupply
34 import Panic
35 import Binary
36 import SrcLoc
37 import ErrUtils
38 import FastMutInt
39 import Unique
40 import Outputable
41 import NameCache
42 import Platform
43 import FastString
44 import Constants
45 import Util
46
47 import Data.Array
48 import Data.Array.ST
49 import Data.Array.Unsafe
50 import Data.Bits
51 import Data.Char
52 import Data.Word
53 import Data.IORef
54 import Data.Foldable
55 import Control.Monad
56 import Control.Monad.ST
57 import Control.Monad.Trans.Class
58 import qualified Control.Monad.Trans.State.Strict as State
59
60 -- ---------------------------------------------------------------------------
61 -- Reading and writing binary interface files
62 --
63
64 data CheckHiWay = CheckHiWay | IgnoreHiWay
65 deriving Eq
66
67 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
68 deriving Eq
69
70 -- | Read an interface file
71 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
72 -> TcRnIf a b ModIface
73 readBinIface checkHiWay traceBinIFaceReading hi_path = do
74 ncu <- mkNameCacheUpdater
75 dflags <- getDynFlags
76 liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
77
78 readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
79 -> NameCacheUpdater
80 -> IO ModIface
81 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
82 let printer :: SDoc -> IO ()
83 printer = case traceBinIFaceReading of
84 TraceBinIFaceReading -> \sd ->
85 putLogMsg dflags
86 NoReason
87 SevOutput
88 noSrcSpan
89 (defaultDumpStyle dflags)
90 sd
91 QuietBinIFaceReading -> \_ -> return ()
92 wantedGot :: Outputable a => String -> a -> a -> IO ()
93 wantedGot what wanted got =
94 printer (text what <> text ": " <>
95 vcat [text "Wanted " <> ppr wanted <> text ",",
96 text "got " <> ppr got])
97
98 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
99 errorOnMismatch what wanted got =
100 -- This will be caught by readIface which will emit an error
101 -- msg containing the iface module name.
102 when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
103 (what ++ " (wanted " ++ show wanted
104 ++ ", got " ++ show got ++ ")")
105 bh <- Binary.readBinMem hi_path
106
107 -- Read the magic number to check that this really is a GHC .hi file
108 -- (This magic number does not change when we change
109 -- GHC interface file format)
110 magic <- get bh
111 wantedGot "Magic" (binaryInterfaceMagic dflags) magic
112 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
113 (binaryInterfaceMagic dflags) magic
114
115 -- Note [dummy iface field]
116 -- read a dummy 32/64 bit value. This field used to hold the
117 -- dictionary pointer in old interface file formats, but now
118 -- the dictionary pointer is after the version (where it
119 -- should be). Also, the serialisation of value of type "Bin
120 -- a" used to depend on the word size of the machine, now they
121 -- are always 32 bits.
122 if wORD_SIZE dflags == 4
123 then do _ <- Binary.get bh :: IO Word32; return ()
124 else do _ <- Binary.get bh :: IO Word64; return ()
125
126 -- Check the interface file version and ways.
127 check_ver <- get bh
128 let our_ver = show hiVersion
129 wantedGot "Version" our_ver check_ver
130 errorOnMismatch "mismatched interface file versions" our_ver check_ver
131
132 check_way <- get bh
133 let way_descr = getWayDescr dflags
134 wantedGot "Way" way_descr check_way
135 when (checkHiWay == CheckHiWay) $
136 errorOnMismatch "mismatched interface file ways" way_descr check_way
137
138 -- Read the dictionary
139 -- The next word in the file is a pointer to where the dictionary is
140 -- (probably at the end of the file)
141 dict_p <- Binary.get bh
142 data_p <- tellBin bh -- Remember where we are now
143 seekBin bh dict_p
144 dict <- getDictionary bh
145 seekBin bh data_p -- Back to where we were before
146
147 -- Initialise the user-data field of bh
148 bh <- do
149 bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
150 (getDictFastString dict)
151 symtab_p <- Binary.get bh -- Get the symtab ptr
152 data_p <- tellBin bh -- Remember where we are now
153 seekBin bh symtab_p
154 symtab <- getSymbolTable bh ncu
155 seekBin bh data_p -- Back to where we were before
156
157 -- It is only now that we know how to get a Name
158 return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
159 (getDictFastString dict)
160
161 -- Read the interface file
162 get bh
163
164 -- | Write an interface file
165 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
166 writeBinIface dflags hi_path mod_iface = do
167 bh <- openBinMem initBinMemSize
168 put_ bh (binaryInterfaceMagic dflags)
169
170 -- dummy 32/64-bit field before the version/way for
171 -- compatibility with older interface file formats.
172 -- See Note [dummy iface field] above.
173 if wORD_SIZE dflags == 4
174 then Binary.put_ bh (0 :: Word32)
175 else Binary.put_ bh (0 :: Word64)
176
177 -- The version and way descriptor go next
178 put_ bh (show hiVersion)
179 let way_descr = getWayDescr dflags
180 put_ bh way_descr
181
182 -- Remember where the dictionary pointer will go
183 dict_p_p <- tellBin bh
184 -- Placeholder for ptr to dictionary
185 put_ bh dict_p_p
186
187 -- Remember where the symbol table pointer will go
188 symtab_p_p <- tellBin bh
189 put_ bh symtab_p_p
190
191 -- Make some intial state
192 symtab_next <- newFastMutInt
193 writeFastMutInt symtab_next 0
194 symtab_map <- newIORef emptyUFM
195 let bin_symtab = BinSymbolTable {
196 bin_symtab_next = symtab_next,
197 bin_symtab_map = symtab_map }
198 dict_next_ref <- newFastMutInt
199 writeFastMutInt dict_next_ref 0
200 dict_map_ref <- newIORef emptyUFM
201 let bin_dict = BinDictionary {
202 bin_dict_next = dict_next_ref,
203 bin_dict_map = dict_map_ref }
204
205 -- Put the main thing,
206 bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
207 (putName bin_dict bin_symtab)
208 (putFastString bin_dict)
209 put_ bh mod_iface
210
211 -- Write the symtab pointer at the front of the file
212 symtab_p <- tellBin bh -- This is where the symtab will start
213 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
214 seekBin bh symtab_p -- Seek back to the end of the file
215
216 -- Write the symbol table itself
217 symtab_next <- readFastMutInt symtab_next
218 symtab_map <- readIORef symtab_map
219 putSymbolTable bh symtab_next symtab_map
220 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
221 <+> text "Names")
222
223 -- NB. write the dictionary after the symbol table, because
224 -- writing the symbol table may create more dictionary entries.
225
226 -- Write the dictionary pointer at the fornt of the file
227 dict_p <- tellBin bh -- This is where the dictionary will start
228 putAt bh dict_p_p dict_p -- Fill in the placeholder
229 seekBin bh dict_p -- Seek back to the end of the file
230
231 -- Write the dictionary itself
232 dict_next <- readFastMutInt dict_next_ref
233 dict_map <- readIORef dict_map_ref
234 putDictionary bh dict_next dict_map
235 debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
236 <+> text "dict entries")
237
238 -- And send the result to the file
239 writeBinMem bh hi_path
240
241 -- | Initial ram buffer to allocate for writing interface files
242 initBinMemSize :: Int
243 initBinMemSize = 1024 * 1024
244
245 binaryInterfaceMagic :: DynFlags -> Word32
246 binaryInterfaceMagic dflags
247 | target32Bit (targetPlatform dflags) = 0x1face
248 | otherwise = 0x1face64
249
250
251 -- -----------------------------------------------------------------------------
252 -- The symbol table
253 --
254
255 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
256 putSymbolTable bh next_off symtab = do
257 put_ bh next_off
258 let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
259 -- It's OK to use nonDetEltsUFM here because the elements have
260 -- indices that array uses to create order
261 mapM_ (\n -> serialiseName bh n symtab) names
262
263 getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
264 getSymbolTable bh ncu = do
265 sz <- get bh
266 od_names <- sequence (replicate sz (get bh))
267 updateNameCache ncu $ \namecache ->
268 runST $ flip State.evalStateT namecache $ do
269 mut_arr <- lift $ newSTArray_ (0, sz-1)
270 for_ (zip [0..] od_names) $ \(i, odn) -> do
271 (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
272 lift $ writeArray mut_arr i n
273 State.put nc
274 arr <- lift $ unsafeFreeze mut_arr
275 namecache' <- State.get
276 return (namecache', arr)
277 where
278 -- This binding is required because the type of newArray_ cannot be inferred
279 newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
280 newSTArray_ = newArray_
281
282 type OnDiskName = (UnitId, ModuleName, OccName)
283
284 fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
285 fromOnDiskName nc (pid, mod_name, occ) =
286 let mod = mkModule pid mod_name
287 cache = nsNames nc
288 in case lookupOrigNameCache cache mod occ of
289 Just name -> (nc, name)
290 Nothing ->
291 let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
292 name = mkExternalName uniq mod occ noSrcSpan
293 new_cache = extendNameCache cache mod occ name
294 in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
295
296 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
297 serialiseName bh name _ = do
298 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
299 put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
300
301
302 -- Note [Symbol table representation of names]
303 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
304 --
305 -- An occurrence of a name in an interface file is serialized as a single 32-bit
306 -- word. The format of this word is:
307 -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
308 -- A normal name. x is an index into the symbol table
309 -- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
310 -- A known-key name. x is the Unique's Char, y is the int part. We assume that
311 -- all known-key uniques fit in this space. This is asserted by
312 -- PrelInfo.knownKeyNamesOkay.
313 --
314 -- During serialization we check for known-key things using isKnownKeyName.
315 -- During deserialization we use lookupKnownKeyName to get from the unique back
316 -- to its corresponding Name.
317
318
319 -- See Note [Symbol table representation of names]
320 putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
321 putName _dict BinSymbolTable{
322 bin_symtab_map = symtab_map_ref,
323 bin_symtab_next = symtab_next }
324 bh name
325 | isKnownKeyName name
326 , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
327 = -- ASSERT(u < 2^(22 :: Int))
328 put_ bh (0x80000000
329 .|. (fromIntegral (ord c) `shiftL` 22)
330 .|. (fromIntegral u :: Word32))
331
332 | otherwise
333 = do symtab_map <- readIORef symtab_map_ref
334 case lookupUFM symtab_map name of
335 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
336 Nothing -> do
337 off <- readFastMutInt symtab_next
338 -- MASSERT(off < 2^(30 :: Int))
339 writeFastMutInt symtab_next (off+1)
340 writeIORef symtab_map_ref
341 $! addToUFM symtab_map name (off,name)
342 put_ bh (fromIntegral off :: Word32)
343
344 -- See Note [Symbol table representation of names]
345 getSymtabName :: NameCacheUpdater
346 -> Dictionary -> SymbolTable
347 -> BinHandle -> IO Name
348 getSymtabName _ncu _dict symtab bh = do
349 i :: Word32 <- get bh
350 case i .&. 0xC0000000 of
351 0x00000000 -> return $! symtab ! fromIntegral i
352
353 0x80000000 ->
354 let
355 tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
356 ix = fromIntegral i .&. 0x003FFFFF
357 u = mkUnique tag ix
358 in
359 return $! case lookupKnownKeyName u of
360 Nothing -> pprPanic "getSymtabName:unknown known-key unique"
361 (ppr i $$ ppr (unpkUnique u))
362 Just n -> n
363
364 _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
365
366 data BinSymbolTable = BinSymbolTable {
367 bin_symtab_next :: !FastMutInt, -- The next index to use
368 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
369 -- indexed by Name
370 }
371
372 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
373 putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
374
375 allocateFastString :: BinDictionary -> FastString -> IO Word32
376 allocateFastString BinDictionary { bin_dict_next = j_r,
377 bin_dict_map = out_r} f = do
378 out <- readIORef out_r
379 let uniq = getUnique f
380 case lookupUFM out uniq of
381 Just (j, _) -> return (fromIntegral j :: Word32)
382 Nothing -> do
383 j <- readFastMutInt j_r
384 writeFastMutInt j_r (j + 1)
385 writeIORef out_r $! addToUFM out uniq (j, f)
386 return (fromIntegral j :: Word32)
387
388 getDictFastString :: Dictionary -> BinHandle -> IO FastString
389 getDictFastString dict bh = do
390 j <- get bh
391 return $! (dict ! fromIntegral (j :: Word32))
392
393 data BinDictionary = BinDictionary {
394 bin_dict_next :: !FastMutInt, -- The next index to use
395 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
396 -- indexed by FastString
397 }
398
399 getWayDescr :: DynFlags -> String
400 getWayDescr dflags
401 | platformUnregisterised (targetPlatform dflags) = 'u':tag
402 | otherwise = tag
403 where tag = buildTag dflags
404 -- if this is an unregisterised build, make sure our interfaces
405 -- can't be used by a registerised build.