[project @ 2000-04-21 14:40:48 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / MkIface.lhs

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 6edc9d5..21991ea 100644 (file)
--- 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