[commit: ghc] master: Fix Trac #7681. (7b098b6)

Simon Peyton-Jones simonpj at microsoft.com
Tue Feb 12 16:18:56 CET 2013


I doubt it matters.   I was just curious.  But it might do no harm to have it there, commented out, because it's an example of how do to the "modify" operation on TrieMaps

S

| -----Original Message-----
| From: Richard Eisenberg [mailto:eir at cis.upenn.edu]
| Sent: 12 February 2013 15:08
| To: Simon Peyton-Jones
| Cc: ghc-devs at haskell.org
| Subject: Re: [commit: ghc] master: Fix Trac #7681. (7b098b6)
| 
| 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/7b098b6009727a012cb1f3
| > | ff0c
| > | 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