[commit: ghc] master: Fix Trac #7681. (7b098b6)
Simon Peyton-Jones
simonpj at microsoft.com
Tue Feb 12 09:08:57 CET 2013
Thanks for fixing.
You removed lookupType_mod from TrieMap. It was defined and exported but not called. How did validate spot that? I'm sure there are quite a few such functions in GHC.
Simon
| -----Original Message-----
| From: ghc-commits-bounces at haskell.org [mailto:ghc-commits-
| bounces at haskell.org] On Behalf Of Richard Eisenberg
| Sent: 12 February 2013 04:10
| To: ghc-commits at haskell.org
| Subject: [commit: ghc] master: Fix Trac #7681. (7b098b6)
|
| Repository : ssh://darcs.haskell.org//srv/darcs/ghc
|
| On branch : master
|
| http://hackage.haskell.org/trac/ghc/changeset/7b098b6009727a012cb1f3ff0c
| a51698d302cae1
|
| >---------------------------------------------------------------
|
| commit 7b098b6009727a012cb1f3ff0ca51698d302cae1
| Author: Richard Eisenberg <eir at cis.upenn.edu>
| Date: Mon Feb 11 23:07:25 2013 -0500
|
| Fix Trac #7681.
|
| Removed checks for empty lists for case expressions and lambda-case.
| If -XEmptyCase is not enabled, compilation still fails
| (appropriately)
| in the renamer.
|
| Had to remove dead code from TrieMap to pass the validator.
|
| >---------------------------------------------------------------
|
| compiler/coreSyn/TrieMap.lhs | 38 +----------------------------------
| ---
| compiler/deSugar/DsMeta.hs | 6 ++++--
| compiler/hsSyn/Convert.lhs | 8 ++------
| libraries/random | 2 +-
| 4 files changed, 8 insertions(+), 46 deletions(-)
|
| diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
| index 148464b..c013b5d 100644
| --- a/compiler/coreSyn/TrieMap.lhs
| +++ b/compiler/coreSyn/TrieMap.lhs
| @@ -14,7 +14,7 @@
| {-# LANGUAGE TypeFamilies #-}
| module TrieMap(
| CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
| - TypeMap, foldTypeMap, lookupTypeMap_mod,
| + TypeMap, foldTypeMap, -- lookupTypeMap_mod,
| CoercionMap,
| MaybeMap,
| ListMap,
| @@ -32,8 +32,6 @@ import UniqFM
| import Unique( Unique )
| import FastString(FastString)
|
| -import Unify ( niFixTvSubst )
| -
| import qualified Data.Map as Map
| import qualified Data.IntMap as IntMap
| import VarEnv
| @@ -632,40 +630,6 @@ lkT env ty m
| go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=>
| lkBndr env tv
|
|
| -lkT_mod :: CmEnv
| - -> TyVarEnv Type -- TvSubstEnv
| - -> Type
| - -> TypeMap b -> Maybe b
| -lkT_mod env s ty m
| - | EmptyTM <- m = Nothing
| - | Just ty' <- coreView ty
| - = lkT_mod env s ty' m
| - | [] <- candidates
| - = go env s ty m
| - | otherwise
| - = Just $ snd (head candidates) -- Yikes!
| - where
| - -- Hopefully intersects is much smaller than traversing the whole
| vm_fvar
| - intersects = eltsUFM $
| - intersectUFM_C (,) s (vm_fvar $ tm_var m)
| - candidates = [ (u,ct) | (u,ct) <- intersects
| - , Type.substTy (niFixTvSubst s) u `eqType` ty
| ]
| -
| - go env _s (TyVarTy v) = tm_var >.> lkVar env v
| - go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s t1 >=>
| lkT_mod env s t2
| - go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s t1 >=>
| lkT_mod env s t2
| - go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList
| (lkT_mod env s) tys
| - go _env _s (LitTy l) = tm_tylit >.> lkTyLit l
| - go _env _s (ForAllTy _tv _ty) = const Nothing
| -
| - {- DV TODO: Add proper lookup for ForAll -}
| -
| -lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the
| /keys/ of type map
| - -> (a -> Type)
| - -> Type
| - -> TypeMap b -> Maybe b
| -lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s)
| -
| -----------------
| xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a xtT env ty f m
| diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
| index 9a9f89d..4f5ba2d 100644
| --- a/compiler/deSugar/DsMeta.hs
| +++ b/compiler/deSugar/DsMeta.hs
| @@ -920,7 +920,8 @@ repE (HsLit l) = do { a <- repLiteral l;
| repLit a }
| repE (HsLam (MG { mg_alts = [m] })) = repLambda m repE (HsLamCase _
| (MG { mg_alts = ms }))
| = do { ms' <- mapM repMatchTup ms
| - ; repLamCase (nonEmptyCoreList ms') }
| + ; core_ms <- coreList matchQTyConName ms'
| + ; repLamCase core_ms }
| repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
|
| repE (OpApp e1 op _ e2) =
| @@ -938,7 +939,8 @@ repE (SectionR x y) = do { a <- repLE x; b <-
| repLE y; repSectionR a b }
| repE (HsCase e (MG { mg_alts = ms }))
| = do { arg <- repLE e
| ; ms2 <- mapM repMatchTup ms
| - ; repCaseE arg (nonEmptyCoreList ms2) }
| + ; core_ms2 <- coreList matchQTyConName
| ms2
| + ; repCaseE arg core_ms2 }
| repE (HsIf _ x y z) = do
| a <- repLE x
| b <- repLE y
| diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
| index a21caf4..ce15071 100644
| --- a/compiler/hsSyn/Convert.lhs
| +++ b/compiler/hsSyn/Convert.lhs
| @@ -524,9 +524,7 @@ cvtl e = wrapL (cvt e)
| cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $
| HsApp x' y' }
| cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
| ; return $ HsLam (mkMatchGroup
| [mkSimpleMatch ps' e']) }
| - cvt (LamCaseE ms)
| - | null ms = failWith (ptext (sLit "Lambda-case expression
| with no alternatives"))
| - | otherwise = do { ms' <- mapM cvtMatch ms
| + cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
| ; return $ HsLamCase placeHolderType
| (mkMatchGroup ms')
| }
| @@ -543,9 +541,7 @@ cvtl e = wrapL (cvt e)
| ; return $ HsMultiIf placeHolderType alts'
| }
| cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let
| expression")) ds
| ; e' <- cvtl e; return $ HsLet ds' e' }
| - cvt (CaseE e ms)
| - | null ms = failWith (ptext (sLit "Case expression with no
| alternatives"))
| - | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
| + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
| ; return $ HsCase e' (mkMatchGroup ms') }
| cvt (DoE ss) = cvtHsDo DoExpr ss
| cvt (CompE ss) = cvtHsDo ListComp ss
| diff --git a/libraries/random b/libraries/random index 0531d37..69bfde2
| 160000
| --- a/libraries/random
| +++ b/libraries/random
| @@ -1 +1 @@
| -Subproject commit 0531d37602d6e7c0b2b5adbf2d5fdd2d01830216
| +Subproject commit 69bfde219bab869729fdbe9c1496371f912bf41e
|
|
|
| _______________________________________________
| ghc-commits mailing list
| ghc-commits at haskell.org
| http://www.haskell.org/mailman/listinfo/ghc-commits
More information about the ghc-devs
mailing list