The Backpack patch.
[ghc.git] / compiler / deSugar / Desugar.hs
index 94ee7fa..72d2f9b 100644 (file)
@@ -8,40 +8,49 @@ The Desugarer: turning HsSyn into Core.
 
 {-# LANGUAGE CPP #-}
 
-module Desugar ( deSugar, deSugarExpr ) where
+module Desugar (
+    -- * Desugaring operations
+    deSugar, deSugarExpr,
+    -- * Dependency/fingerprinting code (used by MkIface)
+    mkUsageInfo, mkUsedNames, mkDependencies
+    ) where
+
+#include "HsVersions.h"
 
 import DynFlags
 import HscTypes
 import HsSyn
 import TcRnTypes
 import TcRnMonad ( finalSafeMode, fixSafeInstances )
-import MkIface
 import Id
 import Name
 import Type
 import FamInstEnv
-import Coercion
 import InstEnv
 import Class
 import Avail
 import CoreSyn
-import CoreFVs( exprsSomeFreeVars )
+import CoreFVs( exprsSomeFreeVarsList )
 import CoreSubst
 import PprCore
 import DsMonad
 import DsExpr
 import DsBinds
 import DsForeign
+import PrelNames   ( coercibleTyConKey )
+import TysPrim     ( eqReprPrimTyCon )
+import Unique      ( hasKey )
+import Coercion    ( mkCoVarCo )
+import TysWiredIn  ( coercibleDataCon )
+import DataCon     ( dataConWrapId )
+import MkCore      ( mkCoreLet )
 import Module
 import NameSet
 import NameEnv
 import Rules
-import TysPrim (eqReprPrimTyCon)
-import TysWiredIn (coercibleTyCon )
 import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
 import CoreMonad        ( CoreToDo(..) )
 import CoreLint         ( endPassIO )
-import MkCore
 import VarSet
 import FastString
 import ErrUtils
@@ -51,10 +60,201 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
-import StaticPtrTable
+import UniqFM
+import UniqDFM
+import ListSetOps
+import Fingerprint
+import Maybes
+
 import Data.List
 import Data.IORef
 import Control.Monad( when )
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- | Extract information from the rename and typecheck phases to produce
+-- a dependencies information for the module being compiled.
+mkDependencies :: TcGblEnv -> IO Dependencies
+mkDependencies
+          TcGblEnv{ tcg_mod = mod,
+                    tcg_imports = imports,
+                    tcg_th_used = th_var
+                  }
+ = do
+      -- Template Haskell used?
+      th_used <- readIORef th_var
+      let dep_mods = eltsUDFM (delFromUDFM (imp_dep_mods imports)
+                                           (moduleName mod))
+                -- M.hi-boot can be in the imp_dep_mods, but we must remove
+                -- it before recording the modules on which this one depends!
+                -- (We want to retain M.hi-boot in imp_dep_mods so that
+                --  loadHiBootInterface can see if M's direct imports depend
+                --  on M.hi-boot, and hence that we should do the hi-boot consistency
+                --  check.)
+
+          pkgs | th_used   = insertList thUnitId (imp_dep_pkgs imports)
+               | otherwise = imp_dep_pkgs imports
+
+          -- Set the packages required to be Safe according to Safe Haskell.
+          -- See Note [RnNames . Tracking Trust Transitively]
+          sorted_pkgs = sortBy stableUnitIdCmp pkgs
+          trust_pkgs  = imp_trust_pkgs imports
+          dep_pkgs'   = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
+
+      return Deps { dep_mods   = dep_mods,
+                    dep_pkgs   = dep_pkgs',
+                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
+                    -- sort to get into canonical order
+                    -- NB. remember to use lexicographic ordering
+
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
+
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
+  = do
+    eps <- hscEPS hsc_env
+    hashes <- mapM getFileHash dependent_files
+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
+                                       dir_imp_mods used_names
+        usages = mod_usages ++ [ UsageFile { usg_file_path = f
+                                           , usg_file_hash = hash }
+                               | (f, hash) <- zip dependent_files hashes ]
+                            ++ [ UsageMergedRequirement
+                                    { usg_mod = mod,
+                                      usg_mod_hash = hash
+                                    }
+                               | (mod, hash) <- merged ]
+    usages `seqList` return usages
+    -- seq the list of Usages returned: occasionally these
+    -- don't get evaluated for a while and we can end up hanging on to
+    -- the entire collection of Ifaces.
+
+mk_mod_usage_info :: PackageIfaceTable
+              -> HscEnv
+              -> Module
+              -> ImportedMods
+              -> NameSet
+              -> [Usage]
+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
+  = mapMaybe mkUsage usage_mods
+  where
+    hpt = hsc_HPT hsc_env
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    used_mods    = moduleEnvKeys ent_map
+    dir_imp_mods = moduleEnvKeys direct_imports
+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
+    usage_mods   = sortBy stableModuleCmp all_mods
+                        -- canonical order is imported, to avoid interface-file
+                        -- wobblage.
+
+    -- ent_map groups together all the things imported and used
+    -- from a particular module
+    ent_map :: ModuleEnv [OccName]
+    ent_map  = nonDetFoldUFM add_mv emptyModuleEnv used_names
+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
+     -- in ent_hashs
+     where
+      add_mv name mv_map
+        | isWiredInName name = mv_map  -- ignore wired-in names
+        | otherwise
+        = case nameModule_maybe name of
+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
+                -- See Note [Internal used_names]
+
+             Just mod -> -- This lambda function is really just a
+                         -- specialised (++); originally came about to
+                         -- avoid quadratic behaviour (trac #2680)
+                         extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
+                where occ = nameOccName name
+
+    -- We want to create a Usage for a home module if
+    --  a) we used something from it; has something in used_names
+    --  b) we imported it, even if we used nothing from it
+    --     (need to recompile if its export list changes: export_fprint)
+    mkUsage :: Module -> Maybe Usage
+    mkUsage mod
+      | isNothing maybe_iface           -- We can't depend on it if we didn't
+                                        -- load its interface.
+      || mod == this_mod                -- We don't care about usages of
+                                        -- things in *this* module
+      = Nothing
+
+      | moduleUnitId mod /= this_pkg
+      = Just UsagePackageModule{ usg_mod      = mod,
+                                 usg_mod_hash = mod_hash,
+                                 usg_safe     = imp_safe }
+        -- for package modules, we record the module hash only
+
+      | (null used_occs
+          && isNothing export_hash
+          && not is_direct_import
+          && not finsts_mod)
+      = Nothing                 -- Record no usage info
+        -- for directly-imported modules, we always want to record a usage
+        -- on the orphan hash.  This is what triggers a recompilation if
+        -- an orphan is added or removed somewhere below us in the future.
+
+      | otherwise
+      = Just UsageHomeModule {
+                      usg_mod_name = moduleName mod,
+                      usg_mod_hash = mod_hash,
+                      usg_exports  = export_hash,
+                      usg_entities = Map.toList ent_hashs,
+                      usg_safe     = imp_safe }
+      where
+        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
+                -- In one-shot mode, the interfaces for home-package
+                -- modules accumulate in the PIT not HPT.  Sigh.
+
+        Just iface   = maybe_iface
+        finsts_mod   = mi_finsts    iface
+        hash_env     = mi_hash_fn   iface
+        mod_hash     = mi_mod_hash  iface
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+                    | otherwise         = Nothing
+
+        (is_direct_import, imp_safe)
+            = case lookupModuleEnv direct_imports mod of
+                Just (imv : _xs) -> (True, imv_is_safe imv)
+                Just _           -> pprPanic "mkUsage: empty direct import" Outputable.empty
+                Nothing          -> (False, safeImplicitImpsReq dflags)
+                -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
+                -- is used in the source code. We require them to be safe in Safe Haskell
+
+        used_occs = lookupModuleEnv ent_map mod `orElse` []
+
+        -- Making a Map here ensures that (a) we remove duplicates
+        -- when we have usages on several subordinates of a single parent,
+        -- and (b) that the usages emerge in a canonical order, which
+        -- is why we use Map rather than OccEnv: Map works
+        -- using Ord on the OccNames, which is a lexicographic ordering.
+        ent_hashs :: Map OccName Fingerprint
+        ent_hashs = Map.fromList (map lookup_occ used_occs)
+
+        lookup_occ occ =
+            case hash_env occ of
+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
+                Just r  -> r
+
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
 
 {-
 ************************************************************************
@@ -70,7 +270,8 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
 
 deSugar hsc_env
         mod_loc
-        tcg_env@(TcGblEnv { tcg_mod          = mod,
+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
+                            tcg_semantic_mod = mod,
                             tcg_src          = hsc_src,
                             tcg_type_env     = type_env,
                             tcg_imports      = imports,
@@ -81,6 +282,7 @@ deSugar hsc_env
                             tcg_fix_env      = fix_env,
                             tcg_inst_env     = inst_env,
                             tcg_fam_inst_env = fam_inst_env,
+                            tcg_merged       = merged,
                             tcg_warns        = warns,
                             tcg_anns         = anns,
                             tcg_binds        = binds,
@@ -98,18 +300,22 @@ deSugar hsc_env
 
   = do { let dflags = hsc_dflags hsc_env
              print_unqual = mkPrintUnqualified dflags rdr_env
-        ; showPass dflags "Desugar"
-
-        -- Desugar the program
-        ; let export_set = availsToNameSet exports
+        ; withTiming (pure dflags)
+                     (text "Desugar"<+>brackets (ppr mod))
+                     (const ()) $
+     do { -- Desugar the program
+        ; let export_set =
+                -- Used to be 'availsToNameSet', but we now export selectors
+                -- only when necessary. See #12125.
+                availsToNameSetWithSelectors exports
               target     = hscTarget dflags
               hpcInfo    = emptyHpcInfo other_hpc_info
 
         ; (binds_cvr, ds_hpc_info, modBreaks)
                          <- if not (isHsBootOrSig hsc_src)
-                              then addTicksToBinds dflags mod mod_loc export_set
-                                          (typeEnvTyCons type_env) binds
-                              else return (binds, hpcInfo, emptyModBreaks)
+                              then addTicksToBinds hsc_env mod mod_loc
+                                       export_set (typeEnvTyCons type_env) binds
+                              else return (binds, hpcInfo, Nothing)
 
         ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
                        do { ds_ev_binds <- dsEvBinds ev_binds
@@ -118,24 +324,17 @@ deSugar hsc_env
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
-                          ; stBinds <- dsGetStaticBindsVar >>=
-                                           liftIO . readIORef
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
-                                -- Stub to insert the static entries of the
-                                -- module into the static pointer table
-                                spt_init = sptInitCode mod stBinds
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
-                                                 `appOL` toOL (map snd stBinds)
                                    , spec_rules ++ ds_rules, ds_vects
-                                   , ds_fords `appendStubC` hpc_init
-                                              `appendStubC` spt_init) }
+                                   , ds_fords `appendStubC` hpc_init) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
+           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
 
      do {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
@@ -167,16 +366,19 @@ deSugar hsc_env
         ; used_th <- readIORef tc_splice_used
         ; dep_files <- readIORef dependent_files
         ; safe_mode <- finalSafeMode dflags tcg_env
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged
+        -- id_mod /= mod when we are processing an hsig, but hsigs
+        -- never desugared and compiled (there's no code!)
+        ; MASSERT ( id_mod == mod )
 
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
                 mg_hsc_src      = hsc_src,
                 mg_loc          = mkFileSrcSpan mod_loc,
                 mg_exports      = exports,
+                mg_usages       = usages,
                 mg_deps         = deps,
-                mg_used_names   = used_names,
                 mg_used_th      = used_th,
-                mg_dir_imps     = imp_mods imports,
                 mg_rdr_env      = rdr_env,
                 mg_fix_env      = fix_env,
                 mg_warns        = warns,
@@ -195,11 +397,10 @@ deSugar hsc_env
                 mg_vect_decls   = ds_vects,
                 mg_vect_info    = noVectInfo,
                 mg_safe_haskell = safe_mode,
-                mg_trust_pkg    = imp_trust_own_pkg imports,
-                mg_dependent_files = dep_files
+                mg_trust_pkg    = imp_trust_own_pkg imports
               }
         ; return (msgs, Just mod_guts)
-        }}}
+        }}}}
 
 mkFileSrcSpan :: ModLocation -> SrcSpan
 mkFileSrcSpan mod_loc
