[commit: ghc] master: Fix Trac #7681. (7b098b6)
Richard Eisenberg
eir at cis.upenn.edu
Tue Feb 12 16:08:16 CET 2013
I was working in a ghc tree that I thought was clean (i.e. was a checkout of HEAD), but evidently was not.
In my other work, I needed to update lookupType_mod, but wasn't sure how to. So, I looked for use sites. When I found none, I must have gone into this ghc tree, removed the exports, and checked to make sure everything compiled. There were no problems, and I guess I forgot to undo my test change. When fixing #7681, the exports were still missing, causing the warning and validate failure.
I'm happy to bring lookupType_mod back if it is expected to be needed somewhere.
Richard
On Feb 12, 2013, at 3:08 AM, Simon Peyton-Jones <simonpj at microsoft.com> wrote:
> 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