The Backpack patch.
[ghc.git] / compiler / iface / LoadIface.hs
index c5c3538..4e1fea0 100644 (file)
@@ -24,7 +24,9 @@ module LoadIface (
         findAndReadIface, readIface,    -- Used when reading the module's old interface
         loadDecls,      -- Should move to TcIface and be renamed
         initExternalPackageState,
+        moduleFreeHolesPrecise,
 
+        pprModIfaceSimple,
         ifaceStats, pprModIface, showIface
    ) where
 
@@ -69,6 +71,8 @@ import FastString
 import Fingerprint
 import Hooks
 import FieldLabel
+import RnModIface
+import UniqDSet
 
 import Control.Monad
 import Data.IORef
@@ -352,11 +356,7 @@ loadPluginInterface doc mod_name
 -- | A wrapper for 'loadInterface' that throws an exception if it fails
 loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
 loadInterfaceWithException doc mod_name where_from
-  = do  { mb_iface <- loadInterface doc mod_name where_from
-        ; dflags <- getDynFlags
-        ; case mb_iface of
-            Failed err      -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
-            Succeeded iface -> return iface }
+  = withException (loadInterface doc mod_name where_from)
 
 ------------------
 loadInterface :: SDoc -> Module -> WhereFrom
@@ -375,6 +375,12 @@ loadInterface :: SDoc -> Module -> WhereFrom
 -- is no longer used
 
 loadInterface doc_str mod from
+  | isHoleModule mod
+  -- Hole modules get special treatment
+  = do dflags <- getDynFlags
+       -- Redo search for our local hole module
+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
+  | otherwise
   = do  {       -- Read the state
           (eps,hpt) <- getEpsAndHpt
         ; gbl_env <- getGblEnv
@@ -402,7 +408,7 @@ loadInterface doc_str mod from
                             WARN( hi_boot_file &&
                                   fmap fst (if_rec_types gbl_env) == Just mod,
                                   ppr mod )
-                            findAndReadIface doc_str mod hi_boot_file
+                            computeInterface doc_str hi_boot_file mod
         ; case read_result of {
             Failed err -> do
                 { let fake_iface = emptyModIface mod
@@ -423,12 +429,11 @@ loadInterface doc_str mod from
         -- But this is no longer valid because thNameToGhcName allows users to
         -- cause the system to load arbitrary interfaces (by supplying an appropriate
         -- Template Haskell original-name).
-            Succeeded (iface, file_path) ->
-
+            Succeeded (iface, loc) ->
         let
-            loc_doc = text file_path
+            loc_doc = text loc
         in
-        initIfaceLcl mod loc_doc (mi_boot iface) $ do
+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
 
         --      Load the new ModIface into the External Package State
         -- Even home-package interfaces loaded by loadInterface
@@ -464,7 +469,8 @@ loadInterface doc_str mod from
                }
 
         ; updateEps_  $ \ eps ->
-           if elemModuleEnv mod (eps_PIT eps) then eps else
+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface
+           then eps else
                 eps {
                   eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
                   eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
@@ -495,6 +501,91 @@ loadInterface doc_str mod from
         ; return (Succeeded final_iface)
     }}}}
 
+-- | Returns @True@ if a 'ModIface' comes from an external package.
+-- In this case, we should NOT load it into the EPS; the entities
+-- should instead come from the local merged signature interface.
+is_external_sig :: DynFlags -> ModIface -> Bool
+is_external_sig dflags iface =
+    -- It's a signature iface...
+    mi_semantic_module iface /= mi_module iface &&
+    -- and it's not from the local package
+    moduleUnitId (mi_module iface) /= thisPackage dflags
+
+-- | This is an improved version of 'findAndReadIface' which can also
+-- handle the case when a user requests @p[A=<B>]:M@ but we only
+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.
+-- If we are not trying to build code, we load the interface we have,
+-- *instantiating it* according to how the holes are specified.
+-- (Of course, if we're actually building code, this is a hard error.)
+--
+-- In the presence of holes, 'computeInterface' has an important invariant:
+-- to load module M, its set of transitively reachable requirements must
+-- have an up-to-date local hi file for that requirement.  Note that if
+-- we are loading the interface of a requirement, this does not
+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require
+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
+-- we are actually typechecking p.)
+computeInterface ::
+       SDoc -> IsBootInterface -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+computeInterface doc_str hi_boot_file mod0 = do
+    MASSERT( not (isHoleModule mod0) )
+    dflags <- getDynFlags
+    case splitModuleInsts mod0 of
+        (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+            r <- findAndReadIface doc_str imod hi_boot_file
+            case r of
+                Succeeded (iface0, path) -> do
+                    hsc_env <- getTopEnv
+                    r <- liftIO (rnModIface hsc_env insts Nothing iface0)
+                    return (Succeeded (r, path))
+                Failed err -> return (Failed err)
+        (mod, _) ->
+            findAndReadIface doc_str mod hi_boot_file
+
+-- | Compute the signatures which must be compiled in order to
+-- load the interface for a 'Module'.  The output of this function
+-- is always a subset of 'moduleFreeHoles'; it is more precise
+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes
+-- are A and B, B might not depend on A at all!
+--
+-- If this is invoked on a signature, this does NOT include the
+-- signature itself; e.g. precise free module holes of
+-- @p[A=<A>,B=<B>]:B@ never includes B.
+moduleFreeHolesPrecise
+    :: SDoc -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
+moduleFreeHolesPrecise doc_str mod
+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
+ | otherwise =
+   case splitModuleInsts mod of
+    (imod, Just insts) -> do
+        traceIf (text "Considering whether to load" <+> ppr mod <+>
+                 text "to compute precise free module holes")
+        (eps, hpt) <- getEpsAndHpt
+        dflags <- getDynFlags
+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of
+            Just r -> return (Succeeded r)
+            Nothing -> readAndCache imod insts
+    (_, Nothing) -> return (Succeeded emptyUniqDSet)
+  where
+    tryEpsAndHpt dflags eps hpt =
+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
+    tryDepsCache eps imod insts =
+        case lookupModuleEnv (eps_free_holes eps) imod of
+            Just ifhs  -> Just (renameFreeHoles ifhs insts)
+            _otherwise -> Nothing
+    readAndCache imod insts = do
+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod False
+        case mb_iface of
+            Succeeded (iface, _) -> do
+                let ifhs = mi_free_holes iface
+                -- Cache it
+                updateEps_ (\eps ->
+                    eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs })
+                return (Succeeded (renameFreeHoles ifhs insts))
+            Failed err -> return (Failed err)
+
 wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
                -> MaybeErr MsgDoc IsBootInterface
 -- Figure out whether we want Foo.hi or Foo.hi-boot