@@ -371,7 +572,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
         -- Substitute the dict bindings eagerly,
         -- and take the body apart into a (f args) form
         ; case decomposeRuleLhs bndrs'' lhs'' of {
-                Left msg -> do { warnDs msg; return Nothing } ;
+                Left msg -> do { warnDs NoReason msg; return Nothing } ;
                 Right (final_bndrs, fn_id, args) -> do
 
         { let is_local = isLocalId fn_id
@@ -381,12 +582,14 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
               rule_name = snd (unLoc name)
-              rule      = mkRule this_mod False {- Not auto -} is_local
-                                 rule_name rule_act fn_name final_bndrs args
-                                 final_rhs
-              arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
+              final_bndrs_set = mkVarSet final_bndrs
+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
+                        exprsSomeFreeVarsList isId args
 
         ; dflags <- getDynFlags
+        ; rule <- dsMkUserRule this_mod is_local
+                         rule_name rule_act fn_name final_bndrs args
+                         final_rhs
         ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
           warnRuleShadowing rule_name rule_act fn_id arg_ids
 
@@ -406,22 +609,24 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
       | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
                        -- If imported with no unfolding, no worries
       , idInlineActivation lhs_id `competesWith` rule_act
-      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
-                               <+> ptext (sLit "may never fire"))
-                            2 (ptext (sLit "because") <+> quotes (ppr lhs_id)
-                               <+> ptext (sLit "might inline first"))
-                     , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for")
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because" <+> quotes (ppr lhs_id)
+                               <+> text "might inline first")
+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
                        <+> quotes (ppr lhs_id)
                      , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
 
       | check_rules_too
       , bad_rule : _ <- get_bad_rules lhs_id
