X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=8b5c0a95bd99b040d0f93da1963d6275e36e0d40;hb=8b3bfb2ec41fd0e807a8f6e7a823795eafca1dcb;hp=4c05f5ea5c641d551c22d17b1a42965c4b72983b;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 4c05f5e..8b5c0a9 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -53,7 +53,6 @@ import CoreUtils import MkCore import MkId import Id -import Var import Name import Literal import TyCon @@ -75,7 +74,6 @@ import StaticFlags \end{code} - %************************************************************************ %* * Rebindable syntax @@ -144,12 +142,49 @@ selectMatchVar :: Pat Id -> DsM Id selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return var +selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders] selectMatchVar (AsPat var _) = return (unLoc var) selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one... \end{code} +Note [Localise pattern binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider module M where + [Just a] = e +After renaming it looks like + module M where + [Just M.a] = e + +We don't generalise, since it's a pattern binding, monomorphic, etc, +so after desugaring we may get something like + M.a = case e of (v:_) -> + case v of Just M.a -> M.a +Notice the "M.a" in the pattern; after all, it was in the original +pattern. However, after optimisation those pattern binders can become +let-binders, and then end up floated to top level. They have a +different *unique* by then (the simplifier is good about maintaining +proper scoping), but it's BAD to have two top-level bindings with the +External Name M.a, because that turns into two linker symbols for M.a. +It's quite rare for this to actually *happen* -- the only case I know +of is tc003 compiled with the 'hpc' way -- but that only makes it +all the more annoying. + +To avoid this, we craftily call 'localiseId' in the desugarer, which +simply turns the External Name for the Id into an Internal one, but +doesn't change the unique. So the desugarer produces this: + M.a{r8} = case e of (v:_) -> + case v of Just a{r8} -> M.a{r8} +The unique is still 'r8', but the binding site in the pattern +is now an Internal Name. Now the simplifier's usual mechanisms +will propagate that Name to all the occurrence sites, as well as +un-shadowing it, so we'll get + M.a{r8} = case e of (v:_) -> + case v of Just a{s77} -> a{s77} +In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr +runs on the output of the desugarer, so all is well by the end of +the desugaring pass. + %************************************************************************ %* * @@ -219,10 +254,9 @@ wrapBinds [] e = e wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- Can deal with term variables *or* type variables - | new==old = body - | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body - | otherwise = Let (NonRec new (Var old)) body +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = Case (Var var) var (exprType body) @@ -262,10 +296,11 @@ mkCoPrimCaseMatchResult var ty match_alts return (LitAlt lit, [], body) -mkCoAlgCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of exp - -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives - -> MatchResult +mkCoAlgCaseMatchResult + :: Id -- Scrutinee + -> Type -- Type of exp + -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult mkCoAlgCaseMatchResult var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) @@ -346,7 +381,7 @@ mkCoAlgCaseMatchResult var ty match_alts isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" -- mk_parrCase fail = do - lengthP <- dsLookupGlobalId lengthPName + lengthP <- dsLookupDPHId lengthPName alt <- unboxAlt return (mkWildCase (len lengthP) intTy ty [alt]) where @@ -358,7 +393,7 @@ mkCoAlgCaseMatchResult var ty match_alts -- unboxAlt = do l <- newSysLocalDs intPrimTy - indexP <- dsLookupGlobalId indexPName + indexP <- dsLookupDPHId indexPName alts <- mapM (mkAlt indexP) sorted_alts return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) where @@ -551,12 +586,13 @@ mkSelectorBinds pat val_expr tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr tuple_var <- newSysLocalDs tuple_ty let mk_tup_bind binder - = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) + = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var)) return ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where - binders = collectPatBinders pat - local_tuple = mkBigCoreVarTup binders - tuple_ty = exprType local_tuple + binders = collectPatBinders pat + local_binders = map localiseId binders -- See Note [Localise pattern binders] + local_tuple = mkBigCoreVarTup binders + tuple_ty = exprType local_tuple mk_bind scrut_var err_var bndr_var = do -- (mk_bind sv err_var) generates @@ -567,7 +603,7 @@ mkSelectorBinds pat val_expr return (bndr_var, rhs_expr) where error_expr = mkCoerce co (Var err_var) - co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var) + co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var) is_simple_lpat p = is_simple_pat (unLoc p)