[project @ 1999-04-14 04:07:57 by kglynn]

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

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index b792459..af158b4 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -36,17 +36,19 @@ import IdInfo               ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePr
                          arityInfo, ppArityInfo, 
                          strictnessInfo, ppStrictnessInfo, 
                          cafInfo, ppCafInfo,
-                         workerExists, isBottomingStrictness
+                         cprInfo, ppCprInfo,
+                         workerExists, workerInfo, isBottomingStrictness
                        )
 import CoreSyn         ( CoreExpr, CoreBind, Bind(..) )
 import CoreUtils       ( exprSomeFreeVars )
 import CoreUnfold      ( calcUnfoldingGuidance, UnfoldingGuidance(..), 
                          Unfolding, okToUnfoldInHiFile )
+import Module          ( moduleString, pprModule, pprModuleBoot )
 import Name            ( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
                          isExported,
                          Name, NamedThing(..)
                        )
-import OccName         ( OccName, pprOccName, moduleString, pprModule, pprModuleBoot )
+import OccName         ( OccName, pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
                          tyConTheta, tyConTyVars, tyConDataCons
                        )
@@ -276,6 +278,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
      | otherwise               = hsep [ptext SLIT("{-##"),
                                        arity_pretty, 
                                        caf_pretty,
+                                       cpr_pretty,
                                        strict_pretty, 
                                        unfold_pretty, 
                                        spec_pretty,
@@ -287,9 +290,13 @@ ifaceId get_idinfo needed_ids is_rec id rhs
     ------------ Caf Info --------------
     caf_pretty = ppCafInfo (cafInfo idinfo)
 
-    ------------  Strictness  --------------
+    ------------ CPR Info --------------
+    cpr_pretty = ppCprInfo (cprInfo idinfo)
+
+    ------------  Strictness and Worker  --------------
     strict_info   = strictnessInfo idinfo
-    has_worker    = workerExists strict_info
+    work_info     = workerInfo idinfo
+    has_worker    = workerExists work_info
     bottoming_fn  = isBottomingStrictness strict_info
     strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
 
@@ -298,8 +305,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs
                | otherwise      = ppr work_id <+> 
                                   braces (hsep (map ppr con_list))
 
-    (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
-    con_list               = uniqSetToList wrapper_cons
+--    (Just work_id) = work_info
+-- Temporary fix.  We can't use the worker id saved by the w/w
+-- pass because later optimisations may have changed it.  So try
+-- to snaffle from the wrapper code again ...
+    (work_id, wrapper_cons)   = getWorkerIdAndCons id rhs
+    con_list       = uniqSetToList wrapper_cons
 
     ------------  Unfolding  --------------
     unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
@@ -347,8 +358,10 @@ ifaceId get_idinfo needed_ids is_rec id rhs
                                           unfold_ids   `unionVarSet`
                                           spec_ids
 
-    worker_ids | has_worker = unitVarSet work_id
-              | otherwise  = emptyVarSet
+    worker_ids | has_worker && interesting work_id = unitVarSet work_id
+                       -- Conceivably, the worker might come from
+                       -- another module
+              | otherwise                         = emptyVarSet
 
     spec_ids = foldr add emptyVarSet spec_list
             where
@@ -360,8 +373,9 @@ ifaceId get_idinfo needed_ids is_rec id rhs
     find_fvs expr = free_vars
                  where
                    free_vars = exprSomeFreeVars interesting expr
-                   interesting id = isId id && isLocallyDefined id &&
-                                    not (omitIfaceSigForId id)
+
+    interesting id = isId id && isLocallyDefined id &&
+                    not (omitIfaceSigForId id)
 \end{code}
 
 \begin{code}
@@ -494,11 +508,9 @@ ifaceTyCon tycon
 
     ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
 
-    ppr_strict_mark NotMarkedStrict = empty
-    ppr_strict_mark MarkedStrict    = ptext SLIT("! ")
-                               -- The extra space helps the lexical analyser that lexes
-                               -- interface files; it doesn't make the rigid operator/identifier
-                               -- distinction, so "!a" is a valid identifier so far as it is concerned
+    ppr_strict_mark NotMarkedStrict        = empty
+    ppr_strict_mark (MarkedUnboxed _ _)    = ptext SLIT("! ! ")
+    ppr_strict_mark MarkedStrict           = ptext SLIT("! ")
 
     ppr_field (strict_mark, field_label)
        = hsep [ ppr (fieldLabelName field_label),
@@ -540,7 +552,8 @@ ppr_decl_context []    = empty
 ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
 
 pprIfaceTheta :: ThetaType -> SDoc     -- Use braces rather than parens in interface files
-pprIfaceTheta theta =  braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
+pprIfaceTheta []    = empty
+pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
 \end{code}
 
 %************************************************************************