import Unique
import Outputable
import FastString
+import Constants
import Data.List
import Data.Word
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
- nc <- getNameCache
- (new_nc, iface) <- liftIO $
- readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
- setNameCache new_nc
- return iface
-
-readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
- -> IO (NameCache, ModIface)
-readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
+ update_nc <- mkNameCacheUpdater
+ dflags <- getDOpts
+ liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> NameCacheUpdater (Array Int Name)
+ -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
binaryInterfaceMagic magic
- -- Get the dictionary pointer. We won't attempt to actually
- -- read the dictionary until we've done the version checks below,
- -- just in case this isn't a valid interface. In retrospect the
- -- version should have come before the dictionary pointer, but this
- -- is the way it was done originally, and we can't change it now.
- dict_p <- Binary.get bh -- Get the dictionary ptr
+ -- Note [dummy iface field]
+ -- read a dummy 32/64 bit value. This field used to hold the
+ -- dictionary pointer in old interface file formats, but now
+ -- the dictionary pointer is after the version (where it
+ -- should be). Also, the serialisation of value of type "Bin
+ -- a" used to depend on the word size of the machine, now they
+ -- are always 32 bits.
+ --
+ if wORD_SIZE == 4
+ then do _ <- Binary.get bh :: IO Word32; return ()
+ else do _ <- Binary.get bh :: IO Word64; return ()
-- Check the interface file version and ways.
check_ver <- get bh
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
+ dict_p <- Binary.get bh
data_p <- tellBin bh -- Remember where we are now
seekBin bh dict_p
dict <- getDictionary bh
symtab_p <- Binary.get bh -- Get the symtab ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh symtab_p
- (nc', symtab) <- getSymbolTable bh nc
+ symtab <- getSymbolTable bh update_nc
seekBin bh data_p -- Back to where we were before
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
- return (nc', iface)
+ return iface
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
bh <- openBinMem initBinMemSize
put_ bh binaryInterfaceMagic
- -- Remember where the dictionary pointer will go
- dict_p_p <- tellBin bh
- put_ bh dict_p_p -- Placeholder for ptr to dictionary
+ -- dummy 32/64-bit field before the version/way for
+ -- compatibility with older interface file formats.
+ -- See Note [dummy iface field] above.
+ if wORD_SIZE == 4
+ then Binary.put_ bh (0 :: Word32)
+ else Binary.put_ bh (0 :: Word64)
-- The version and way descriptor go next
put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
put_ bh way_descr
+ -- Remember where the dictionary pointer will go
+ dict_p_p <- tellBin bh
+ put_ bh dict_p_p -- Placeholder for ptr to dictionary
+
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
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
+getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
+ -> IO (Array Int Name)
+getSymbolTable bh update_namecache = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
- let
+ update_namecache $ \namecache ->
+ let
arr = listArray (0,sz-1) names
(namecache', names) =
mapAccumR (fromOnDiskName arr) namecache od_names
- --
- return (namecache', arr)
+ in (namecache', arr)
type OnDiskName = (PackageId, ModuleName, OccName)
= do
symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh off
+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
- put_ bh off
+ put_ bh (fromIntegral off :: Word32)
data BinSymbolTable = BinSymbolTable {
out <- readIORef out_r
let uniq = getUnique f
case lookupUFM out uniq of
- Just (j, _) -> put_ bh j
+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
- put_ bh j
+ put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out uniq (j, f)
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
-getWayDescr :: IO String
-getWayDescr = do
- tag <- readIORef v_Build_tag
- if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+ | cGhcUnregisterised == "YES" = 'u':tag
+ | otherwise = tag
+ where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
+ put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
-- Generic cases
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+ 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
_ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
put_ bh IfaceArgTypeKindTc = putByte bh 10
put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
+ put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
get bh = do
h <- getByte bh
9 -> return IfaceUbxTupleKindTc
10 -> return IfaceArgTypeKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
- _ -> do { ext <- get bh; return (IfaceTc ext) }
+ 12 -> do { ext <- get bh; return (IfaceTc ext) }
+ _ -> do { k <- get bh; return (IfaceAnyTc k) }
instance Binary IfacePredType where
put_ bh (IfaceClassP aa ab) = do
projects / ghc-hetmet.git / blobdiff