projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Refactor some code a bit, and improve an error
[ghc-hetmet.git]
/
compiler
/
iface
/
MkIface.lhs
diff --git
a/compiler/iface/MkIface.lhs
b/compiler/iface/MkIface.lhs
index
e335f75
..
e89d8be
100644
(file)
--- a/
compiler/iface/MkIface.lhs
+++ b/
compiler/iface/MkIface.lhs
@@
-181,6
+181,10
@@
code of A, and thereby haul in all the stuff reachable from it.
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O. I think this is the case.]
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O. I think this is the case.]
+SimonM [30/11/2007]: I believe the above is all out of date; the
+current implementation doesn't do it this way. Instead, when any of
+the dependencies of a declaration changes, the version of the
+declaration itself changes.
\begin{code}
#include "HsVersions.h"
\begin{code}
#include "HsVersions.h"
@@
-219,7
+223,7
@@
import SrcLoc
import PackageConfig hiding ( Version )
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
import PackageConfig hiding ( Version )
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
-import UniqFM
+import LazyUniqFM
import Util hiding ( eqListBy )
import FiniteMap
import FastString
import Util hiding ( eqListBy )
import FiniteMap
import FastString
@@
-229,6
+233,7
@@
import ListSetOps
import Control.Monad
import Data.List
import Data.IORef
import Control.Monad
import Data.List
import Data.IORef
+import System.FilePath
\end{code}
\end{code}
@@
-409,7
+414,7
@@
mkIface_ hsc_env maybe_old_iface
mi_fix_fn = mkIfaceFixCache fixities }
-- Add version information
mi_fix_fn = mkIfaceFixCache fixities }
-- Add version information
- ; ext_ver_fn = mkParentVerFun hsc_env eps
+ ; ext_ver_fn = mkParentVerFun hsc_env eps
; (new_iface, no_change_at_all, pp_diffs, pp_orphs)
= {-# SCC "versioninfo" #-}
addVersionInfo ext_ver_fn maybe_old_iface
; (new_iface, no_change_at_all, pp_diffs, pp_orphs)
= {-# SCC "versioninfo" #-}
addVersionInfo ext_ver_fn maybe_old_iface
@@
-461,7
+466,7
@@
mkIface_ hsc_env maybe_old_iface
-----------------------------
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
-----------------------------
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
- = do createDirectoryHierarchy (directoryOf hi_file_path)
+ = do createDirectoryHierarchy (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
@@
-513,7
+518,7
@@
addVersionInfo ver_fn Nothing new_iface new_decls
new_decls)
},
False,
new_decls)
},
False,
- ptext SLIT("No old interface file"),
+ ptext (sLit "No old interface file"),
pprOrphans orph_insts orph_rules)
where
orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
pprOrphans orph_insts orph_rules)
where
orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
@@
-529,9
+534,9
@@
addVersionInfo ver_fn (Just old_iface@(ModIface {
new_iface@(ModIface { mi_fix_fn = new_fixities })
new_decls
| no_change_at_all
new_iface@(ModIface { mi_fix_fn = new_fixities })
new_decls
| no_change_at_all
- = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs)
+ = (old_iface, True, ptext (sLit "Interface file unchanged"), pp_orphs)
| otherwise
| otherwise
- = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
+ = (final_iface, False, vcat [ptext (sLit "Interface file has changed"),
nest 2 pp_diffs], pp_orphs)
where
final_iface = new_iface {
nest 2 pp_diffs], pp_orphs)
where
final_iface = new_iface {
@@
-589,7
+594,7
@@
addVersionInfo ver_fn (Just old_iface@(ModIface {
pp_change no_other_changes "Usages" empty,
pp_decl_diffs]
pp_change True what info = empty
pp_change no_other_changes "Usages" empty,
pp_decl_diffs]
pp_change True what info = empty
- pp_change False what info = text what <+> ptext SLIT("changed") <+> info
+ pp_change False what info = text what <+> ptext (sLit "changed") <+> info
-------------------
old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
-------------------
old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
@@
-651,8
+656,8
@@
addVersionInfo ver_fn (Just old_iface@(ModIface {
pp_decl_diffs
| isEmptyOccSet changed_occs = empty
| otherwise
pp_decl_diffs
| isEmptyOccSet changed_occs = empty
| otherwise
- = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs),
- ptext SLIT("Version change for these decls:"),
+ = vcat [ptext (sLit "Changed occs:") <+> ppr (occSetElts changed_occs),
+ ptext (sLit "Version change for these decls:"),
nest 2 (vcat (map show_change new_decls))]
eq_env = mkOccEnv eq_info
nest 2 (vcat (map show_change new_decls))]
eq_env = mkOccEnv eq_info
@@
-664,16
+669,16
@@
addVersionInfo ver_fn (Just old_iface@(ModIface {
where
occ = ifName new_decl
why = case lookupOccEnv eq_env occ of
where
occ = ifName new_decl
why = case lookupOccEnv eq_env occ of
- Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names,
+ Just (EqBut names) -> sep [ppr occ <> colon, ptext (sLit "Free vars (only) changed:") <> ppr names,
nest 2 (braces (fsep (map ppr (occSetElts
(occs `intersectOccSet` changed_occs)))))]
where occs = mkOccSet (map nameOccName (nameSetToList names))
Just NotEqual
| Just old_decl <- lookupOccEnv old_decl_env occ
nest 2 (braces (fsep (map ppr (occSetElts
(occs `intersectOccSet` changed_occs)))))]
where occs = mkOccSet (map nameOccName (nameSetToList names))
Just NotEqual
| Just old_decl <- lookupOccEnv old_decl_env occ
- -> vcat [ptext SLIT("Old:") <+> ppr old_decl,
- ptext SLIT("New:") <+> ppr new_decl]
+ -> vcat [ptext (sLit "Old:") <+> ppr old_decl,
+ ptext (sLit "New:") <+> ppr new_decl]
| otherwise
| otherwise
- -> ppr occ <+> ptext SLIT("only in new interface")
+ -> ppr occ <+> ptext (sLit "only in new interface")
other -> pprPanic "MkIface.show_change" (ppr occ)
pp_orphs = pprOrphans new_orph_insts new_orph_rules
other -> pprPanic "MkIface.show_change" (ppr occ)
pp_orphs = pprOrphans new_orph_insts new_orph_rules
@@
-684,10
+689,10
@@
pprOrphans insts rules
| otherwise
= Just $ vcat [
if null insts then empty else
| otherwise
= Just $ vcat [
if null insts then empty else
- hang (ptext SLIT("Warning: orphan instances:"))
+ hang (ptext (sLit "Warning: orphan instances:"))
2 (vcat (map ppr insts)),
if null rules then empty else
2 (vcat (map ppr insts)),
if null rules then empty else
- hang (ptext SLIT("Warning: orphan rules:"))
+ hang (ptext (sLit "Warning: orphan rules:"))
2 (vcat (map ppr rules))
]
2 (vcat (map ppr rules))
]
@@
-704,11
+709,13
@@
computeChangedOccs ver_fn this_module old_usages eq_info
-- return True if an external name has changed
name_changed :: Name -> Bool
name_changed nm
-- return True if an external name has changed
name_changed :: Name -> Bool
name_changed nm
+ | isWiredInName nm -- Wired-in things don't get into interface
+ = False -- files and hence don't get into the ver_fn
| Just ents <- lookupUFM usg_modmap (moduleName mod),
Just v <- lookupUFM ents parent_occ
= v < new_version
| modulePackageId mod == this_pkg
| Just ents <- lookupUFM usg_modmap (moduleName mod),
Just v <- lookupUFM ents parent_occ
= v < new_version
| modulePackageId mod == this_pkg
- = WARN(True, ptext SLIT("computeChangedOccs") <+> ppr nm) True
+ = WARN(True, ptext (sLit "computeChangedOccs") <+> ppr nm) True
-- should really be a panic, see #1959. The problem is that the usages doesn't
-- contain all the names that might be referred to by unfoldings. So as a
-- conservative workaround we just assume these names have changed.
-- should really be a panic, see #1959. The problem is that the usages doesn't
-- contain all the names that might be referred to by unfoldings. So as a
-- conservative workaround we just assume these names have changed.
@@
-723,7
+730,7
@@
computeChangedOccs ver_fn this_module old_usages eq_info
usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
| usg <- old_usages ]
usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
| usg <- old_usages ]
- get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet
+ get_local_eq_info :: GenIfaceEq Name -> GenIfaceEq OccName
get_local_eq_info Equal = Equal
get_local_eq_info NotEqual = NotEqual
get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
get_local_eq_info Equal = Equal
get_local_eq_info NotEqual = NotEqual
get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
@@
-753,12
+760,7
@@
computeChangedOccs ver_fn this_module old_usages eq_info
where (occs, iface_eqs) = unzip pairs
add_changes so_far other = so_far
where (occs, iface_eqs) = unzip pairs
add_changes so_far other = so_far
-type OccIfaceEq = GenIfaceEq OccSet
-
-instance Outputable OccIfaceEq where
- ppr Equal = ptext SLIT("Equal")
- ppr NotEqual = ptext SLIT("NotEqual")
- ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset)
+type OccIfaceEq = GenIfaceEq OccName
changedWrt :: OccSet -> OccIfaceEq -> Bool
changedWrt so_far Equal = False
changedWrt :: OccSet -> OccIfaceEq -> Bool
changedWrt so_far Equal = False
@@
-996,7
+998,7
@@
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
= do -- CHECK WHETHER THE SOURCE HAS CHANGED
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
= do -- CHECK WHETHER THE SOURCE HAS CHANGED
- { ifM (not source_unchanged)
+ { when (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- If the source has changed and we're in interactive mode, avoid reading
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- If the source has changed and we're in interactive mode, avoid reading
@@
-1028,7
+1030,7
@@
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
-- We have got the old iface; check its versions
{ traceIf (text "Read the interface file" <+> text iface_path)
; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
-- We have got the old iface; check its versions
{ traceIf (text "Read the interface file" <+> text iface_path)
; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
- ; returnM (recomp, Just iface)
+ ; return (recomp, Just iface)
}}}}}
\end{code}
}}}}}
\end{code}
@@
-1050,7
+1052,7
@@
checkVersions :: HscEnv
-> IfG RecompileRequired
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
-> IfG RecompileRequired
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
- = returnM outOfDate
+ = return outOfDate
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
@@
-1104,7
+1106,7
@@
checkDependencies hsc_env summary iface
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ mod) = do
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ mod) = do
- find_res <- ioToIOEnv $ findImportedModule hsc_env mod Nothing
+ find_res <- liftIO $ findImportedModule hsc_env mod Nothing
case find_res of
Found _ mod
| pkg == this_pkg
case find_res of
Found _ mod
| pkg == this_pkg
@@
-1136,21
+1138,18
@@
checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
usg_rules = old_rule_vers,
usg_exports = maybe_old_export_vers,
usg_entities = old_decl_vers })
usg_rules = old_rule_vers,
usg_exports = maybe_old_export_vers,
usg_entities = old_decl_vers })
- = -- Load the imported interface is possible
- let
- doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
- in
- traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
+ = do -- Load the imported interface is possible
+ let doc_str = sep [ptext (sLit "need version info for"), ppr mod_name]
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name)
- let
- mod = mkModule this_pkg mod_name
- in
- loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface ->
+ let mod = mkModule this_pkg mod_name
+
+ mb_iface <- loadInterface doc_str mod ImportBySystem
-- Load the interface, but don't complain on failure;
-- Instead, get an Either back which we can test
case mb_iface of {
-- Load the interface, but don't complain on failure;
-- Instead, get an Either back which we can test
case mb_iface of {
- Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ Failed exn -> (out_of_date (sep [ptext (sLit "Can't find version number for module"),
ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
@@
-1164,39
+1163,39
@@
checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
new_rule_vers = mi_rule_vers iface
in
-- CHECK MODULE
new_rule_vers = mi_rule_vers iface
in
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
+ checkModuleVersion old_mod_vers new_mod_vers >>= \ recompile ->
if not recompile then
if not recompile then
- returnM upToDate
+ return upToDate
else
-- CHECK EXPORT LIST
if checkExportList maybe_old_export_vers new_export_vers then
else
-- CHECK EXPORT LIST
if checkExportList maybe_old_export_vers new_export_vers then
- out_of_date_vers (ptext SLIT(" Export list changed"))
+ out_of_date_vers (ptext (sLit " Export list changed"))
(expectJust "checkModUsage" maybe_old_export_vers)
new_export_vers
else
-- CHECK RULES
if old_rule_vers /= new_rule_vers then
(expectJust "checkModUsage" maybe_old_export_vers)
new_export_vers
else
-- CHECK RULES
if old_rule_vers /= new_rule_vers then
- out_of_date_vers (ptext SLIT(" Rules changed"))
+ out_of_date_vers (ptext (sLit " Rules changed"))
old_rule_vers new_rule_vers
else
-- CHECK ITEMS ONE BY ONE
old_rule_vers new_rule_vers
else
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] >>= \ recompile ->
if recompile then
if recompile then
- returnM outOfDate -- This one failed, so just bail out now
+ return outOfDate -- This one failed, so just bail out now
else
else
- up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
+ up_to_date (ptext (sLit " Great! The bits I use are up to date"))
}
------------------------
checkModuleVersion old_mod_vers new_mod_vers
| new_mod_vers == old_mod_vers
}
------------------------
checkModuleVersion old_mod_vers new_mod_vers
| new_mod_vers == old_mod_vers
- = up_to_date (ptext SLIT("Module version unchanged"))
+ = up_to_date (ptext (sLit "Module version unchanged"))
| otherwise
| otherwise
- = out_of_date_vers (ptext SLIT(" Module version has changed"))
+ = out_of_date_vers (ptext (sLit " Module version has changed"))
old_mod_vers new_mod_vers
------------------------
old_mod_vers new_mod_vers
------------------------
@@
-1208,28
+1207,27
@@
checkEntityUsage new_vers (name,old_vers)
= case new_vers name of
Nothing -> -- We used it before, but it ain't there now
= case new_vers name of
Nothing -> -- We used it before, but it ain't there now
- out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
+ out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
Just (_, new_vers) -- It's there, but is it up to date?
Just (_, new_vers) -- It's there, but is it up to date?
- | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
- returnM upToDate
- | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
+ | new_vers == old_vers -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers))
+ return upToDate
+ | otherwise -> out_of_date_vers (ptext (sLit " Out of date:") <+> ppr name)
old_vers new_vers
old_vers new_vers
-up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
-out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+up_to_date msg = traceHiDiffs msg >> return upToDate
+out_of_date msg = traceHiDiffs msg >> return outOfDate
out_of_date_vers msg old_vers new_vers
out_of_date_vers msg old_vers new_vers
- = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
+ = out_of_date (hsep [msg, ppr old_vers, ptext (sLit "->"), ppr new_vers])
----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
-checkList [] = returnM upToDate
-checkList (check:checks) = check `thenM` \ recompile ->
- if recompile then
- returnM outOfDate
- else
- checkList checks
+checkList [] = return upToDate
+checkList (check:checks) = do recompile <- check
+ if recompile
+ then return outOfDate
+ else checkList checks
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-1498,7
+1496,7
@@
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
- = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
+ = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }