[project @ 1999-12-09 12:30:56 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 e823e47..224e31e 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -27,11 +27,12 @@ import Id           ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
 import Var             ( isId )
 import VarSet
 import DataCon         ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo          ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
-                         arityInfo, ppArityInfo, 
+import IdInfo          ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo,
+                         arityInfo, ppArityInfo, arityLowerBound,
                          strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
                          cafInfo, ppCafInfo, specInfo,
-                         cprInfo, ppCprInfo,
+                         cprInfo, ppCprInfo, pprInlinePragInfo,
+                         occInfo, OccInfo(..),
                          workerExists, workerInfo, ppWorkerInfo
                        )
 import CoreSyn         ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
@@ -45,7 +46,7 @@ import OccName                ( OccName, pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
                          tyConTheta, tyConTyVars, tyConDataCons
                        )
-import Class           ( Class, classBigSig )
+import Class           ( Class, classExtraBigSig )
 import FieldLabel      ( fieldLabelName, fieldLabelType )
 import Type            ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
                          Type, ThetaType
@@ -53,6 +54,7 @@ import Type           ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
 
 import PprType
 import PprCore         ( pprIfaceUnfolding, pprCoreRule )
+import FunDeps         ( pprFundeps )
 import Rules           ( pprProtoCoreRule, ProtoCoreRule(..) )
 
 import Bag             ( bagToList, isEmptyBag )
@@ -89,7 +91,7 @@ endIface    :: Maybe Handle -> IO ()
 \end{code}
 
 \begin{code}
-startIface mod (has_orphans, import_usages, ExportEnv avails fixities)
+startIface mod (has_orphans, import_usages, ExportEnv avails fixities _)
   = case opt_ProduceHi of
       Nothing -> return Nothing ; -- not producing any .hi file
 
@@ -290,7 +292,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
   = Nothing            -- Well, that was easy!
 
 ifaceId get_idinfo needed_ids is_rec id rhs
-  = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
+  = ASSERT2( arity_matches_strictness, ppr id )
+    Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
   where
     core_idinfo = idInfo id
     stg_idinfo  = get_idinfo id
@@ -310,7 +313,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
                                        ptext SLIT("##-}")]
 
     ------------  Arity  --------------
-    arity_pretty  = ppArityInfo (arityInfo stg_idinfo)
+    arity_info    = arityInfo stg_idinfo
+    arity_pretty  = ppArityInfo arity_info
 
     ------------ Caf Info --------------
     caf_pretty = ppCafInfo (cafInfo stg_idinfo)
@@ -330,19 +334,25 @@ ifaceId get_idinfo needed_ids is_rec id rhs
     Just work_id  = work_info
 
 
+    ------------  Occ info  --------------
+    loop_breaker  = case occInfo core_idinfo of
+                       IAmALoopBreaker -> True
+                       other           -> False
+
     ------------  Unfolding  --------------
     inline_pragma  = inlinePragInfo core_idinfo
     dont_inline           = case inline_pragma of
-                       IMustNotBeINLINEd -> True
-                       IAmALoopBreaker   -> True
-                       other             -> False
+                       IMustNotBeINLINEd False Nothing -> True -- Unconditional NOINLINE
+                       other                           -> False
+
 
-    unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs
+    unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
                  | otherwise   = empty
 
     show_unfold = not has_worker        &&     -- Not unnecessary
                  not bottoming_fn       &&     -- Not necessary
                  not dont_inline        &&
+                 not loop_breaker       &&
                  rhs_is_small           &&     -- Small enough
                  okToUnfoldInHiFile rhs        -- No casms etc
 
@@ -369,6 +379,16 @@ ifaceId get_idinfo needed_ids is_rec id rhs
 
     find_fvs expr = exprSomeFreeVars interestingId expr
 
+    ------------ 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
+    
 interestingId id = isId id && isLocallyDefined id &&
                   not (omitIfaceSigForId id)
 \end{code}
@@ -530,21 +550,22 @@ ifaceClass clas
           ppr_decl_context sc_theta,
           ppr clas,                    -- Print the name
           pprTyVarBndrs clas_tyvars,
+          pprFundeps clas_fds,
           pp_ops,
           semi
          ]
    where
-     (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas
+     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 
-     pp_ops | null sel_ids  = empty
-           | otherwise = hsep [ptext SLIT("where"),
-                                braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms)))
-                         ]
+     pp_ops | null op_stuff  = empty
+           | otherwise      = hsep [ptext SLIT("where"),
+                                    braces (hsep (punctuate semi (map ppr_classop op_stuff)))
+                              ]
 
-     ppr_classop sel_id maybe_defm
+     ppr_classop (sel_id, dm_id, explicit_dm)
        = ASSERT( sel_tyvars == clas_tyvars)
          hsep [ppr (getOccName sel_id),
-               if maybeToBool maybe_defm then equals else empty,
+               if explicit_dm then equals else empty,
                dcolon,
                ppr op_ty
          ]