X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=bea0de13f12b54e9bc21dd9eb4e331f687f1c7dd;hp=d47398cb14c1503609e4d15a80c95854b1ac36bb;hb=6777144f7522d8db5935737e12fa451ca3211e6d;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index d47398c..bea0de1 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -62,10 +62,36 @@ readBinIface_ hi_path nc = do throwDyn (ProgramError ( "magic number mismatch: old/corrupt interface file?")) + -- 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 + + -- Check the interface file version and ways. + check_ver <- get bh + let our_ver = show opt_HiVersion + when (check_ver /= our_ver) $ + -- This will be caught by readIface which will emit an error + -- msg containing the iface module name. + throwDyn (ProgramError ( + "mismatched interface file versions: expected " + ++ our_ver ++ ", found " ++ check_ver)) + + check_way <- get bh + ignore_way <- readIORef v_IgnoreHiWay + way_descr <- getWayDescr + when (not ignore_way && check_way /= way_descr) $ + -- This will be caught by readIface + -- which will emit an error msg containing the iface module name. + throwDyn (ProgramError ( + "mismatched interface file ways: expected " + ++ way_descr ++ ", found " ++ 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 -- Get the dictionary ptr data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh @@ -95,6 +121,11 @@ writeBinIface dflags hi_path mod_iface = do dict_p_p <- tellBin bh put_ bh dict_p_p -- Placeholder for ptr to dictionary + -- The version and way descriptor go next + put_ bh (show opt_HiVersion) + way_descr <- getWayDescr + put bh way_descr + -- Remember where the symbol table pointer will go symtab_p_p <- tellBin bh put_ bh symtab_p_p @@ -185,7 +216,7 @@ fromOnDiskName arr nc (pid, mod_name, occ) = let us = nsUniqs nc uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache cache mod occ name in case splitUniqSupply us of { (us',_) -> @@ -251,6 +282,7 @@ instance Binary ModIface where mi_boot = is_boot, mi_mod_vers = mod_vers, mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -261,14 +293,13 @@ instance Binary ModIface where mi_insts = insts, mi_fam_insts = fam_insts, mi_rules = rules, - mi_rule_vers = rule_vers }) = do - put_ bh (show opt_HiVersion) - way_descr <- getWayDescr - put bh way_descr + mi_rule_vers = rule_vers, + mi_vect_info = vect_info }) = do put_ bh mod put_ bh is_boot put_ bh mod_vers put_ bh orphan + put_ bh hasFamInsts lazyPut bh deps lazyPut bh usages put_ bh exports @@ -280,31 +311,14 @@ instance Binary ModIface where put_ bh fam_insts lazyPut bh rules put_ bh rule_vers + put_ bh vect_info get bh = do - check_ver <- get bh - let our_ver = show opt_HiVersion - when (check_ver /= our_ver) $ - -- use userError because this will be caught by readIface - -- which will emit an error msg containing the iface module name. - throwDyn (ProgramError ( - "mismatched interface file versions: expected " - ++ our_ver ++ ", found " ++ check_ver)) - - check_way <- get bh - ignore_way <- readIORef v_IgnoreHiWay - way_descr <- getWayDescr - when (not ignore_way && check_way /= way_descr) $ - -- use userError because this will be caught by readIface - -- which will emit an error msg containing the iface module name. - throwDyn (ProgramError ( - "mismatched interface file ways: expected " - ++ way_descr ++ ", found " ++ check_way)) - mod_name <- get bh is_boot <- get bh mod_vers <- get bh orphan <- get bh + hasFamInsts <- get bh deps <- lazyGet bh usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh @@ -316,11 +330,13 @@ instance Binary ModIface where fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh + vect_info <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, mi_mod_vers = mod_vers, mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -333,6 +349,7 @@ instance Binary ModIface where mi_fam_insts = fam_insts, mi_rules = rules, mi_rule_vers = rule_vers, + mi_vect_info = vect_info, -- And build the cached values mi_dep_fn = mkIfaceDepCache deprecs, mi_fix_fn = mkIfaceFixCache fixities, @@ -355,11 +372,14 @@ instance Binary Dependencies where put_ bh deps = do put_ bh (dep_mods deps) put_ bh (dep_pkgs deps) put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) get bh = do ms <- get bh ps <- get bh os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) instance (Binary name) => Binary (GenAvailInfo name) where put_ bh (Avail aa) = do @@ -674,6 +694,16 @@ instance Binary IfaceBndr where _ -> do ab <- get bh return (IfaceTvBndr ab) +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) + instance Binary IfaceType where put_ bh (IfaceForAllTy aa ab) = do putByte bh 0 @@ -1004,7 +1034,6 @@ instance Binary IfaceNote where 4 -> do ac <- get bh return (IfaceCoreNote ac) - ------------------------------------------------------------------------- -- IfaceDecl and friends ------------------------------------------------------------------------- @@ -1123,18 +1152,16 @@ instance Binary OverlapFlag where instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 put_ bh IfOpenDataTyCon = putByte bh 1 - put_ bh IfOpenNewTyCon = putByte bh 2 - put_ bh (IfDataTyCon cs) = do { putByte bh 3 + put_ bh (IfDataTyCon cs) = do { putByte bh 2 ; put_ bh cs } - put_ bh (IfNewTyCon c) = do { putByte bh 4 + put_ bh (IfNewTyCon c) = do { putByte bh 3 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon 1 -> return IfOpenDataTyCon - 2 -> return IfOpenNewTyCon - 3 -> do cs <- get bh + 2 -> do cs <- get bh return (IfDataTyCon cs) _ -> do aa <- get bh return (IfNewTyCon aa) @@ -1192,4 +1219,11 @@ instance Binary IfaceRule where a7 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6 a7) +instance Binary IfaceVectInfo where + put_ bh (IfaceVectInfo a1) = do + put_ bh a1 + get bh = do + a1 <- get bh + return (IfaceVectInfo a1) +