@@ -678,7 +769,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
 See Trac #8320.
 -}
 
-findAndReadIface :: SDoc -> Module
+findAndReadIface :: SDoc -> VirginModule
                  -> IsBootInterface     -- True  <=> Look for a .hi-boot file
                                         -- False <=> Look for .hi file
                  -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
@@ -687,7 +778,6 @@ findAndReadIface :: SDoc -> Module
 
         -- It *doesn't* add an error to the monad, because
         -- sometimes it's ok to fail... see notes with loadInterface
-
 findAndReadIface doc_str mod hi_boot_file
   = do traceIf (sep [hsep [text "Reading",
                            if hi_boot_file
@@ -710,7 +800,6 @@ findAndReadIface doc_str mod hi_boot_file
                mb_found <- liftIO (findExactModule hsc_env mod)
                case mb_found of
                    Found loc mod -> do
-
                        -- Found file, so read it
                        let file_path = addBootSuffix_maybe hi_boot_file
                                                            (ml_hi_file loc)
@@ -740,7 +829,11 @@ findAndReadIface doc_str mod hi_boot_file
                             -- Don't forget to fill in the package name...
           checkBuildDynamicToo (Succeeded (iface, filePath)) = do
               dflags <- getDynFlags
-              whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
+              -- Indefinite interfaces are ALWAYS non-dynamic, and
+              -- that's OK.
+              let is_definite_iface = moduleIsDefinite (mi_module iface)
+              when is_definite_iface $
+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
                   let ref = canGenerateDynamicToo dflags
                       dynFilePath = addBootSuffix_maybe hi_boot_file
                                   $ replaceExtension filePath (dynHiSuf dflags)
@@ -759,7 +852,7 @@ findAndReadIface doc_str mod hi_boot_file
 
 -- @readIface@ tries just the one file.
 
-readIface :: Module -> FilePath
+readIface :: VirginModule -> FilePath
           -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
         -- Failed err    <=> file not found, or unreadable, or illegible
         -- Succeeded iface <=> successfully found and parsed
@@ -791,6 +884,7 @@ initExternalPackageState
   = EPS {
       eps_is_boot      = emptyUFM,
       eps_PIT          = emptyPackageIfaceTable,
+      eps_free_holes   = emptyModuleEnv,
       eps_PTE          = emptyTypeEnv,
       eps_inst_env     = emptyInstEnv,
       eps_fam_inst_env = emptyFamInstEnv,
@@ -868,6 +962,11 @@ showIface hsc_env filename = do
    let dflags = hsc_dflags hsc_env
    log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
 
+-- Show a ModIface but don't display details; suitable for ModIfaces stored in
+-- the EPT.
+pprModIfaceSimple :: ModIface -> SDoc
+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
+
 pprModIface :: ModIface -> SDoc
 -- Show a ModIface
 pprModIface iface
@@ -935,6 +1034,8 @@ pprUsage usage@UsageHomeModule{}
 pprUsage usage@UsageFile{}
   = hsep [text "addDependentFile",
           doubleQuotes (text (usg_file_path usage))]
+pprUsage usage@UsageMergedRequirement{}
+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
 
 pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
 pprUsageImport usage usg_mod'