X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=515ac8565f4d86215502eeb9bacb9efd3cbabffd;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=4c144b8e507ba201100dc1f73fa38bec7f9f7bc6;hpb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4c144b8..515ac85 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -31,16 +31,16 @@ import MkCore import CoreUtils import CoreFVs -import TcHsSyn ( mkArbitraryType ) -- Mis-placed? import TcType +import TysPrim ( anyTypeOfKind ) import CostCentre import Module import Id -import Var ( Var, TyVar ) +import MkId ( seqId ) +import Var ( Var, TyVar, tyVarKind ) import VarSet import Rules import VarEnv -import Type import Outputable import SrcLoc import Maybes @@ -192,8 +192,9 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds) -- see if it has any impact; it is on by default = -- Note [Abstracting over tyvars only] do { core_prs <- ds_lhs_binds NoSccs binds - ; arby_env <- mkArbitraryTypeEnv tyvars exports - ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs + ; + ; let arby_env = mkArbitraryTypeEnv tyvars exports + (lg_binds, core_prs') = mapAndUnzip do_one core_prs bndrs = mkVarSet (map fst core_prs) add_lets | core_prs `lengthExceeds` 10 = add_some @@ -262,26 +263,26 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr) - ; let dict_args = map Var dicts - - 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 { ty_args <- mapM mk_ty_arg all_tyvars - ; let substitute = substTyWith all_tyvars ty_args + ; let 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 { let ty_args = map mk_ty_arg all_tyvars + 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) + ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global + local core_bind) prags ; let (spec_binds, rules) = unzip (catMaybes mb_specs) global' = addIdSpecialisations global rules rhs = mkLams tyvars $ mkLams dicts $ mkTupleSelector locals' (locals' !! n) tup_id $ - mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args + mkVarApps (mkTyApps (Var poly_tup_id) ty_args) + dicts ; return ((global', rhs) : spec_binds) } where mk_ty_arg all_tyvar - | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar) + | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = dsMkArbitraryType all_tyvar ; export_binds_s <- mapM mk_bind (exports `zip` [0..]) @@ -344,9 +345,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } | otherwise -> do - { f_body <- fix_up (Let mono_bind (Var mono_id)) + { let f_body = fix_up (Let mono_bind (Var mono_id)) - ; let local_poly = setIdNotExported poly_id + 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 @@ -367,9 +368,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind where -- Bind to Any any of all_ptvs that aren't -- relevant for this particular function - fix_up body | null void_tvs = return body - | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs - ; return (mkTyApps (mkLams void_tvs body) void_tys) } + fix_up body | null void_tvs = body + | otherwise = mkTyApps (mkLams void_tvs body) $ + map dsMkArbitraryType void_tvs void_tvs = all_tvs \\ tvs @@ -383,27 +384,24 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind 2 (ppr spec_expr) -mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type) +mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type -- If any of the tyvars is missing from any of the lists in -- the second arg, return a binding in the result mkArbitraryTypeEnv tyvars exports = go emptyVarEnv exports where - go env [] = return env + go env [] = env go env ((ltvs, _, _, _) : exports) - = do { env' <- foldlM extend env [tv | tv <- tyvars - , not (tv `elem` ltvs) - , not (tv `elemVarEnv` env)] - ; go env' exports } - - extend env tv = do { ty <- dsMkArbitraryType tv - ; return (extendVarEnv env tv ty) } + = go env' exports + where + env' = foldl extend env [tv | tv <- tyvars + , not (tv `elem` ltvs) + , not (tv `elemVarEnv` env)] + extend env tv = extendVarEnv env tv (dsMkArbitraryType tv) -dsMkArbitraryType :: TcTyVar -> DsM Type -dsMkArbitraryType tv = mkArbitraryType warn tv - where - warn span msg = putSrcSpanDs span (warnDs msg) +dsMkArbitraryType :: TcTyVar -> Type +dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv) \end{code} Note [Unused spec binders] @@ -476,6 +474,12 @@ decomposeRuleLhs lhs -- a LHS: let f71 = M.f Int in f71 decomp env (Let (NonRec dict rhs) body) = decomp (extendVarEnv env dict (simpleSubst env rhs)) body + + decomp env (Case scrut bndr ty [(DEFAULT, _, body)]) + | isDeadBinder bndr -- Note [Matching seqId] + = Just (seqId, [Type (idType bndr), Type ty, + simpleSubst env scrut, simpleSubst env body]) + decomp env body = case collectArgs (simpleSubst env body) of (Var fn, args) -> Just (fn, args) @@ -516,17 +520,23 @@ addInlinePrags prags bndr rhs (inl:_) -> addInlineInfo inl bndr rhs addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr) -addInlineInfo (Inline phase is_inline) bndr rhs - = (attach_phase bndr phase, wrap_inline is_inline rhs) +addInlineInfo (Inline prag is_inline) bndr rhs + = (attach_pragma bndr prag, wrap_inline is_inline rhs) where - attach_phase bndr phase - | isAlwaysActive phase = bndr -- Default phase - | otherwise = bndr `setInlinePragma` phase + attach_pragma bndr prag + | isDefaultInlinePragma prag = bndr + | otherwise = bndr `setInlinePragma` prag wrap_inline True body = mkInlineMe body wrap_inline False body = body \end{code} +Note [Matching seq] +~~~~~~~~~~~~~~~~~~~ +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. + %************************************************************************ %* *