From: simonpj Date: Thu, 4 Oct 2001 08:35:26 +0000 (+0000) Subject: [project @ 2001-10-04 08:35:24 by simonpj] X-Git-Tag: Approximately_9120_patches~860 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=25eca40de184841d6ccd9bc31bf8b998528347fd;hp=a1b59a18845ddaa5e752c9fbc0ad8b947642b50d;p=ghc-hetmet.git [project @ 2001-10-04 08:35:24 by simonpj] Heal the HEAD --- diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index 2c83d95..076f342 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/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 diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 0dccf94..82b15af 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/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 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 3d171cb..91bd856 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/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 diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 21ebaa6..fb70278 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/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 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index e966509..2edb45b 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/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 ->