From 2454d08942e0422ae90445fa2edbef8927a512d7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 21 Oct 2010 08:54:02 +0000 Subject: [PATCH] Improve rule checking, to fix panic Trac #4398 Lots of comments with decomposeRuleLhs --- compiler/deSugar/Desugar.lhs | 13 ++-- compiler/deSugar/DsBinds.lhs | 157 ++++++++++++++++++++++-------------------- 2 files changed, 86 insertions(+), 84 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index d154e04..e5d763c 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -34,7 +34,6 @@ import CoreMonad ( endPass, CoreToDo(..) ) import ErrUtils import Outputable import SrcLoc -import FastString import Coverage import Util import MonadUtils @@ -345,9 +344,9 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form - ; case decomposeRuleLhs lhs' of { - Nothing -> do { warnDs msg; return Nothing } ; - Just (fn_id, args) -> do + ; case decomposeRuleLhs bndrs' lhs' of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do { let is_local = isLocalId fn_id -- NB: isLocalId is False of implicit Ids. This is good becuase @@ -356,14 +355,10 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) fn_name = idName fn_id final_rhs = simpleOptExpr rhs' -- De-crap it rule = mkRule False {- Not auto -} is_local - name act fn_name bndrs' args final_rhs + name act fn_name final_bndrs args final_rhs ; return (Just rule) } } } - where - msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored")) - 2 (ppr lhs) \end{code} - Note [Desugaring RULE left hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the LHS of a RULE we do *not* want to desugar diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 00e8652..48fad92 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -499,18 +499,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; wrap_fn <- dsHsWrapper spec_co ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id)) spec_ty = mkPiTypes bndrs (exprType ds_lhs) - ; case decomposeRuleLhs ds_lhs of { - Nothing -> do { warnDs (decomp_msg spec_co) - ; return Nothing } ; - - Just (_fn, args) -> - - -- Check for dead binders: Note [Unused spec binders] - let arg_fvs = exprsFreeVars args - bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs - in if not (null bad_bndrs) - then do { warnDs (dead_msg bad_bndrs); return Nothing } - else do + ; case decomposeRuleLhs bndrs ds_lhs of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (final_bndrs, _fn, args) -> do { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id) @@ -518,19 +509,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) `setInlinePragma` inl_prag `setIdUnfolding` spec_unf inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id - | otherwise = spec_inl + | otherwise = spec_inl -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id - extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) - -- See Note [Constant rule dicts] - | d <- varSetElems (arg_fvs `delVarSetList` bndrs) - , isDictId d] - rule = mkRule False {- Not auto -} is_local_id (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) AlwaysActive poly_name - (extra_dict_bndrs ++ bndrs) args + final_bndrs args (mkVarApps (Var spec_id) bndrs) spec_rhs = wrap_fn poly_rhs @@ -539,16 +525,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; return (Just (spec_pair `consOL` unf_pairs, rule)) } } } where - dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs - <+> ptext (sLit "in specialied type:"), - nest 2 (pprTheta (map get_pred bs))] - , ptext (sLit "SPECIALISE pragma ignored")] - get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b)) - - decomp_msg spec_co - = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) - 2 (pprHsWrapper (ppr poly_id) spec_co) - is_local_id = isJust mb_poly_rhs poly_rhs | Just rhs <- mb_poly_rhs = rhs @@ -590,46 +566,6 @@ dsMkArbitraryType :: TcTyVar -> Type dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv) \end{code} -Note [Unused spec binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: a -> a - {-# SPECIALISE f :: Eq a => a -> a #-} -It's true that this *is* a more specialised type, but the rule -we get is something like this: - f_spec d = f - RULE: f = f_spec d -Note that the rule is bogus, becuase it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, becuase -the constraint is unused. We could bind 'd' to (error "unused") -but it seems better to reject the program because it's almost certainly -a mistake. That's what the isDeadBinder call detects. - -Note [Constant rule dicts] -~~~~~~~~~~~~~~~~~~~~~~~ -When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too. *Any* dict with that type will do. - -So for example when you have - f :: Eq a => a -> a - f = - {-# SPECIALISE f :: Int -> Int #-} - -Then we get the SpecPrag - SpecPrag (f Int dInt) - -And from that we want the rule - - RULE forall dInt. f Int dInt = f_spec - f_spec = let f = in f Int dInt - -But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External -Name, and you can't bind them in a lambda or forall without getting things -confused. Likewise it might have an InlineRule or something, which would be -utterly bogus. So we really make a fresh Id, with the same unique and type -as the old one, but with an Internal name and no IdInfo. - %************************************************************************ %* * \subsection{Adding inline pragmas} @@ -637,24 +573,55 @@ as the old one, but with an Internal name and no IdInfo. %************************************************************************ \begin{code} -decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr]) +decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) -- Take apart the LHS of a RULE. It's suuposed to look like -- /\a. f a Int dOrdInt -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl -- That is, the RULE binders are lambda-bound -- Returns Nothing if the LHS isn't of the expected shape -decomposeRuleLhs lhs +decomposeRuleLhs bndrs lhs = -- Note [Simplifying the left-hand side of a RULE] - case collectArgs (simpleOptExpr lhs) of - (Var fn, args) -> Just (fn, args) + case collectArgs opt_lhs of + (Var fn, args) -> check_bndrs fn args (Case scrut bndr ty [(DEFAULT, _, body)], args) | isDeadBinder bndr -- Note [Matching seqId] - -> Just (seqId, args' ++ args) + -> check_bndrs seqId (args' ++ args) where args' = [Type (idType bndr), Type ty, scrut, body] - _other -> Nothing -- Unexpected shape + _other -> Left bad_shape_msg + where + opt_lhs = simpleOptExpr lhs + + check_bndrs fn args + | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args) + | otherwise = Left (vcat (map dead_msg dead_bndrs)) + where + arg_fvs = exprsFreeVars args + + -- Check for dead binders: Note [Unused spec binders] + dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs + + -- Add extra dict binders: Note [Constant rule dicts] + extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) + | d <- varSetElems (arg_fvs `delVarSetList` bndrs) + , isDictId d] + + + bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) + 2 (ppr opt_lhs) + dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr + <+> ptext (sLit "is not bound in RULE lhs")) + 2 (ppr opt_lhs) + pp_bndr bndr + | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr + | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr + | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr) + | otherwise = ptext (sLit "variable") <+> ppr bndr + + get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" + (tcSplitPredTy_maybe (idType b)) \end{code} Note [Simplifying the left-hand side of a RULE] @@ -688,6 +655,46 @@ The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack and this code turns it back into an application of seq! See Note [Rules for seq] in MkId for the details. +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + {-# SPECIALISE f :: Eq a => a -> a #-} +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, becuase it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, becuase +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [Constant rule dicts] +~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + {-# SPECIALISE f :: Int -> Int #-} + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have an InlineRule or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + %************************************************************************ %* * -- 1.7.10.4