X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=4bfc2c864f6c85855f3d8a91ba7d2b82bcb7e410;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=8f35f6af71ecf4118bcfeef571e9f26e773065e6;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 8f35f6a..4bfc2c8 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -30,7 +30,6 @@ module IdInfo (
 	mkDemandInfo,
 	willBeDemanded,
 
-	MatchEnv,		-- the SpecEnv
 	StrictnessInfo(..), 	-- non-abstract
 	Demand(..),	    	-- non-abstract
 
@@ -47,14 +46,14 @@ module IdInfo (
 
 	UpdateInfo,
 	mkUpdateInfo,
-	UpdateSpec(..),
+	SYN_IE(UpdateSpec),
 	updateInfoMaybe,
 
 	DeforestInfo(..),
 
 	ArgUsageInfo,
 	ArgUsage(..),
-	ArgUsageType(..),
+	SYN_IE(ArgUsageType),
 	mkArgUsageInfo,
 	getArgUsage,
 
@@ -67,28 +66,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 )
+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"
-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}
@@ -113,16 +115,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
 
@@ -138,7 +137,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}
 
@@ -158,7 +157,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
@@ -167,8 +166,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
 
@@ -181,7 +180,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"
@@ -249,7 +248,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
@@ -275,8 +274,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 pp_NONE -- 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
@@ -410,19 +409,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
-  = panic "IdInfo:ppSpecs"
+    ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
+--      = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
 \end{code}
 
 %************************************************************************
@@ -563,7 +559,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
@@ -583,9 +579,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 +604,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 +627,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,25 +729,18 @@ 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)
-	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}
@@ -754,14 +749,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
@@ -800,7 +793,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