-      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
-                               <+> ptext (sLit "may never fire"))
-                            2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule)
-                               <+> ptext (sLit "for")<+> quotes (ppr lhs_id)
-                               <+> ptext (sLit "might fire first"))
-                      , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule")
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
+                               <+> text "for"<+> quotes (ppr lhs_id)
+                               <+> text "might fire first")
+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"
                       , ifPprDebug (ppr bad_rule) ])
 
       | otherwise
@@ -440,13 +645,19 @@ unfold_coerce bndrs lhs rhs = do
     go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
     go []     = return ([], id)
     go (v:vs)
-        | Just (tc, args) <- splitTyConApp_maybe (idType v)
-        , tc == coercibleTyCon = do
-            let ty' = mkTyConApp eqReprPrimTyCon args
-            v' <- mkDerivedLocalM mkRepEqOcc v ty'
+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
+        , tc `hasKey` coercibleTyConKey = do
+            u <- newUnique
+
+            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
+                v'  = mkLocalCoVar
+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
+                      [k, t1, t2] `App`
+                      Coercion (mkCoVarCo v')
 
             (bndrs, wrap) <- go vs
-            return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
         | otherwise = do
             (bndrs,wrap) <- go vs
             return (v:bndrs, wrap)
@@ -461,8 +672,6 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
 
-
-
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
@@ -473,13 +682,14 @@ We want the user to express a rule saying roughly “mapping a coercion over a
 list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
 be written in Haskell. So we use `coerce` for that (#2110). The user writes
     map coerce = coerce
-as a RULE, and this optimizes any kind of mapped' casts aways, including `map
+as a RULE, and this optimizes any kind of mapped' casts away, including `map
 MkNewtype`.
 
 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
 `let c = MkCoercible co in ...`. This is later simplified to the desired form
 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
+See also Note [Getting the map/coerce RULE to work] in CoreSubst.
 
 Note [Rules and inlining/other rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~