diff options
Diffstat (limited to 'compiler/specialise/Specialise.hs')
| -rw-r--r-- | compiler/specialise/Specialise.hs | 19 |
1 files changed, 9 insertions, 10 deletions
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 869da640ea..6f775dfdcb 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -9,6 +9,8 @@ module Specialise ( specProgram, specUnfolding ) where #include "HsVersions.h" +import GhcPrelude + import Id import TcType hiding( substTy ) import Type hiding( substTy, extendTvSubstList ) @@ -43,9 +45,7 @@ import State import UniqDFM import Control.Monad -#if __GLASGOW_HASKELL__ > 710 import qualified Control.Monad.Fail as MonadFail -#endif {- ************************************************************************ @@ -147,7 +147,7 @@ becomes in fl -We still have recusion for non-overloaded functions which we +We still have recursion for non-overloaded functions which we specialise, but the recursive call should get specialised to the same recursive version. @@ -735,7 +735,7 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) - , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) ; return ([], []) } @@ -1343,10 +1343,10 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs -- See Note [Specialising imported functions] in OccurAnal | InlinePragma { inl_inline = Inlinable } <- inl_prag - = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding) + = (inl_prag { inl_inline = NoUserInline }, noUnfolding) | otherwise - = (inl_prag, specUnfolding poly_tyvars spec_app + = (inl_prag, specUnfolding dflags poly_tyvars spec_app arity_decrease fn_unf) arity_decrease = length spec_dict_args @@ -2011,6 +2011,7 @@ mkCallUDs' env f args EqPred {} -> True IrredPred {} -> True -- Things like (D []) where D is a -- Constraint-ranged family; Trac #7785 + ForAllPred {} -> True {- Note [Type determines value] @@ -2095,7 +2096,7 @@ mkDB bind = (bind, bind_fvs bind) -- | Identify the free variables of a 'CoreBind' bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs +bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs where bndrs = map fst prs rhs_fvs = unionVarSets (map pair_fvs prs) @@ -2287,12 +2288,10 @@ instance Monad SpecM where case f y of SpecM z -> z - fail str = SpecM $ fail str + fail = MonadFail.fail -#if __GLASGOW_HASKELL__ > 710 instance MonadFail.MonadFail SpecM where fail str = SpecM $ fail str -#endif instance MonadUnique SpecM where getUniqueSupplyM |