X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=21991ea247fa350f7a3e5f9272ea2be5fd05291b;hb=0666c3bb2433ade3ac9582f58126abb4ebcf548b;hp=6edc9d557082012244d91e3c2e2dd709ea886712;hpb=c01dc71dffd1977bf556167d7174e39eed69d61f;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 6edc9d5..21991ea 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -14,7 +14,9 @@ import IO ( Handle, hPutStr, openFile, hClose, hPutStrLn, IOMode(..) ) import HsSyn -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), + OccInfo, isLoopBreaker + ) import RnMonad import RnEnv ( availName ) @@ -22,7 +24,7 @@ import TcInstUtil ( InstInfo(..) ) import CmdLineOpts import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, - getIdSpecialisation + idSpecialisation ) import Var ( isId ) import VarSet @@ -32,12 +34,12 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inli strictnessInfo, ppStrictnessInfo, isBottomingStrictness, cafInfo, ppCafInfo, specInfo, cprInfo, ppCprInfo, pprInlinePragInfo, - occInfo, OccInfo(..), - workerExists, workerInfo, ppWorkerInfo + occInfo, + workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..) ) import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) -import CoreUnfold ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline ) +import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) import Module ( moduleString, pprModule, pprModuleName ) import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, Name, NamedThing(..) @@ -103,8 +105,8 @@ startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fix Just fn -> do if_hdl <- openFile fn WriteMode - hPutStr if_hdl ("__interface " ++ moduleString mod) - hPutStr if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator) + hPutStr if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod) + hPutStr if_hdl (' ' : orphan_indicator) hPutStrLn if_hdl " where" ifaceExports if_hdl avails ifaceImports if_hdl import_usages @@ -155,14 +157,16 @@ ifaceImports :: Handle -> VersionInfo Name -> IO () ifaceImports if_hdl import_usages = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - upp_uses (m, mv, has_orphans, whats_imported) + upp_uses (m, mv, has_orphans, is_boot, whats_imported) = hsep [ptext SLIT("import"), pprModuleName m, - int mv, pp_orphan, + int mv, pp_orphan, pp_boot, upp_import_versions whats_imported ] <> semi where pp_orphan | has_orphans = ptext SLIT("!") | otherwise = empty + pp_boot | is_boot = ptext SLIT("@") + | otherwise = empty -- Importing the whole module is indicated by an empty list upp_import_versions Everything = empty @@ -212,7 +216,9 @@ ifaceFixities if_hdl fixities ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO () ifaceRules if_hdl rules emitted - | null orphan_rule_pretties && null local_id_pretties + | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing + -- interface pragmas + || (null orphan_rule_pretties && null local_id_pretties) = return () | otherwise = printForIface if_hdl (vcat [ @@ -227,9 +233,10 @@ ifaceRules if_hdl rules emitted ] local_id_pretties = [ pprCoreRule (Just fn) rule | fn <- varSetElems emitted, - rule <- rulesRules (getIdSpecialisation fn), + rule <- rulesRules (idSpecialisation fn), all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) -- Spit out a rule only if all its lhs free vars are emitted + -- This is a good reason not to do it when we emit the Id itself ] ifaceDeprecations :: Handle -> [Deprecation Name] -> IO () @@ -237,12 +244,15 @@ ifaceDeprecations if_hdl [] = return () ifaceDeprecations if_hdl deprecations = printForIface if_hdl (vcat [ ptext SLIT("{-## __D"), - vcat [ pprIfaceDeprec d <> semi | d <- deprecations ], + vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ], ptext SLIT("##-}") ]) where - pprIfaceDeprec (DeprecMod txt) = doubleQuotes (ppr txt) - pprIfaceDeprec (DeprecName n txt) = ppr n <+> doubleQuotes (ppr txt) + pprIE (IEVar n ) = ppr n + pprIE (IEThingAbs n ) = ppr n + pprIE (IEThingAll n ) = hcat [ppr n, text "(..)"] + pprIE (IEThingWith n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns))) + pprIE (IEModuleContents _ ) = empty \end{code} %************************************************************************ @@ -354,13 +364,11 @@ ifaceId get_idinfo needed_ids is_rec id rhs work_info = workerInfo core_idinfo has_worker = workerExists work_info wrkr_pretty = ppWorkerInfo work_info - Just work_id = work_info + HasWorker work_id wrap_arity = work_info ------------ Occ info -------------- - loop_breaker = case occInfo core_idinfo of - IAmALoopBreaker -> True - other -> False + loop_breaker = isLoopBreaker (occInfo core_idinfo) ------------ Unfolding -------------- inline_pragma = inlinePragInfo core_idinfo @@ -379,7 +387,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs rhs_is_small && -- Small enough okToUnfoldInHiFile rhs -- No casms etc - rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs) + rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs ------------ Specialisations -------------- spec_info = specInfo core_idinfo @@ -405,12 +413,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Sanity checking -------------- -- The arity of a wrapper function should match its strictness, -- or else an importing module will get very confused indeed. - -- [later: actually all that is necessary is for strictness to exceed arity] - arity_matches_strictness - = not has_worker || - case strict_info of - StrictnessInfo ds _ -> length ds >= arityLowerBound arity_info - other -> True + arity_matches_strictness = not has_worker || + wrap_arity == arityLowerBound arity_info interestingId id = isId id && isLocallyDefined id && not (omitIfaceSigForId id) @@ -675,7 +679,7 @@ lt_lexical :: NamedThing a => a -> a -> Bool lt_lexical a1 a2 = getName a1 `lt_name` getName a2 lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool -lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2 +lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2 sort_versions vs = sortLt lt_vers vs