From 7f05f1095e9a2c7b2b378859da00fde7ca907080 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 30 Dec 2004 22:15:19 +0000 Subject: [PATCH] [project @ 2004-12-30 22:14:59 by simonpj] Fix to the pre-Xmas simplifier changes, which should make everything work again. I'd forgotten to attend to this corner. Still not properly tested I fear. Also remove dead code from SimplEnv, and simplify the remainder (hooray). --- ghc/compiler/basicTypes/VarEnv.lhs | 8 ++- ghc/compiler/coreSyn/CoreLint.lhs | 12 ++-- ghc/compiler/main/TidyPgm.lhs | 1 - ghc/compiler/simplCore/SimplEnv.lhs | 135 +++++++++++++---------------------- ghc/compiler/simplCore/Simplify.lhs | 5 +- ghc/compiler/types/Type.lhs | 16 ++++- ghc/compiler/types/Unify.lhs | 20 +++--- 7 files changed, 91 insertions(+), 106 deletions(-) diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index f29b940..d3b9bcb 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -7,7 +7,7 @@ module VarEnv ( VarEnv, IdEnv, TyVarEnv, emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, varEnvElts, + elemVarEnv, varEnvElts, varEnvKeys, extendVarEnv, extendVarEnv_C, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, @@ -22,6 +22,7 @@ module VarEnv ( InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, modifyInScopeSet, getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, + mapInScopeSet, -- RnEnv2 and its operations RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, @@ -86,6 +87,9 @@ modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_sco delInScopeSet :: InScopeSet -> Var -> InScopeSet delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n +mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet +mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n + elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope @@ -286,6 +290,7 @@ plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a varEnvElts :: VarEnv a -> [a] +varEnvKeys :: VarEnv a -> [Unique] isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a @@ -310,6 +315,7 @@ mapVarEnv = mapUFM mkVarEnv = listToUFM emptyVarEnv = emptyUFM varEnvElts = eltsUFM +varEnvKeys = keysUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index a3ea531..ee5efb7 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -34,7 +34,8 @@ import Type ( Type, tyVarsOfType, coreEqType, isUnboxedTupleType, isSubKind, substTyWith, emptyTvSubst, extendTvInScope, TvSubst, TvSubstEnv, setTvSubstEnv, substTy, - extendTvSubst, isInScope ) + extendTvSubst, composeTvSubst, isInScope, + getTvSubstEnv, getTvInScope ) import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), Boxity(..), isNonRec ) import CmdLineOpts @@ -464,9 +465,11 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) pat_res_ty = dataConResTy con (mkTyVarTys tvs) ; subst <- getTvSubst - ; case coreRefineTys tvs subst pat_res_ty scrut_ty of { - Nothing -> return () ; -- Alternative is dead code - Just senv -> updateTvSubstEnv senv $ + ; let in_scope = getTvInScope subst + subst_env = getTvSubstEnv subst + ; case coreRefineTys in_scope tvs pat_res_ty scrut_ty of { + Nothing -> return () ; -- Alternative is dead code + Just refine -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $ do { tvs' <- mapM lintTy (mkTyVarTys tvs) ; con_type <- lintTyApps (dataConRepType con) tvs' ; mapM lintBinder ids -- Lint Ids in the refined world @@ -579,7 +582,6 @@ addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) --- gaw 2004 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a updateTvSubstEnv substenv m = LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs) diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index a4fb275..ee4b5bb 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -40,7 +40,6 @@ import HscTypes ( HscEnv(..), NameCache( nsUniqs ), ) import Maybes ( orElse ) import ErrUtils ( showPass, dumpIfSet_core ) -import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Maybe ( isJust ) diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index e7792e8..8a3841f 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -21,7 +21,7 @@ module SimplEnv ( SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getRules, + getRules, refineSimplEnv, SimplSR(..), mkContEx, substId, @@ -39,55 +39,31 @@ module SimplEnv ( #include "HsVersions.h" import SimplMonad -import Rules ( RuleBase, emptyRuleBase ) -import Id ( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding ) +import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, arityInfo, setArityInfo, workerInfo, setWorkerInfo, unfoldingInfo, setUnfoldingInfo, unknownArity, workerExists ) import CoreSyn -import CoreUtils ( needsCaseBinding, exprIsTrivial ) +import Rules ( RuleBase ) +import CoreUtils ( needsCaseBinding ) import PprCore () -- Instances import CostCentre ( CostCentreStack, subsumedCCS ) import Var import VarEnv -import VarSet ( isEmptyVarSet ) +import VarSet ( isEmptyVarSet, elemVarSetByKey, mkVarSet ) import OrdList import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker ) import qualified Type ( substTy, substTyVarBndr ) -import Type ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType ) -import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, - UniqSupply - ) -import FiniteMap -import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker, - Activation, isActive, isAlwaysActive, - OccInfo(..), isOneOcc, isFragileOcc - ) -import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), - DynFlags, DynFlag(..), dopt, - opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff - ) -import Unique ( Unique ) +import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, + isUnLiftedType, seqType, tyVarsOfType ) +import BasicTypes ( OccInfo(..), isFragileOcc ) +import CmdLineOpts ( SimplifierMode(..) ) import Util ( mapAccumL ) import Outputable -import FastTypes -import FastString -import Maybes ( expectJust ) - -import GLAEXTS ( indexArray# ) - -#if __GLASGOW_HASKELL__ < 503 -import PrelArr ( Array(..) ) -#else -import GHC.Arr ( Array(..) ) -#endif - -import Array ( array, (//) ) - \end{code} %************************************************************************ @@ -328,6 +304,34 @@ getRules :: SimplEnv -> RuleBase getRules = seExtRules \end{code} + GADT stuff + +Given an idempotent substitution, generated by the unifier, use it to +refine the environment + +\begin{code} +refineSimplEnv :: SimplEnv -> TvSubstEnv -> [OutTyVar] -> SimplEnv +-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes +refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope }) + refine_tv_subst tvs + = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst, + seInScope = in_scope' } + where + in_scope' + | all bound_here (varEnvKeys refine_tv_subst) = in_scope + -- The tvs are the tyvars bound here. If only they + -- are refined, there's no need to do anything + | otherwise = mapInScopeSet refine_id in_scope + + bound_here uniq = elemVarSetByKey uniq tv_set + tv_set = mkVarSet tvs + + refine_id v -- Only refine its type; any rules will get + -- refined if they are used (I hope) + | isId v = setIdType v (Type.substTy refine_subst (idType v)) + | otherwise = v + refine_subst = TvSubst in_scope refine_tv_subst +\end{code} %************************************************************************ %* * @@ -361,7 +365,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v refine v = case lookupInScope in_scope v of Just v' -> v' Nothing -> WARN( True, ppr v ) v -- This is an error! - \end{code} @@ -391,7 +394,7 @@ simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder) simplBinder env bndr | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr ; seqTyVar tv `seq` return (env', tv) } - | otherwise = do { let (env', id) = substIdBndr False env env bndr + | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } ------------- @@ -412,7 +415,7 @@ simplLamBndr env bndr | otherwise = seqId id2 `seq` return (env', id2) where old_unf = idUnfolding bndr - (env', id1) = substIdBndr False env env bndr + (env', id1) = substIdBndr env bndr id2 = id1 `setIdUnfolding` substUnfolding env old_unf ------------- @@ -426,48 +429,21 @@ seqId id = seqType (idType id) `seq` \end{code} \begin{code} --- substBndr and friends are used when doing expression substitution only --- In this case we can *preserve* occurrence information, and indeed we *want* --- to do so else lose useful occ info in rules. - -substBndr :: SimplEnv -> Var -> (SimplEnv, Var) -substBndr subst bndr - | isTyVar bndr = substTyVarBndr subst bndr - | otherwise = substIdBndr True {- keep fragile info -} subst subst bndr - -substBndrs :: SimplEnv -> [Var] -> (SimplEnv, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs - -substRecBndrs :: SimplEnv -> [Id] -> (SimplEnv, [Id]) --- Substitute a mutually recursive group -substRecBndrs subst bndrs - = (new_subst, new_bndrs) - where - -- Here's the reason we need to pass rec_subst to substIdBndr - (new_subst, new_bndrs) = mapAccumL (substIdBndr True {- keep fragile info -} new_subst) - subst bndrs -\end{code} - - -\begin{code} -substIdBndr :: Bool -- True <=> keep fragile info - -> SimplEnv -- Substitution to use for the IdInfo - -> SimplEnv -> Id -- Substitition and Id to transform - -> (SimplEnv, Id) -- Transformed pair +substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform + -> (SimplEnv, Id) -- Transformed pair -- Returns with: -- * Unique changed if necessary -- * Type substituted -- * Unfolding zapped -- * Rules, worker, lbvar info all substituted --- * Occurrence info zapped if is_fragile_occ returns True +-- * Fragile occurrence info zapped -- * The in-scope set extended with the returned Id -- * The substitution extended with a DoneId if unique changed -- In this case, the var in the DoneId is the same as the -- var returned -substIdBndr keep_fragile rec_env - env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) +substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst}) old_id = (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) @@ -481,7 +457,7 @@ substIdBndr keep_fragile rec_env -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with -- rec_env, when dealing with a mutually-recursive group - new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_env) id2 + new_id = maybeModifyIdInfo (substIdInfo env) id2 -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delSubstEnv @@ -570,33 +546,24 @@ simplIdInfo :: SimplEnv -> IdInfo -> IdInfo -- Used by the simplifier to compute new IdInfo for a let(rec) binder, -- subsequent to simplLetId having zapped its IdInfo simplIdInfo env old_info - = case substIdInfo False env old_info of + = case substIdInfo env old_info of Just new_info -> new_info Nothing -> old_info -substIdInfo :: Bool -- True <=> keep even fragile info - -> SimplEnv +substIdInfo :: SimplEnv -> IdInfo -> Maybe IdInfo --- The keep_fragile flag is True when we are running a simple expression --- substitution that preserves all structure, so that arity and occurrence --- info are unaffected. The False state is used more often. --- -- Substitute the -- rules -- worker info -- Zap the unfolding --- If keep_fragile then --- keep OccInfo --- keep Arity --- else --- keep only 'robust' OccInfo --- zap Arity +-- Keep only 'robust' OccInfo +-- Zap Arity -- -- Seq'ing on the returned IdInfo is enough to cause all the -- substitutions to happen completely -substIdInfo keep_fragile env info +substIdInfo env info | nothing_to_do = Nothing | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) `setArityInfo` (if keep_arity then old_arity else unknownArity) @@ -612,8 +579,8 @@ substIdInfo keep_fragile env info not (workerExists old_wrkr) && not (hasUnfolding (unfoldingInfo info)) - keep_occ = keep_fragile || not (isFragileOcc old_occ) - keep_arity = keep_fragile || old_arity == unknownArity + keep_occ = not (isFragileOcc old_occ) + keep_arity = old_arity == unknownArity old_arity = arityInfo info old_occ = occInfo info old_rules = specInfo info diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 7ffdc38..6d132d0 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1500,8 +1500,9 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' simplBinders env tvs `thenSmpl` \ (env1, tvs') -> let pat_res_ty = dataConResTy con (mkTyVarTys tvs') + in_scope = getInScope env1 in - case coreRefineTys tvs' (error "urk") pat_res_ty (idType case_bndr') of { + case coreRefineTys in_scope tvs' pat_res_ty (idType case_bndr') of { Nothing -- Dead code; for now, I'm just going to put in an -- error case so I can see them -> let rhs' = mkApps (Var eRROR_ID) @@ -1514,7 +1515,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' Just tv_subst_env -> -- The normal case let - env2 = error "setTvSubstEnv" env1 tv_subst_env + env2 = refineSimplEnv env1 tv_subst_env tvs' -- Simplify the Ids in the refined environment, so their types -- reflect the refinement. Usually this doesn't matter, but it helps -- in mkDupableAlt, when we want to float a lambda that uses these binders diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index f2f06c8..d4bc995 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -67,11 +67,11 @@ module Type ( TvSubstEnv, emptyTvSubst, mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, + extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, -- Performing substitution on types substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr, - deShadowTy, + deShadowTy, -- Pretty-printing pprType, pprParendType, pprTyThingCategory, @@ -1026,6 +1026,18 @@ type TvSubstEnv = TyVarEnv Type -- So you have to look at the context to know if it's idempotent or -- apply-once or whatever +composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv +-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1 +-- It assumes that both are idempotent +composeTvSubst in_scope env1 env2 + = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, becuause the right arg wins + where + subst1 = TvSubst in_scope env1 + emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index a8b893c..a2316f8 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -198,25 +198,23 @@ gadtMatchTys ex_tvs subst tys1 tys2 = initUM (bindOnly (mkVarSet ex_tvs)) (unify_tys subst tys1 tys2) ---------------------------- -coreRefineTys :: [TyVar] -- Try to unify these - -> TvSubst -- A full-blown apply-once substitition +coreRefineTys :: InScopeSet -- Superset of free vars of either type + -> [TyVar] -- Try to unify these -> Type -- Both types should be a fixed point -> Type -- of the incoming substitution -> Maybe TvSubstEnv -- In-scope set is unaffected -- Used by Core Lint and the simplifier. Takes a full apply-once substitution. -- The incoming substitution's in-scope set should mention all the variables free -- in the incoming types -coreRefineTys ex_tvs subst@(TvSubst in_scope orig_env) ty1 ty2 +coreRefineTys in_scope ex_tvs ty1 ty2 = maybeErrToMaybe $ initUM (tryToBind (mkVarSet ex_tvs)) $ do { -- Run the unifier, starting with an empty env - ; extra_env <- unify emptyTvSubstEnv ty1 ty2 - - -- Find the fixed point of the resulting non-idempotent - -- substitution, and apply it to the incoming substitution - ; let extra_subst = TvSubst in_scope extra_env_fixpt - extra_env_fixpt = mapVarEnv (substTy extra_subst) extra_env - orig_env' = mapVarEnv (substTy extra_subst) orig_env - ; return (orig_env' `plusVarEnv` extra_env_fixpt) } + ; subst_env <- unify emptyTvSubstEnv ty1 ty2 + + -- Find the fixed point of the resulting non-idempotent substitution + ; let subst = TvSubst in_scope subst_env_fixpt + subst_env_fixpt = mapVarEnv (substTy subst) subst_env + ; return subst_env_fixpt } ---------------------------- tcUnifyTys :: TyVarSet -> [Type] -> [Type] -> Maybe TvSubstEnv -- 1.7.10.4