Merge remote branch 'origin/master' into ghc-new-co
[ghc.git] / compiler / iface / MkIface.lhs
index 68c6cf1..88dbfa3 100644 (file)
@@ -59,10 +59,10 @@ import Annotations
 import CoreSyn
 import CoreFVs
 import Class
+import Kind
 import TyCon
 import DataCon
 import Type
-import Coercion
 import TcType
 import InstEnv
 import FamInstEnv
@@ -153,7 +153,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
                       tcg_hpc = other_hpc_info
                     }
   = do
-          used_names <- mkUsedNames tc_result
+          let used_names = mkUsedNames tc_result
           deps <- mkDependencies tc_result
           let hpc_info = emptyHpcInfo other_hpc_info
           mkIface_ hsc_env maybe_old_fingerprint
@@ -161,13 +161,8 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
                    fix_env warns hpc_info (imp_mods imports) mod_details
         
 
-mkUsedNames :: TcGblEnv -> IO NameSet
-mkUsedNames 
-          TcGblEnv{ tcg_inst_uses = dfun_uses_var,
-                    tcg_dus = dus
-                  }
- = do { dfun_uses <- readIORef dfun_uses_var           -- What dfuns are used
-      ; return (allUses dus `unionNameSets` dfun_uses) }
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
         
 mkDependencies :: TcGblEnv -> IO Dependencies
 mkDependencies
@@ -280,9 +275,11 @@ mkIface_ hsc_env maybe_old_fingerprint
                                          intermediate_iface decls
 
                -- Warn about orphans
-       ; let orph_warnings   --- Laziness means no work done unless -fwarn-orphans
-               | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
-               | otherwise                   = emptyBag
+       ; let warn_orphs      = dopt Opt_WarnOrphans dflags
+              warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
+              orph_warnings   --- Laziness means no work done unless -fwarn-orphans
+               | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+               | otherwise                     = emptyBag
              errs_and_warns = (orph_warnings, emptyBag)
              unqual = mkPrintUnqualified dflags rdr_env
              inst_warns = listToBag [ instOrphWarn unqual d 
@@ -290,7 +287,9 @@ mkIface_ hsc_env maybe_old_fingerprint
                                     , isNothing (ifInstOrph i) ]
              rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
                                     | r <- iface_rules
-                                    , isNothing (ifRuleOrph r) ]
+                                    , isNothing (ifRuleOrph r)
+                                     , if ifRuleAuto r then warn_auto_orphs
+                                                       else warn_orphs ]
 
        ; if errorsFound dflags errs_and_warns
             then return ( errs_and_warns, Nothing )
@@ -435,7 +434,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
           | isWiredInName name  =  putNameLiterally bh name 
            -- wired-in names don't have fingerprints
           | otherwise
-          = ASSERT( isExternalName name )
+          = ASSERT2( isExternalName name, ppr name )
            let hash | nameModule name /= this_mod =  global_hash_fn name
                      | otherwise = 
                         snd (lookupOccEnv local_env (getOccName name)
@@ -511,7 +510,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
 
    orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
-                      (map IfaceInstABI orph_insts, orph_rules, fam_insts)
+                      (map ifDFun orph_insts, orph_rules, fam_insts)
 
    -- the export list hash doesn't depend on the fingerprints of
    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
@@ -626,8 +625,8 @@ The ABI of a declaration consists of:
 
 Items (c)-(f) are not stored in the IfaceDecl, but instead appear
 elsewhere in the interface file.  But they are *fingerprinted* with
-the Id itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
-and fingerprinting that as part of the Id.
+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the declaration.
 
 \begin{code}
 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
@@ -653,10 +652,10 @@ freeNamesDeclABI (_mod, decl, extras) =
 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
 freeNamesDeclExtras (IfaceIdExtras    _ rules)
   = unionManyNameSets (map freeNamesIfRule rules)
-freeNamesDeclExtras (IfaceDataExtras  _ _insts subs)
-  = unionManyNameSets (map freeNamesSub subs)
-freeNamesDeclExtras (IfaceClassExtras _ _insts subs)
-  = unionManyNameSets (map freeNamesSub subs)
+freeNamesDeclExtras (IfaceDataExtras  _ insts subs)
+  = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts subs)
+  = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
 freeNamesDeclExtras (IfaceSynExtras _)
   = emptyNameSet
 freeNamesDeclExtras IfaceOtherDeclExtras
@@ -709,11 +708,11 @@ declExtras fix_fn rule_env inst_env decl
                         (lookupOccEnvL rule_env n)
       IfaceData{ifCons=cons} -> 
                      IfaceDataExtras (fix_fn n)
