[project @ 2001-10-04 08:35:24 by simonpj]

Heal the HEAD

ghc/compiler/basicTypes/NewDemand.lhs

@@ -21,7 +21,7 @@ module NewDemand(
 #include "HsVersions.h"
 
 import BasicTypes	( Arity )
-import VarEnv		( VarEnv, emptyVarEnv )
+import VarEnv		( VarEnv, emptyVarEnv, isEmptyVarEnv )
 import UniqFM		( ufmToList )
 import Outputable
 \end{code}
@@ -82,8 +82,8 @@ botDmdType = DmdType emptyDmdEnv [] BotRes
 
 isTopDmdType :: DmdType -> Bool
 -- Only used on top-level types, hence the assert
-isTopDmdType (DmdType _ [] TopRes) = ASSERT( isEmptyVarEnv env) True	
-isTopDmdType other		   = False
+isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True	
+isTopDmdType other		     = False
 
 isBotRes :: DmdResult -> Bool
 isBotRes BotRes = True

ghc/compiler/coreSyn/CoreTidy.lhs

@@ -28,7 +28,7 @@ import Id		( idType, idInfo, idName, isExportedId,
 			  idNewStrictness, setIdNewStrictness
 			) 
 import IdInfo		{- loads of stuff -}
-import NewDemand	( isBottomingSig, topSig, isStrictDmd, isTopSig )
+import NewDemand	( isBottomingSig, topSig )
 import BasicTypes	( isNeverActive )
 import Name		( getOccName, nameOccName, globaliseName, setNameOcc, 
 		  	  localiseName, isGlobalName, setNameUnique
@@ -51,7 +51,7 @@ import UniqFM		( mapUFM )
 import UniqSupply	( splitUniqSupply, uniqFromSupply )
 import List		( partition )
 import Util		( mapAccumL )
-import Maybe		( isJust, fromJust, isNothing )
+import Maybe		( isJust )
 import Outputable
 \end{code}
 
@@ -639,19 +639,13 @@ tidyLetBndr env (id,rhs)
 	--
 	-- Similarly for the demand info - on a let binder, this tells 
 	-- CorePrep to turn the let into a case.
-    final_id
-	| totally_boring_info = new_id
-	| otherwise = new_id `setIdNewDemandInfo` dmd_info
-			     `setIdNewStrictness` new_strictness
+    final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id
+		      `setIdNewStrictness` idNewStrictness id
 
-    -- override the env we get back from tidyId with the new IdInfo
+    -- Override the env we get back from tidyId with the new IdInfo
     -- so it gets propagated to the usage sites.
     new_var_env = extendVarEnv var_env id final_id
 
-    dmd_info		 = idNewDemandInfo id
-    new_strictness       = idNewStrictness id
-    totally_boring_info  = isTopSig new_strictness && not (isStrictDmd dmd_info) 
-
 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
 tidyIdBndr env@(tidy_env, var_env) id
   = 	-- Non-top-level variables

ghc/compiler/main/MkIface.lhs

@@ -20,6 +20,7 @@ import TysPrim		( alphaTyVars )
 import BasicTypes	( Fixity(..), NewOrData(..), Activation(..),
 			  Version, initialVersion, bumpVersion 
 			)
+import NewDemand	( isTopSig )
 import RnMonad
 import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl )
 import HscTypes		( VersionInfo(..), ModIface(..), ModDetails(..),
@@ -272,9 +273,10 @@ ifaceTyCls (AnId id) = iface_sig
 		   otherwise -> []
 
     ------------  Strictness  --------------
+	-- No point in explicitly exporting TopSig
     strict_hsinfo = case newStrictnessInfo id_info of
-			Nothing  -> []
-			Just sig -> [HsStrictness sig]
+			Just sig | not (isTopSig sig) -> [HsStrictness sig]
+			other			      -> []
 
     ------------  Worker  --------------
     work_info   = workerInfo id_info

ghc/compiler/simplCore/SimplUtils.lhs

@@ -5,7 +5,8 @@
 
 \begin{code}
 module SimplUtils (
-	simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
+	simplBinder, simplBinders, simplRecBndrs, simplLetBndr, 
+	simplLamBndrs, simplTopBndrs,
 	newId, mkLam, mkCase,
 
 	-- The continuation type
@@ -29,7 +30,7 @@ import CoreUtils	( cheapEqExpr, exprType,
 			  findDefault, exprOkForSpeculation, exprIsValue
 			)
 import qualified Subst	( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id		( Id, idType, idInfo,
+import Id		( Id, idType, idInfo, isLocalId,
 			  mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
 			  idUnfolding, idNewStrictness
 			)
@@ -438,30 +439,41 @@ simplBinder env bndr
     returnSmpl (setSubst env subst', bndr')
 
 
-simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplLamBinders env bndrs
-  = let
-	(subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
-    in
-    seqBndrs bndrs'	`seq`
-    returnSmpl (setSubst env subst', bndrs')
-
-simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecIds env ids
-  = let
-	(subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
-    in
-    seqBndrs ids'	`seq`
-    returnSmpl (setSubst env subst', ids')
-
-simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetId env id
+simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplLetBndr env id
   = let
 	(subst', id') = Subst.simplLetId (getSubst env) id
     in
     seqBndr id'		`seq`
     returnSmpl (setSubst env subst', id')
 
+simplTopBndrs, simplLamBndrs, simplRecBndrs 
+	:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplTopBndrs = simplBndrs simplTopBinder
+simplRecBndrs = simplBndrs Subst.simplLetId
+simplLamBndrs = simplBndrs Subst.simplLamBndr
+
+-- For top-level binders, don't use simplLetId for GlobalIds. 
+-- There are some of these, notably consructor wrappers, and we don't
+-- want to clone them or fiddle with them at all.  
+-- Rather tiresomely, the specialiser may float a use of a constructor
+-- wrapper to before its definition (which shouldn't really matter)
+-- because it doesn't see the constructor wrapper as free in the binding
+-- it is floating (because it's a GlobalId).
+-- Then the simplifier brings all top level Ids into scope at the
+-- beginning, and we don't want to lose the IdInfo on the constructor
+-- wrappers.  It would also be Bad to clone it!
+simplTopBinder subst bndr
+  | isLocalId bndr = Subst.simplLetId subst bndr
+  | otherwise	   = (subst, bndr)
+
+simplBndrs simpl_bndr env bndrs
+  = let
+	(subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
+    in
+    seqBndrs bndrs'	`seq`
+    returnSmpl (setSubst env subst', bndrs')
+
 seqBndrs [] = ()
 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 

ghc/compiler/simplCore/Simplify.lhs

@@ -13,8 +13,8 @@ import CmdLineOpts	( dopt, DynFlag(Opt_D_dump_inlinings),
 			)
 import SimplMonad
 import SimplUtils	( mkCase, mkLam, newId,
-			  simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
-			  SimplCont(..), DupFlag(..), LetRhsFlag(..), 
+			  simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
+			  simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..), 
 			  mkStop, mkBoringStop,  pushContArgs,
 			  contResultType, countArgs, contIsDupable, contIsRhsOrArg,
 			  getContArgs, interestingCallContext, interestingArg, isStrictType
@@ -24,7 +24,7 @@ import VarEnv
 import Id		( Id, idType, idInfo, idArity, isDataConId, 
 			  idUnfolding, setIdUnfolding, isDeadBinder,
 			  idNewDemandInfo, setIdInfo,
-			  setIdOccInfo, 
+			  setIdOccInfo, isLocalId,
 			  zapLamIdInfo, setOneShotLambda, 
 			)
 import IdInfo		( OccInfo(..), isLoopBreaker,
@@ -230,7 +230,7 @@ simplTopBinds env binds
 	-- so that if a transformation rule has unexpectedly brought
 	-- anything into scope, then we don't get a complaint about that.
 	-- It's rather as if the top-level binders were imported.
-    simplRecIds env (bindersOfBinds binds)	`thenSmpl` \ (env, bndrs') -> 
+    simplTopBndrs env (bindersOfBinds binds)	`thenSmpl` \ (env, bndrs') -> 
     simpl_binds env binds bndrs'		`thenSmpl` \ (floats, _) ->
     freeTick SimplifierDone			`thenSmpl_`
     returnSmpl (floatBinds floats)
@@ -296,7 +296,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
   | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr)	-- A strict let
   =  	-- Don't use simplBinder because that doesn't keep 
 	-- fragile occurrence in the substitution
-    simplLetId env bndr				`thenSmpl` \ (env, bndr') ->
+    simplLetBndr env bndr				`thenSmpl` \ (env, bndr') ->
     simplStrictArg env AnRhs rhs rhs_se cont_ty	$ \ env rhs1 ->
 
 	-- Now complete the binding and simplify the body
@@ -305,7 +305,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
   | otherwise							-- Normal, lazy case
   =  	-- Don't use simplBinder because that doesn't keep 
 	-- fragile occurrence in the substitution
-    simplLetId env bndr					`thenSmpl` \ (env, bndr') ->
+    simplLetBndr env bndr				`thenSmpl` \ (env, bndr') ->
     simplLazyBind env NotTopLevel NonRecursive
 		  bndr bndr' rhs rhs_se 		`thenSmpl` \ (floats, env) ->
     addFloats env floats thing_inside
@@ -565,7 +565,10 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
 		   | otherwise    = new_bndr_info `setUnfoldingInfo` unfolding
 	unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
 
-	final_id = new_bndr `setIdInfo` info_w_unf
+		-- Don't fiddle with the IdInfo of a constructor
+		-- wrapper or other GlobalId.
+	final_id | isLocalId new_bndr = new_bndr `setIdInfo` info_w_unf
+		 | otherwise	      = new_bndr
     in
 		-- These seqs forces the Id, and hence its IdInfo,
 		-- and hence any inner substitutions
@@ -669,7 +672,7 @@ simplExprF env (Case scrut bndr alts) cont
     case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
 
 simplExprF env (Let (Rec pairs) body) cont
-  = simplRecIds env (map fst pairs) 		`thenSmpl` \ (env, bndrs') -> 
+  = simplRecBndrs env (map fst pairs) 		`thenSmpl` \ (env, bndrs') -> 
 	-- NB: bndrs' don't have unfoldings or spec-envs
 	-- We add them as we go down, using simplPrags
 
@@ -721,7 +724,7 @@ simplLam env fun cont
 
 	-- Not enough args, so there are real lambdas left to put in the result
     go env lam@(Lam _ _) cont
-      = simplLamBinders env bndrs	`thenSmpl` \ (env, bndrs') ->
+      = simplLamBndrs env bndrs		`thenSmpl` \ (env, bndrs') ->
 	simplExpr env body 		`thenSmpl` \ body' ->
 	mkLam env bndrs' body' cont	`thenSmpl` \ (floats, new_lam) ->
 	addFloats env floats		$ \ env ->