[project @ 1996-06-26 10:26:00 by partain]

[ghc-hetmet.git] / ghc / compiler / basicTypes / IdInfo.lhs

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 8f35f6a..f6afdc1 100644 (file)
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -30,7 +30,7 @@ module IdInfo (
        mkDemandInfo,
        willBeDemanded,
 
-       MatchEnv,               -- the SpecEnv
+       MatchEnv,               -- the SpecEnv (why is this exported???)
        StrictnessInfo(..),     -- non-abstract
        Demand(..),             -- non-abstract
 
@@ -47,14 +47,14 @@ module IdInfo (
 
        UpdateInfo,
        mkUpdateInfo,
-       UpdateSpec(..),
+       SYN_IE(UpdateSpec),
        updateInfoMaybe,
 
        DeforestInfo(..),
 
        ArgUsageInfo,
        ArgUsage(..),
-       ArgUsageType(..),
+       SYN_IE(ArgUsageType),
        mkArgUsageInfo,
        getArgUsage,
 
@@ -67,28 +67,31 @@ module IdInfo (
 
     ) where
 
-import Ubiq
+IMP_Ubiq()
+IMPORT_1_3(Char(toLower))
 
-import IdLoop          -- IdInfo is a dependency-loop ranch, and
+IMPORT_DELOOPER(IdLoop)        -- IdInfo is a dependency-loop ranch, and
                        -- we break those loops by using IdLoop and
                        -- *not* importing much of anything else,
                        -- except from the very general "utils".
 
 import CmdLineOpts     ( opt_OmitInterfacePragmas )
 import Maybes          ( firstJust )
-import MatchEnv                ( nullMEnv, isEmptyMEnv, mEnvToList )
+import MatchEnv                ( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
 import Outputable      ( ifPprInterface, Outputable(..){-instances-} )
 import PprStyle                ( PprStyle(..) )
 import Pretty
 import SrcLoc          ( mkUnknownSrcLoc )
-import Type            ( eqSimpleTy )
+import Type            ( eqSimpleTy, splitFunTyExpandingDicts )
 import Util            ( mapAccumL, panic, assertPanic, pprPanic )
 
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
 applySubstToTy = panic "IdInfo.applySubstToTy"
-splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
 showTypeCategory = panic "IdInfo.showTypeCategory"
 mkFormSummary = panic "IdInfo.mkFormSummary"
-occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
 isWrapperFor = panic "IdInfo.isWrapperFor"
 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
 \end{code}
@@ -138,7 +141,7 @@ data IdInfo
        -- ToDo: SrcLoc is in FullNames too (could rm?)  but it
        -- is needed here too for things like ConstMethodIds and the
        -- like, which don't have full-names of their own Mind you,
-       -- perhaps the FullName for a constant method could give the
+       -- perhaps the Name for a constant method could give the
        -- class/type involved?
 \end{code}
 
@@ -422,7 +425,7 @@ instance OptIdInfo (MatchEnv [Type] CoreExpr) where
       = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 
 ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
-  = panic "IdInfo:ppSpecs"
+  = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
 \end{code}
 
 %************************************************************************
@@ -563,7 +566,7 @@ or an Absent {\em that we accept}.
 indicatesWorker :: [Demand] -> Bool
 
 indicatesWorker dems
-  = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
+  = fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
   where
     fake_mk_ww _ [] = False
     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
@@ -583,9 +586,8 @@ mkWrapperArgTypeCategories
        -> String       -- a string saying lots about the args
 
 mkWrapperArgTypeCategories wrapper_ty wrap_info
-  = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
-    map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
-    }
+  = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
+    map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
   where
     -- ToDo: this needs FIXING UP (it was a hack anyway...)
     do_one (WwPrim, _) = 'P'
@@ -609,7 +611,11 @@ as the worker requires.  Hence we have to give up altogether, and call
 the wrapper only; so under these circumstances we return \tr{False}.
 
 \begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read Demand where
+#else
 instance Text Demand where
+#endif
     readList str = read_em [{-acc-}] str
       where
        read_em acc []          = [(reverse acc, "")]
@@ -628,6 +634,9 @@ instance Text Demand where
 
        read_em acc other = panic ("IdInfo.readem:"++other)
 
+#ifdef REALLY_HASKELL_1_3
+instance Show Demand where
+#endif
     showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
       where
        show1 (WwLazy False) = "L"
@@ -727,8 +736,8 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 
 \begin{code}
 mkUnfolding guide expr
-  = GenForm False (mkFormSummary NoStrictnessInfo expr)
-       (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
+  = GenForm (mkFormSummary NoStrictnessInfo expr)
+       (occurAnalyseGlobalExpr expr)
        guide
 \end{code}
 
@@ -737,8 +746,8 @@ noInfo_UF = NoUnfoldingDetails
 
 getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
   = case unfolding of
-      GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
-      unfolding_as_was                      -> unfolding_as_was
+      GenForm _ _ BadUnfolding -> NoUnfoldingDetails
+      unfolding_as_was                -> unfolding_as_was
 
 -- getInfo_UF ensures that any BadUnfoldings are never returned
 -- We had to delay the test required in TcPragmas until now due
@@ -759,9 +768,9 @@ pp_unfolding sty for_this_id inline_env uf_details
     pp (MagicForm tag _)
       = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
 
-    pp (GenForm _ _ _ BadUnfolding) = pp_NONE
+    pp (GenForm _ _ BadUnfolding) = pp_NONE
 
-    pp (GenForm _ _ template guide)
+    pp (GenForm _ template guide)
       = let
            untagged = unTagBinders template
        in
@@ -800,7 +809,11 @@ updateInfoMaybe (SomeUpdateInfo     u) = Just u
 Text instance so that the update annotations can be read in.
 
 \begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read UpdateInfo where
+#else
 instance Text UpdateInfo where
+#endif
     readsPrec p s | null s    = panic "IdInfo: empty update pragma?!"
                  | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
       where