X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=0f7f0eb2ba40fb952a6662b17a25f9962f8e6fb0;hb=12899612693163154531da3285ec99c1c8ca2226;hp=4d2a2a138c90f68bcd2da1d7ae24382bf3fb24d3;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 4d2a2a1..0f7f0eb 100644
--- 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,27 +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 Outputable	( ifPprInterface, Outputable(..){-instances-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import SrcLoc		( mkUnknownSrcLoc )
 import Type		( eqSimpleTy, splitFunTyExpandingDicts )
+import Unique		( pprUnique )
 import Util		( mapAccumL, panic, assertPanic, pprPanic )
 
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
 applySubstToTy = panic "IdInfo.applySubstToTy"
 showTypeCategory = panic "IdInfo.showTypeCategory"
 mkFormSummary = panic "IdInfo.mkFormSummary"
-occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
 isWrapperFor = panic "IdInfo.isWrapperFor"
 pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
 \end{code}
@@ -112,16 +116,13 @@ data IdInfo
 	DemandInfo		-- Whether or not it is definitely
 				-- demanded
 
-	(MatchEnv [Type] CoreExpr)
-				-- Specialisations of this function which exist
-				-- This corresponds to a SpecEnv which we do
-				-- not import directly to avoid loop
+	SpecEnv			-- Specialisations of this function which exist
 
 	StrictnessInfo		-- Strictness properties, notably
 				-- how to conjure up "worker" functions
 
-	UnfoldingDetails	-- Its unfolding; for locally-defined
-				-- things, this can *only* be NoUnfoldingDetails
+	Unfolding		-- Its unfolding; for locally-defined
+				-- things, this can *only* be NoUnfolding
 
 	UpdateInfo		-- Which args should be updated
 
@@ -157,7 +158,7 @@ boringIdInfo (IdInfo UnknownArity
 		     _ {- no f/b w/w -}
 		     _ {- src_loc: no effect on interfaces-}
 	      )
-	      |  null (mEnvToList specenv)
+	      |  isNullSpecEnv specenv
 	      && boring_strictness strictness
 	      && boring_unfolding unfolding
   = True
@@ -166,8 +167,8 @@ boringIdInfo (IdInfo UnknownArity
     boring_strictness BottomGuaranteed = False
     boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
 
-    boring_unfolding NoUnfoldingDetails = True
-    boring_unfolding _	    	    	= False
+    boring_unfolding NoUnfolding = True
+    boring_unfolding _	    	 = False
 
 boringIdInfo _ = False
 
@@ -180,7 +181,7 @@ nasty loop, friends...)
 \begin{code}
 apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
 			      update deforest arg_usage fb_ww srcloc)
-  | isEmptyMEnv spec
+  | isNullSpecEnv spec
   = idinfo
   | otherwise
   = panic "IdInfo:apply_to_IdInfo"
@@ -248,7 +249,7 @@ ppIdInfo :: PprStyle
 	 -> Id		-- The Id for which we're printing this IdInfo
 	 -> Bool	-- True <=> print specialisations, please
 	 -> (Id -> Id)	-- to look up "better Ids" w/ better IdInfos;
-	 -> IdEnv UnfoldingDetails
+	 -> IdEnv Unfolding
 			-- inlining info for top-level fns in this module
 	 -> IdInfo	-- see MkIface notes
 	 -> Pretty
@@ -274,8 +275,8 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
 		    else pp_unfolding sty for_this_id inline_env unfold,
 
 		    if specs_please
-		    then ppSpecs sty (not (isDataCon for_this_id))
-				 better_id_fn inline_env (mEnvToList specenv)
+		    then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
+					 -- better_id_fn inline_env (mEnvToList specenv)
 		    else pp_NONE,
 
 		    -- DemandInfo needn't be printed since it has no effect on interfaces
@@ -409,19 +410,16 @@ instance OptIdInfo DemandInfo where
 See SpecEnv.lhs
 
 \begin{code}
-instance OptIdInfo (MatchEnv [Type] CoreExpr) where
-    noInfo = nullMEnv
+instance OptIdInfo SpecEnv where
+    noInfo = nullSpecEnv
 
     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 
-    addInfo id_info spec | null (mEnvToList spec) = id_info
+    addInfo id_info spec | isNullSpecEnv spec = id_info
     addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
 
-    ppInfo sty better_id_fn spec
-      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
-
-ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
-  = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
+    ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
+--      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 \end{code}
 
 %************************************************************************
@@ -562,7 +560,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 (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
   where
     fake_mk_ww _ [] = False
     fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
@@ -607,7 +605,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, "")]
@@ -626,6 +628,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"
@@ -725,25 +730,18 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 
 \begin{code}
 mkUnfolding guide expr
-  = GenForm False (mkFormSummary NoStrictnessInfo expr)
-	(occurAnalyseGlobalExpr expr)
-	guide
+  = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
+				   guide
+				   (occurAnalyseGlobalExpr expr))
 \end{code}
 
 \begin{code}
-noInfo_UF = NoUnfoldingDetails
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
-  = case unfolding of
-      GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
-      unfolding_as_was 		     -> unfolding_as_was
+noInfo_UF = NoUnfolding
 
--- getInfo_UF ensures that any BadUnfoldings are never returned
--- We had to delay the test required in TcPragmas until now due
--- to strictness constraints in TcPragmas
+getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
 
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF   (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
+addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
+addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
 \end{code}
 
 \begin{code}
@@ -752,14 +750,12 @@ pp_unfolding sty for_this_id inline_env uf_details
       Nothing -> pp uf_details
       Just dt -> pp dt
   where
-    pp NoUnfoldingDetails = pp_NONE
+    pp NoUnfolding = pp_NONE
 
-    pp (MagicForm tag _)
-      = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
+    pp (MagicUnfolding tag _)
+      = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
 
-    pp (GenForm _ _ _ BadUnfolding) = pp_NONE
-
-    pp (GenForm _ _ template guide)
+    pp (CoreUnfolding (SimpleUnfolding _ guide template))
       = let
 	    untagged = unTagBinders template
 	in
@@ -798,7 +794,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