Fix a bug in the recompilation checking logic.
[ghc-hetmet.git] / compiler / main / GHC.hs
index 0d2cca1..1d745a2 100644 (file)
@@ -49,6 +49,7 @@ module GHC (
         parseModule, typecheckModule, desugarModule, loadModule,
         ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
+        TypecheckedMod, ParsedMod,
         moduleInfo, renamedSource, typecheckedSource,
         parsedSource, coreModule,
         compileToCoreModule, compileToCoreSimplified,
@@ -74,8 +75,12 @@ module GHC (
        modInfoIsExportedName,
        modInfoLookupName,
        lookupGlobalName,
+       findGlobalAnns,
         mkPrintUnqualifiedForModule,
 
+        -- * Querying the environment
+        packageDbModules,
+
        -- * Printing
        PrintUnqualified, alwaysQualify,
 
@@ -278,8 +283,10 @@ import StaticFlagParser
 import qualified StaticFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
+import Annotations
 import Module
 import LazyUniqFM
+import qualified UniqFM as UFM
 import UniqSet
 import Unique
 import FiniteMap
@@ -304,6 +311,8 @@ import System.Directory ( getModificationTime, doesFileExist,
 import Data.Maybe
 import Data.List
 import qualified Data.List as List
+import Data.Typeable    ( Typeable )
+import Data.Word        ( Word8 )
 import Control.Monad
 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime, getClockTime )
@@ -650,6 +659,10 @@ data LoadHowMuch
 
 -- | Try to load the program.  Calls 'loadWithLogger' with the default
 -- compiler that just immediately logs all warnings and errors.
+--
+-- This function may throw a 'SourceError' if errors are encountered before
+-- the actual compilation starts (e.g., during dependency analysis).
+--
 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
 load how_much =
     loadWithLogger defaultWarnErrLogger how_much
@@ -667,7 +680,11 @@ defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
 --
 -- The first argument is a function that is called after compiling each
 -- module to print wanrings and errors.
-
+--
+-- While compiling a module, all 'SourceError's are caught and passed to the
+-- logger, however, this function may still throw a 'SourceError' if
+-- dependency analysis failed (e.g., due to a parse error).
+--
 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
 loadWithLogger logger how_much = do
     -- Dependency analysis first.  Note that this fixes the module graph:
@@ -1173,6 +1190,7 @@ mkModGuts coreModule = ModGuts {
   mg_binds = cm_binds coreModule,
   mg_foreign = NoStubs,
   mg_warns = NoWarnings,
+  mg_anns = [],
   mg_hpc_info = emptyHpcInfo False,
   mg_modBreaks = emptyModBreaks,
   mg_vect_info = noVectInfo,
@@ -1558,65 +1576,75 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                         = compile hsc_env summary' mod_index nmods Nothing
 
         in
-       case target of
-
-            _any
+        case () of
+         _
                 -- Regardless of whether we're generating object code or
                 -- byte code, we can always use an existing object file
                 -- if it is *stable* (see checkStability).
-               | is_stable_obj, isJust old_hmi ->
-                        let Just hmi = old_hmi in
-                       return hmi
-                       -- object is stable, and we have an entry in the
-                       -- old HPT: nothing to do
-
-               | is_stable_obj, isNothing old_hmi -> do
-                       linkable <- liftIO $ findObjectLinkable this_mod obj_fn
-                                       (expectJust "upsweep1" mb_obj_date)
-                       compile_it (Just linkable)
-                       -- object is stable, but we need to load the interface
-                       -- off disk to make a HMI.
-
-            HscInterpreted
-               | is_stable_bco -> 
-                       ASSERT(isJust old_hmi) -- must be in the old_hpt
-                        let Just hmi = old_hmi in
-                       return hmi
-                       -- BCO is stable: nothing to do
-
-               | Just hmi <- old_hmi,
-                 Just l <- hm_linkable hmi, not (isObjectLinkable l),
-                 linkableTime l >= ms_hs_date summary ->
-                       compile_it (Just l)
-                       -- we have an old BCO that is up to date with respect
-                       -- to the source: do a recompilation check as normal.
-
-               | otherwise -> 
-                        compile_it Nothing
-                       -- no existing code at all: we must recompile.
-
-              -- When generating object code, if there's an up-to-date
-              -- object file on the disk, then we can use it.
-              -- However, if the object file is new (compared to any
-              -- linkable we had from a previous compilation), then we
-              -- must discard any in-memory interface, because this
-              -- means the user has compiled the source file
-              -- separately and generated a new interface, that we must
-              -- read from the disk.
-              --
-            obj | isObjectTarget obj,
-                 Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
-                     case old_hmi of
-                        Just hmi 
-                          | Just l <- hm_linkable hmi,
-                            isObjectLinkable l && linkableTime l == obj_date
-                            -> compile_it (Just l)
-                        _otherwise -> do
-                         linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+          | is_stable_obj, Just hmi <- old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable obj mod:" <+> ppr this_mod_name)
+                return hmi
+                -- object is stable, and we have an entry in the
+                -- old HPT: nothing to do
+
+          | is_stable_obj, isNothing old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+                              (expectJust "upsweep1" mb_obj_date)
+                compile_it (Just linkable)
+                -- object is stable, but we need to load the interface
+                -- off disk to make a HMI.
+
+          | not (isObjectTarget target), is_stable_bco ->
+                ASSERT(isJust old_hmi) -- must be in the old_hpt
+                let Just hmi = old_hmi in do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+                return hmi
+                -- BCO is stable: nothing to do
+
+          | not (isObjectTarget target),
+            Just hmi <- old_hmi,
+            Just l <- hm_linkable hmi,
+            not (isObjectLinkable l),
+            linkableTime l >= ms_hs_date summary -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+                compile_it (Just l)
+                -- we have an old BCO that is up to date with respect
+                -- to the source: do a recompilation check as normal.
+
+          -- When generating object code, if there's an up-to-date
+          -- object file on the disk, then we can use it.
+          -- However, if the object file is new (compared to any
+          -- linkable we had from a previous compilation), then we
+          -- must discard any in-memory interface, because this
+          -- means the user has compiled the source file
+          -- separately and generated a new interface, that we must
+          -- read from the disk.
+          --
+          | isObjectTarget target,
+            Just obj_date <- mb_obj_date,
+            obj_date >= hs_date -> do
+                case old_hmi of
+                  Just hmi
+                    | Just l <- hm_linkable hmi,
+                      isObjectLinkable l && linkableTime l == obj_date -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+                          compile_it (Just l)
+                  _otherwise -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
                           compile_it_discard_iface (Just linkable)
 
-           _otherwise ->
-                 compile_it Nothing
+         _otherwise -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling mod:" <+> ppr this_mod_name)
+                compile_it Nothing
 
 
 
@@ -2408,9 +2436,12 @@ isDictonaryId id
 -- 'setContext'.
 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
 lookupGlobalName name = withSession $ \hsc_env -> do
-   eps <- liftIO $ readIORef (hsc_EPS hsc_env)
-   return $! lookupType (hsc_dflags hsc_env) 
-                       (hsc_HPT hsc_env) (eps_PTE eps) name
+   liftIO $ lookupTypeHscEnv hsc_env name
+
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+    return (findAnns deserialize ann_env target)
 
 #ifdef GHCI
 -- | get the GlobalRdrEnv for a session
@@ -2419,6 +2450,23 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
 #endif
 
 -- -----------------------------------------------------------------------------
+
+-- | Return all /external/ modules available in the package database.
+-- Modules from the current session (i.e., from the 'HomePackageTable') are
+-- not included.
+packageDbModules :: GhcMonad m =>
+                    Bool  -- ^ Only consider exposed packages.
+                 -> m [Module]
+packageDbModules only_exposed = do
+   dflags <- getSessionDynFlags
+   let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
+   return $
+     [ mkModule pid modname | p <- pkgs
+                            , not only_exposed || exposed p
+                            , pid <- [mkPackageId (package p)]
+                            , modname <- exposedModules p ]
+
+-- -----------------------------------------------------------------------------
 -- Misc exported utils
 
 dataConType :: DataCon -> Type