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

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 6946df3..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,
 
@@ -68,21 +67,21 @@ module IdInfo (
     ) where
 
 IMP_Ubiq()
+IMPORT_1_3(Char(toLower))
 
-IMPORT_DELOOPER(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 OccurAnal	( occurAnalyseGlobalExpr )
 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
@@ -116,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
 
@@ -161,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
@@ -170,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
 
@@ -184,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"
@@ -252,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
@@ -278,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
@@ -413,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
-  = 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}
 
 %************************************************************************
@@ -566,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
@@ -736,25 +729,18 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
 
 \begin{code}
 mkUnfolding guide expr
-  = GenForm (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}
@@ -763,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 (MagicForm tag _)
-      = ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
+    pp NoUnfolding = pp_NONE
 
-    pp (GenForm _ _ BadUnfolding) = pp_NONE
+    pp (MagicUnfolding tag _)
+      = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
 
-    pp (GenForm _ template guide)
+    pp (CoreUnfolding (SimpleUnfolding _ guide template))
       = let
 	    untagged = unTagBinders template
 	in