[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