-                        (map IfaceInstABI $ lookupOccEnvL inst_env n)
+                        (map ifDFun $ lookupOccEnvL inst_env n)
                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
       IfaceClass{ifSigs=sigs} -> 
                      IfaceClassExtras (fix_fn n)
-                        (map IfaceInstABI $ lookupOccEnvL inst_env n)
+                        (map ifDFun $ lookupOccEnvL inst_env n)
                         [id_extras op | IfaceClassOp op _ _ <- sigs]
       IfaceSyn{} -> IfaceSynExtras (fix_fn n)
       _other -> IfaceOtherDeclExtras
@@ -722,19 +721,10 @@ declExtras fix_fn rule_env inst_env decl
         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
 
 --
--- When hashing an instance, we hash only its structure, not the
--- fingerprints of the things it mentions.  See the section on instances
--- in the commentary,
---    http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+-- When hashing an instance, we hash only the DFunId, because that
+-- depends on all the information about the instance.
 --
-newtype IfaceInstABI = IfaceInstABI IfaceInst
-
-instance Binary IfaceInstABI where
-  get = panic "no get for IfaceInstABI"
-  put_ bh (IfaceInstABI inst) = do
-    let ud  = getUserData bh
-        bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
-    put_ bh' inst
+type IfaceInstABI = IfExtName
 
 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
@@ -910,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
        finsts_mod   = mi_finsts    iface
         hash_env     = mi_hash_fn   iface
         mod_hash     = mi_mod_hash  iface
-        export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
-                   | otherwise             = Nothing
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+                   | otherwise         = Nothing
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
@@ -928,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
                 Just r  -> r
 
-        depend_on_exports mod = 
-           case lookupModuleEnv direct_imports mod of
-               Just _ -> 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.
-               Nothing -> False
-                  -- In GHC 6.8.x the above line read "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!
+        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!
+        -}
 \end{code}
 
 \begin{code}
@@ -1318,11 +1308,7 @@ tyThingToIfaceDecl (AnId id)
   = IfaceId { ifName      = getOccName id,
              ifType      = toIfaceType (idType id),
              ifIdDetails = toIfaceIdDetails (idDetails id),
-             ifIdInfo    = info }
-  where
-    info = case toIfaceIdInfo (idInfo id) of
-               []    -> NoInfo
-               items -> HasInfo items
+             ifIdInfo    = toIfaceIdInfo (idInfo id) }
 
 tyThingToIfaceDecl (AClass clas)
   = IfaceClass { ifCtxt          = toIfaceContext sc_theta,
@@ -1401,14 +1387,16 @@ tyThingToIfaceDecl (ATyCon tycon)
        = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                    ifConInfix   = dataConIsInfix data_con,
                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                   ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
-                   ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
-                   ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
-                   ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
-                   ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
+                   ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+                   ifConExTvs   = toIfaceTvBndrs ex_tvs,
+                   ifConEqSpec  = to_eq_spec eq_spec,
+                   ifConCtxt    = toIfaceContext theta,
+                   ifConArgTys  = map toIfaceType arg_tys,
                    ifConFields  = map getOccName 
                                       (dataConFieldLabels data_con),
                    ifConStricts = dataConStrictMarks data_con }
+        where
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
 
@@ -1416,6 +1404,8 @@ tyThingToIfaceDecl (ATyCon tycon)
     famInstToIface (Just (famTyCon, instTys)) = 
       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
 
+tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+
 tyThingToIfaceDecl (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)     -- Should be trimmed out earlier
 
@@ -1442,10 +1432,10 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     is_local name = nameIsLocalOrFrom mod name
 
        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-    (_, cls, tys) = tcSplitDFunTy (idType dfun_id)
