import DsMonad
import DsGRHSs
import DsUtils
+import OccurAnal
import HsSyn -- lots of things
import CoreSyn -- lots of things
import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import TcType
-import OccurAnal
import CostCentre
import Module
import Id
-import Name ( localiseName )
-import Var ( TyVar )
+import Var ( Var, TyVar )
import VarSet
import Rules
import VarEnv
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; ds_spec_expr <- dsExpr spec_expr
- ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
- -- ds_spec_expr may look like
- -- /\a. f a Int dOrdInt
- -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
- -- The occurrence-analysis does two things
- -- (a) identifies unused binders: Note [Unused spec binders]
- -- (b) sorts dict bindings into NonRecs
- -- so they can be inlined by decomposeRuleLhs
- mb_lhs = decomposeRuleLhs body
-
- -- Check for dead binders: Note [Unused spec binders]
- ; case filter isDeadBinder bndrs of {
- bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
- | otherwise ->
+ ; case (decomposeRuleLhs ds_spec_expr) of {
+ Nothing -> do { warnDs decomp_msg; return Nothing } ;
- case mb_lhs of
- Nothing -> do { warnDs decomp_msg; return Nothing }
+ Just (bndrs, _fn, args) ->
- Just (_, args) -> do {
+ -- Check for dead binders: Note [Unused spec binders]
+ case filter isDeadBinder bndrs of {
+ bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
+ | otherwise -> do
- f_body <- fix_up (Let mono_bind (Var mono_id))
+ { f_body <- fix_up (Let mono_bind (Var mono_id))
; let local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
poly_f_body = mkLams (tvs ++ dicts) f_body
- extra_dict_bndrs = [localise d
+ extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts]
| d <- varSetElems (exprFreeVars ds_spec_expr)
, isDictId d]
-- Note [Const rule dicts]
(extra_dict_bndrs ++ bndrs) args
(mkVarApps (Var spec_id) bndrs)
; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
- } } }
+ } } } }
where
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr)
-
- localise d = mkLocalId (localiseName (idName d)) (idType d)
- -- See Note [Constant rule dicts]
+
mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
-- If any of the tyvars is missing from any of the lists in
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. Hence the use of 'localise' to make it Internal.
+confused. Hence the use of 'localiseId' to make it Internal.
%************************************************************************
%************************************************************************
\begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe ([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
- = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
- -- bindings so we know if they are recursive
+ = case (decomp emptyVarEnv body) of
+ Nothing -> Nothing
+ Just (fn, args) -> Just (bndrs, fn, args)
where
+ occ_lhs = occurAnalyseExpr lhs
+ -- The occurrence-analysis does two things
+ -- (a) identifies unused binders: Note [Unused spec binders]
+ -- (b) sorts dict bindings into NonRecs
+ -- so they can be inlined by 'decomp'
+ (bndrs, body) = collectBinders occ_lhs
+
-- Substitute dicts in the LHS args, so that there
-- aren't any lets getting in the way
-- Note that we substitute the function too; we might have this as
-- a LHS: let f71 = M.f Int in f71
- go env (Let (NonRec dict rhs) body)
- = go (extendVarEnv env dict (simpleSubst env rhs)) body
- go env body
+ decomp env (Let (NonRec dict rhs) body)
+ = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
+ decomp env body
= case collectArgs (simpleSubst env body) of
(Var fn, args) -> Just (fn, args)
_ -> Nothing
; return (Lam id expr) }
dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
; return (Lam tv expr) }
-dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside
- ; return (App expr (Var id)) }
+dsCoercion (WpApp v) thing_inside
+ | isTyVar v = do { expr <- thing_inside
+ {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
+ | otherwise = do { expr <- thing_inside
+ {- An Id -} ; return (App expr (Var v)) }
dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
; return (App expr (Type ty)) }
dsCoercion WpInline thing_inside = do { expr <- thing_inside