[project @ 1998-04-07 16:40:08 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 255dc59..b72b73e 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -12,7 +12,8 @@ module MkIface (
 
 #include "HsVersions.h"
 
-import IO              ( Handle, hPutStr, openFile, hClose, IOMode(..) )
+import IO              ( Handle, hPutStr, openFile, 
+                         hClose, hPutStrLn, IOMode(..) )
 
 import HsSyn
 import RdrHsSyn                ( RdrName(..) )
@@ -28,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, 
                        )
@@ -51,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
@@ -99,9 +100,9 @@ endIface    :: Maybe Handle -> IO ()
 startIface mod
   = case opt_ProduceHi of
       Nothing -> return Nothing -- not producing any .hi file
-      Just fn ->
-       openFile fn WriteMode   >>= \ if_hdl ->
-       hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
+      Just fn -> do
+       if_hdl <- openFile fn WriteMode
+       hPutStrLn if_hdl ("_interface_ "++ _UNPK_ mod ++ ' ':show (PROJECTVERSION :: Int))
        return (Just if_hdl)
 
 endIface Nothing       = return ()
@@ -260,14 +261,14 @@ 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)
@@ -286,23 +287,41 @@ 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_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
+    pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
+                                      if null tyvars then ptext SLIT("[ ]")
+                                                     else brackets (interpp'SP 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` 
@@ -337,9 +356,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