+    (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
                -- Slightly awkward: we need the Class to get the fundeps
     (tvs, fds) = classTvsFds cls
-    arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
+    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
     orph | is_local cls_name = Just (nameOccName cls_name)
         | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
         | otherwise         = Nothing
@@ -1478,33 +1468,26 @@ famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
 toIfaceLetBndr :: Id -> IfaceLetBndr
 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
                               (toIfaceType (idType id)) 
-                              prag_info
-  where
-       -- Stripped-down version of tcIfaceIdInfo
-       -- Change this if you want to export more IdInfo for
-       -- non-top-level Ids.  Don't forget to change
-       -- CoreTidy.tidyLetBndr too!
-       --
-       -- See Note [IdInfo on nested let-bindings] in IfaceSyn
-    id_info = idInfo id
-    inline_prag = inlinePragInfo id_info
-    prag_info | isDefaultInlinePragma inline_prag = NoInfo
-             | otherwise                         = HasInfo [HsInline inline_prag]
+                              (toIfaceIdInfo (idInfo id))
+  -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr 
+  -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn
 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
 toIfaceIdDetails VanillaId                     = IfVanillaId
-toIfaceIdDetails (DFunId {})                           = IfDFunId
+toIfaceIdDetails (DFunId ns _)                  = IfDFunId ns
 toIfaceIdDetails (RecSelId { sel_naughty = n
                           , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
 toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
                                                   IfVanillaId   -- Unexpected
 
-toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo :: IdInfo -> IfaceIdInfo
 toIfaceIdInfo id_info
-  = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
-              inline_hsinfo,  unfold_hsinfo] 
-              -- NB: strictness must be before unfolding
+  = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
+                   inline_hsinfo,  unfold_hsinfo] of
+       []    -> NoInfo
+       infos -> HasInfo infos
+              -- NB: strictness must appear in the list before unfolding
               -- See TcIface.tcUnfolding
   where
     ------------  Arity  --------------
@@ -1535,24 +1518,29 @@ toIfaceIdInfo id_info
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-                                    , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+                                , uf_src = src, uf_guidance = guidance })
   = Just $ HsUnfold lb $
     case src of
-       InlineRule {}
+       InlineStable
           -> case guidance of
-               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
-               _other                     -> pprPanic "toIfUnfolding" (ppr unf)
-       InlineWrapper w  -> IfWrapper arity (idName w)
-        InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
-        InlineRhs        -> IfCoreUnfold (toIfaceExpr rhs)
+               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+               _other                     -> IfCoreUnfold True if_rhs
+       InlineWrapper w | isExternalName n -> IfExtWrapper arity n
+                       | otherwise        -> IfLclWrapper arity (getFS n)
+                       where
+                          n = idName w
+        InlineCompulsory -> IfCompulsory if_rhs
+        InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
+  where
+    if_rhs = toIfaceExpr rhs
 
 toIfUnfolding lb (DFunUnfolding _ar _con ops)
-  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
+  = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
       -- No need to serialise the data constructor; 
       -- we can recover it from the type of the dfun
 
@@ -1565,14 +1553,16 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
   = pprTrace "toHsRule: builtin" (ppr fn) $
     bogusIfaceRule fn
 
-coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
-                                ru_act = act, ru_bndrs = bndrs,
-                               ru_args = args, ru_rhs = rhs })
+coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, 
+                                     ru_act = act, ru_bndrs = bndrs,
+                                    ru_args = args, ru_rhs = rhs, 
+                                     ru_auto = auto })
   = IfaceRule { ifRuleName  = name, ifActivation = act, 
                ifRuleBndrs = map toIfaceBndr bndrs,
                ifRuleHead  = fn, 
                ifRuleArgs  = map do_arg args,
                ifRuleRhs   = toIfaceExpr rhs,
+                ifRuleAuto  = auto,
                ifRuleOrph  = orph }
   where
        -- For type args we must remove synonyms from the outermost
@@ -1580,14 +1570,14 @@ coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
        -- construct the same ru_rough field as we have right now;
        -- see tcIfaceRule
     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+    do_arg (Coercion co) = IfaceType (coToIfaceType co)
+                           
     do_arg arg       = toIfaceExpr arg
 
        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
        -- A rule is an orphan only if none of the variables
        -- mentioned on its left-hand side are locally defined
-    lhs_names = fn : nameSetToList (exprsFreeNames args)
-               -- No need to delete bndrs, because
-               -- exprsFreeNames finds only External names
+    lhs_names = nameSetToList (ruleLhsOrphNames rule)
 
     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
                        (n : _) -> Just (nameOccName n)
@@ -1597,19 +1587,20 @@ bogusIfaceRule :: Name -> IfaceRule
 bogusIfaceRule id_name
   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
-       ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+       ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr
-toIfaceExpr (Var v)       = toIfaceVar v
-toIfaceExpr (Lit l)       = IfaceLit l
-toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
-toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
-toIfaceExpr (App f a)     = toIfaceApp f [a]
-toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
-toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
-toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
+toIfaceExpr (Var v)         = toIfaceVar v
+toIfaceExpr (Lit l)         = IfaceLit l
+toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
+toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
+toIfaceExpr (App f a)       = toIfaceApp f [a]
+toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
+toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Note n e)      = IfaceNote (toIfaceNote n) (toIfaceExpr e)
 
 ---------------------
 toIfaceNote :: Note -> IfaceNote