[project @ 1998-04-08 16:48:14 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 5b5c213..e3648e7 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -29,15 +29,14 @@ import WorkWrap             ( getWorkerIdAndCons )
 
 import CmdLineOpts
 import Id              ( idType, dataConRawArgTys, dataConFieldLabels, 
-                         getIdInfo, getInlinePragma, omitIfaceSigForId,
+                         idInfo, omitIfaceSigForId,
                          dataConStrictMarks, StrictnessMark(..), 
                          IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet, 
                          isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
-                         pprId,
+                         pprId, getIdSpecialisation,
                          Id
-
                        )
-import IdInfo          ( IdInfo, StrictnessInfo, ArityInfo, 
+import IdInfo          ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
                          arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, 
                          bottomIsGuaranteed, workerExists, 
                        )
@@ -52,6 +51,7 @@ import TyCon          ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
                          tyConTheta, tyConTyVars, tyConDataCons
                        )
 import Class           ( Class, classBigSig )
+import SpecEnv         ( specEnvToList )
 import FieldLabel      ( fieldLabelName, fieldLabelType )
 import Type            ( mkSigmaTy, splitSigmaTy, mkDictTy,
                          mkTyVarTys, Type, ThetaType
@@ -261,14 +261,15 @@ ifaceId get_idinfo needed_ids is_rec id rhs
   where
     pp_double_semi = ptext SLIT(";;")
     idinfo         = get_idinfo id
-    inline_pragma  = getInlinePragma id 
+    inline_pragma  = inlinePragInfo idinfo
 
     ty_pretty  = pprType (nmbrGlobalType (idType id))
     sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
 
     prag_pretty 
      | opt_OmitInterfacePragmas = empty
-     | otherwise               = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
+     | otherwise               = hsep [arity_pretty, strict_pretty, unfold_pretty, 
+                                       spec_pretty, pp_double_semi]
 
     ------------  Arity  --------------
     arity_pretty  = ppArityInfo (arityInfo idinfo)
@@ -287,23 +288,42 @@ ifaceId get_idinfo needed_ids is_rec id rhs
     con_list              = idSetToList wrapper_cons
 
     ------------  Unfolding  --------------
-    unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs]
+    unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
                  | otherwise   = empty
 
-    show_unfold = not implicit_unfolding &&            -- Not unnecessary
-                 not dodgy_unfolding                   -- Not dangerous
+    unfold_herald = case inline_pragma of
+                       IMustBeINLINEd   -> SLIT("_U_")
+                       IWantToBeINLINEd -> SLIT("_U_")
+                       other            -> SLIT("_u_")
+
+    show_unfold = not implicit_unfolding &&    -- Not unnecessary
+                 unfolding_is_ok               -- Not dangerous
 
     implicit_unfolding = has_worker ||
                         bottomIsGuaranteed strict_info
 
-    dodgy_unfolding = case guidance of                         -- True <=> too big to show, or the Inline pragma
-                       UnfoldNever -> True             -- says it shouldn't be inlined
-                       other       -> False
-
-    guidance    = calcUnfoldingGuidance inline_pragma
-                                       opt_InterfaceUnfoldThreshold
-                                       rhs
-
+    unfolding_is_ok
+       = case inline_pragma of
+           IMustBeINLINEd    -> True
+           IWantToBeINLINEd  -> True
+           IMustNotBeINLINEd -> False
+           NoPragmaInfo      -> case guidance of
+                                       UnfoldNever -> False    -- Too big
+                                       other       -> True
+
+    guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
+
+    ------------  Specialisations --------------
+    spec_list = specEnvToList (getIdSpecialisation id)
+    spec_pretty = hsep (map pp_spec spec_list)
+    pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
+                                      if null tyvars then ptext SLIT("[ ]")
+                                                     else brackets (interppSP tyvars),
+                                       -- The lexer interprets "[]" as a CONID.  Sigh.
+                                      hsep (map pprParendType tys),
+                                      ptext SLIT("="),
+                                      pprIfaceUnfolding rhs
+                                ]
     
     ------------  Extra free Ids  --------------
     new_needed_ids = (needed_ids `minusIdSet` unitIdSet id)    `unionIdSets` 
@@ -311,18 +331,25 @@ ifaceId get_idinfo needed_ids is_rec id rhs
 
     extra_ids | opt_OmitInterfacePragmas = emptyIdSet
              | otherwise                = worker_ids   `unionIdSets`
-                                          unfold_ids
+                                          unfold_ids   `unionIdSets`
+                                          spec_ids
 
     worker_ids | has_worker = unitIdSet work_id
               | otherwise  = emptyIdSet
 
-    unfold_ids | show_unfold = free_vars
+    spec_ids = foldr add emptyIdSet spec_list
+            where
+              add (_, _, rhs) = unionIdSets (find_fvs rhs)
+
+    unfold_ids | show_unfold = find_fvs rhs
               | otherwise   = emptyIdSet
-                            where
-                              (_,free_vars) = addExprFVs interesting emptyIdSet rhs
-                              interesting bound id = isLocallyDefined id &&
-                                                     not (id `elementOfIdSet` bound) &&
-                                                     not (omitIfaceSigForId id)
+
+    find_fvs expr = free_vars
+                 where
+                   (_,free_vars) = addExprFVs interesting emptyIdSet expr
+                   interesting bound id = isLocallyDefined id &&
+                                          not (id `elementOfIdSet` bound) &&
+                                          not (omitIfaceSigForId id)
 \end{code}
 
 \begin{code}
@@ -338,9 +365,9 @@ ifaceBinds hdl needed_ids final_ids binds
   where
     final_id_map  = listToUFM [(id,id) | id <- final_ids]
     get_idinfo id = case lookupUFM final_id_map id of
-                       Just id' -> getIdInfo id'
+                       Just id' -> idInfo id'
                        Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
-                                   getIdInfo id
+                                   idInfo id
 
     pretties = go needed_ids (reverse binds)   -- Reverse so that later things will 
                                                -- provoke earlier ones to be emitted