X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=d7a88c00cf87b27171e47b4a983c6dc4e758a706;hb=5723262f616ac02ddf637f6ff480a599c737ea0d;hp=00e8652a842613d232b8e94030f0169563efcb14;hpb=6f37cf1b943abbf8a9f51bf80514cae86a2e6765;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 00e8652..d7a88c0 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -230,11 +230,11 @@ dsEvBinds bs = return (map dsEvGroup sccs) mk_node b@(EvBind var term) = (b, var, free_vars_of term) free_vars_of :: EvTerm -> [EvVar] - free_vars_of (EvId v) = [v] - free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) - free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) - free_vars_of (EvDFunApp _ _ vs) = vs - free_vars_of (EvSuperClass d _) = [d] + free_vars_of (EvId v) = [v] + free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) + free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) + free_vars_of (EvDFunApp _ _ vs _) = vs + free_vars_of (EvSuperClass d _) = [d] dsEvGroup :: SCC EvBind -> DsEvBind dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n))) @@ -261,10 +261,10 @@ dsEvGroup (CyclicSCC bs) ds_pair (EvBind v r) = (v, dsEvTerm r) dsEvTerm :: EvTerm -> CoreExpr -dsEvTerm (EvId v) = Var v -dsEvTerm (EvCast v co) = Cast (Var v) co -dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Type co +dsEvTerm (EvId v) = Var v +dsEvTerm (EvCast v co) = Cast (Var v) co +dsEvTerm (EvDFunApp df tys vars _deps) = Var df `mkTyApps` tys `mkVarApps` vars +dsEvTerm (EvCoercion co) = Type co dsEvTerm (EvSuperClass d n) = ASSERT( isClassPred (classSCTheta cls !! n) ) -- We can only select *dictionary* superclasses @@ -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. + %************************************************************************ %* *