Commit 7f05f109 authored by simonpj's avatar simonpj
Browse files

[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).
parent 29ca2190
......@@ -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
......
......@@ -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)
......
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment