X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=5540dd806ba2312c8352fce097f7461cb3637ac5;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=8ed971909fdeb1c61c37e9f867faebaccb226bc4;hpb=c128930dc98c73e2459a4610539fee73ca941247;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 8ed9719..5540dd8 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -10,6 +10,13 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsCoercion, AutoScc(..) @@ -29,15 +36,15 @@ import CoreSyn -- lots of things import CoreUtils import TcHsSyn ( mkArbitraryType ) -- Mis-placed? +import TcType import OccurAnal import CostCentre import Module import Id +import Var ( TyVar ) import Rules -import Var ( TyVar, Var ) import VarEnv import Type -import TysWiredIn import Outputable import SrcLoc import Maybes @@ -89,9 +96,11 @@ dsHsBind auto_scc rest (VarBind var expr) addDictScc var core_expr `thenDs` \ core_expr' -> returnDs ((var, core_expr') : rest) -dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }) - = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> - dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs -> +dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, + fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) + = matchWrapper (FunRhs (idName fun) inf) matches `thenDs` \ (args, body) -> + mkOptTickBox tick body `thenDs` \ body' -> + dsCoercion co_fn (return (mkLams args body')) `thenDs` \ rhs -> returnDs ((fun,rhs) : rest) dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) @@ -166,7 +175,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) -- Rec because of mixed-up dictionary bindings core_bind = Rec (map do_one core_prs) - tup_expr = mkTupleExpr locals + tup_expr = mkBigCoreVarTup locals tup_ty = exprType tup_expr poly_tup_expr = mkLams all_tyvars $ mkLams dicts $ Let core_bind tup_expr @@ -180,7 +189,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local = -- Need to make fresh locals to bind in the selector, because -- some of the tyvars will be bound to 'Any' - do { locals' <- newSysLocalsDs (map substitute local_tys) + do { ty_args <- mapM mk_ty_arg all_tyvars + ; let substitute = substTyWith all_tyvars ty_args + ; locals' <- newSysLocalsDs (map substitute local_tys) ; tup_id <- newSysLocalDs (substitute tup_ty) ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags @@ -191,10 +202,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args ; returnDs ((global', rhs) : spec_binds) } where - mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar - | otherwise = mkArbitraryType all_tyvar - ty_args = map mk_ty_arg all_tyvars - substitute = substTyWith all_tyvars ty_args + mk_ty_arg all_tyvar + | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar) + | otherwise = dsMkArbitraryType all_tyvar ; export_binds_s <- mappM mk_bind (exports `zip` [0..]) -- don't scc (auto-)annotate the tuple itself. @@ -202,7 +212,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest)) } -mkABEnv :: [([TyVar], Id, Id, [Prag])] -> VarEnv (Id, [Prag]) +mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv (Id, [LPrag]) -- Takes the exports of a AbsBinds, and returns a mapping -- lcl_id -> (gbl_id, prags) mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags)) @@ -211,7 +221,7 @@ mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags)) dsSpec :: [TyVar] -> [DictId] -> [TyVar] -> Id -> Id -- Global, local - -> CoreBind -> Prag + -> CoreBind -> LPrag -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id CoreRule)) -- Rule for the Global Id @@ -230,54 +240,107 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar] -- /\b.\(d:Ix b). in f Int b dInt d -- The idea is that f occurs just once, so it'll be -- inlined and specialised - -dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {}) +-- +-- Given SpecPrag (/\as.\ds. f es) t, we have +-- the defn f_spec as ds = f es +-- and the RULE f es = f_spec as ds +-- +-- It is *possible* that 'es' does not mention all of the dictionaries 'ds' +-- (a bit silly, because then the +dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (L _ (InlinePrag {})) = return Nothing dsSpec all_tvs dicts tvs poly_id mono_id mono_bind - (SpecPrag spec_expr spec_ty const_dicts inl) - = do { let poly_name = idName poly_id + (L loc (SpecPrag spec_expr spec_ty _const_dicts inl)) + -- See Note [Const rule dicts] + = putSrcSpanDs loc $ + do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name ; ds_spec_expr <- dsExpr spec_expr - ; let (bndrs, body) = collectBinders ds_spec_expr - mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body - - ; case mb_lhs of - Nothing -> do { warnDs msg; return Nothing } - - Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule)) - where - local_poly = setIdNotExported poly_id + ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr) + -- 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 mb_lhs of + Nothing -> do { warnDs decomp_msg; return Nothing } + + Just (var, args) -> do + + { f_body <- fix_up (Let mono_bind (Var mono_id)) + + ; let local_poly = setIdNotExported poly_id -- Very important to make the 'f' non-exported, -- else it won't be inlined! spec_id = mkLocalId spec_name spec_ty spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr - poly_f_body = mkLams (tvs ++ dicts) $ - fix_up (Let mono_bind (Var mono_id)) - - -- Quantify over constant dicts on the LHS, since - -- their value depends only on their type - -- The ones we are interested in may even be imported - -- e.g. GHC.Base.dEqInt - + poly_f_body = mkLams (tvs ++ dicts) f_body + rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) AlwaysActive poly_name - bndrs' -- Includes constant dicts - args + 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 - fix_up body | null void_tvs = body - | otherwise = mkTyApps (mkLams void_tvs body) - (map mkArbitraryType void_tvs) + fix_up body | null void_tvs = return body + | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs + ; return (mkTyApps (mkLams void_tvs body) void_tys) } + void_tvs = all_tvs \\ tvs - msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored")) - 2 (ppr spec_expr) + 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 = hang (ptext SLIT("Specialisation too complicated to desugar; ignored")) + 2 (ppr spec_expr) + +dsMkArbitraryType tv = mkArbitraryType warn tv + where + warn span msg = putSrcSpanDs span (warnDs msg) \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 [Const rule dicts] +~~~~~~~~~~~~~~~~~~~~~~~ +A SpecPrag has a field for "constant dicts" in the RULE, but I think +it's pretty useless. See the place where it's generated in TcBinds. +TcSimplify will discharge a constraint by binding it to, say, +GHC.Base.$f2 :: Eq Int, withour putting anything in the LIE, so this +dict won't show up in the const-dicts field. It probably doesn't matter, +because the rule will end up being something like + f Int GHC.Base.$f2 = ... +rather than + forall d. f Int d = ... +The latter is more general, but in practice I think it won't make any +difference. + %************************************************************************ %* * @@ -286,29 +349,12 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind %************************************************************************ \begin{code} -decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr]) +decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr]) -- Returns Nothing if the LHS isn't of the expected shape --- The argument 'all_bndrs' includes the "constant dicts" of the LHS, --- and they may be GlobalIds, which we can't forall-ify. --- So we substitute them out instead -decomposeRuleLhs all_bndrs lhs - = go init_env (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict - -- bindings so we know if they are recursive +decomposeRuleLhs lhs + = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict + -- bindings so we know if they are recursive where - - -- all_bndrs may include top-level imported dicts, - -- imported things with a for-all. - -- So we localise them and subtitute them out - bndr_prs = [ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ] - localise d = mkLocalId (idName d) (idType d) - - init_env = mkVarEnv bndr_prs - all_bndrs' = map subst_bndr all_bndrs - subst_bndr bndr = case lookupVarEnv init_env bndr of - Just (Var bndr') -> bndr' - Just other -> panic "decomposeRuleLhs" - Nothing -> bndr - -- 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 @@ -317,7 +363,7 @@ decomposeRuleLhs all_bndrs lhs = go (extendVarEnv env dict (simpleSubst env rhs)) body go env body = case collectArgs (simpleSubst env body) of - (Var fn, args) -> Just (all_bndrs', fn, args) + (Var fn, args) -> Just (fn, args) other -> Nothing simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr @@ -325,7 +371,9 @@ simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr -- (a) takes no account of capture; dictionary bindings use new names -- (b) can have a GlobalId (imported) in its domain -- (c) Ids only; no types are substituted - +-- +-- (b) is the reason we can't use CoreSubst... and it's no longer relevant +-- so really we should replace simpleSubst simpleSubst subst expr = go expr where @@ -341,9 +389,9 @@ simpleSubst subst expr go (Case scrut bndr ty alts) = Case (go scrut) bndr ty [(c,bs,go r) | (c,bs,r) <- alts] -addInlinePrags :: [Prag] -> Id -> CoreExpr -> (Id,CoreExpr) +addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr) addInlinePrags prags bndr rhs - = case [inl | InlinePrag inl <- prags] of + = case [inl | L _ (InlinePrag inl) <- prags] of [] -> (bndr, rhs) (inl:_) -> addInlineInfo inl bndr rhs @@ -423,6 +471,8 @@ dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside ; return (App expr (Var id)) } dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside ; return (App expr (Type ty)) } +dsCoercion WpInline thing_inside = do { expr <- thing_inside + ; return (mkInlineMe expr) } dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs ; expr <- thing_inside ; return (Let (Rec prs) expr) }