X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=fd8fbdb5aeacb9f606a05b6e987f460228602ced;hb=2b8358cfe8b6399874090c099e3b96e932c6ccbb;hp=9263baec69f846cfe539948d4daa37a145370a5f;hpb=f3e080507db6130c983fc86485661e0f14fba565;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 9263bae..fd8fbdb 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -62,6 +62,7 @@ import Class import TyCon import DataCon import Type +import Coercion import TcType import InstEnv import FamInstEnv @@ -83,10 +84,9 @@ import Digraph import SrcLoc import Outputable import BasicTypes hiding ( SuccessFlag(..) ) -import LazyUniqFM +import UniqFM import Unique import Util hiding ( eqListBy ) -import FiniteMap import FastString import Maybes import ListSetOps @@ -96,6 +96,8 @@ import Bag import Control.Monad import Data.List +import Data.Map (Map) +import qualified Data.Map as Map import Data.IORef import System.FilePath \end{code} @@ -164,9 +166,8 @@ 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) + = do { dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + ; return (allUses dus `unionNameSets` dfun_uses) } mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies @@ -319,7 +320,10 @@ mkIface_ hsc_env maybe_old_fingerprint le_occ n1 n2 = nameOccName n1 <= nameOccName n2 dflags = hsc_dflags hsc_env + + deliberatelyOmitted :: String -> a deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + ifFamInstTcName = ifaceTyConName . ifFamInstTyCon flattenVectInfo (VectInfo { vectInfoVar = vVar @@ -520,7 +524,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- wiki/Commentary/Compiler/RecompilationAvoidance -- put the declarations in a canonical order, sorted by OccName - let sorted_decls = eltsFM $ listToFM $ + let sorted_decls = Map.elems $ Map.fromList $ [(ifName d, e) | e@(_, d) <- decls_w_hashes] -- the ABI hash depends on: @@ -661,6 +665,24 @@ freeNamesDeclExtras IfaceOtherDeclExtras freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = empty + ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules + ppr (IfaceSynExtras fix) = ppr fix + ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = ptext (sLit "") + +ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc +ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff] + +ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc +ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules) + -- This instance is used only to compute fingerprints instance Binary IfaceDeclExtras where get _bh = panic "no get for IfaceDeclExtras" @@ -838,11 +860,11 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | isWiredInName name = mv_map -- ignore wired-in names | otherwise = case nameModule_maybe name of - Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map - Just mod -> -- We use this fiddly lambda function rather than - -- (++) as the argument to extendModuleEnv_C to + Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name) + Just mod -> -- This lambda function is really just a + -- specialised (++); originally came about to -- avoid quadratic behaviour (trac #2680) - extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ] + extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ] where occ = nameOccName name -- We want to create a Usage for a home module if @@ -876,7 +898,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names usg_mod_name = moduleName mod, usg_mod_hash = mod_hash, usg_exports = export_hash, - usg_entities = fmToList ent_hashs } + usg_entities = Map.toList ent_hashs } where maybe_iface = lookupIfaceByModule dflags hpt pit mod -- In one-shot mode, the interfaces for home-package @@ -893,13 +915,13 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names used_occs = lookupModuleEnv ent_map mod `orElse` [] - -- Making a FiniteMap here ensures that (a) we remove duplicates + -- 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 FiniteMap rather than OccEnv: FiniteMap works + -- is why we use Map rather than OccEnv: Map works -- using Ord on the OccNames, which is a lexicographic ordering. - ent_hashs :: FiniteMap OccName Fingerprint - ent_hashs = listToFM (map lookup_occ used_occs) + ent_hashs :: Map OccName Fingerprint + ent_hashs = Map.fromList (map lookup_occ used_occs) lookup_occ occ = case hash_env occ of @@ -939,10 +961,10 @@ mkIfaceExports :: [AvailInfo] -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence mkIfaceExports exports - = [ (mod, eltsFM avails) + = [ (mod, Map.elems avails) | (mod, avails) <- sortBy (stableModuleCmp `on` fst) (moduleEnvToList groupFM) - -- NB. the fmToList is in a random order, + -- NB. the Map.toList is in a random order, -- because Ord Module is not a predictable -- ordering. Hence we perform a final sort -- using the stable Module ordering. @@ -950,20 +972,21 @@ mkIfaceExports exports where -- Group by the module where the exported entities are defined -- (which may not be the same for all Names in an Avail) - -- Deliberately use FiniteMap rather than UniqFM so we + -- Deliberately use Map rather than UniqFM so we -- get a canonical ordering - groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName)) groupFM = foldl add emptyModuleEnv exports - add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName)) -> Module -> GenAvailInfo OccName - -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + -> ModuleEnv (Map FastString (GenAvailInfo OccName)) add_one env mod avail - = extendModuleEnv_C plusFM env mod - (unitFM (occNameFS (availName avail)) avail) + -- XXX Is there a need to flip Map.union here? + = extendModuleEnvWith (flip Map.union) env mod + (Map.singleton (occNameFS (availName avail)) avail) -- NB: we should not get T(X) and T(Y) in the export list - -- else the plusFM will simply discard one! They + -- else the Map.union will simply discard one! They -- should have been combined by now. add env (Avail n) = ASSERT( isExternalName n ) @@ -1316,7 +1339,7 @@ tyThingToIfaceDecl (AClass clas) toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty) + IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty) where -- Be careful when splitting the type, because of things -- like class Foo a where @@ -1326,6 +1349,10 @@ tyThingToIfaceDecl (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty + toDmSpec NoDefMeth = NoDM + toDmSpec GenDefMeth = GenericDM + toDmSpec (DefMeth _) = VanillaDM + toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) tyThingToIfaceDecl (ATyCon tycon) @@ -1356,14 +1383,14 @@ tyThingToIfaceDecl (ATyCon tycon) tyvars = tyConTyVars tycon (syn_rhs, syn_ki) = case synTyConRhs tycon of - OpenSynTyCon ki _ -> (Nothing, toIfaceType ki) - SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty)) + SynFamilyTyCon -> (Nothing, toIfaceType (synTyConResKind tycon)) + SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty)) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls OpenTyCon {} = IfOpenDataTyCon + ifaceConDecls DataFamilyTyCon {} = IfOpenDataTyCon ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used @@ -1508,23 +1535,25 @@ 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) + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs InlineWrapper w -> IfWrapper arity (idName w) - InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) - InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) + 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 _con ops) +toIfUnfolding lb (DFunUnfolding _ar _con ops) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun