From 8c40e3f98649d6d3310a1181add7d2af6f6b7c87 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 1 Nov 2019 17:26:12 +0000 Subject: More wibbles --- compiler/coreSyn/CoreUnfold.hs | 14 +++++++++----- compiler/coreSyn/CoreUtils.hs | 4 +++- compiler/deSugar/DsBinds.hs | 13 ++++++++----- compiler/deSugar/DsExpr.hs | 3 ++- compiler/deSugar/DsMonad.hs | 10 +++++++--- 5 files changed, 29 insertions(+), 15 deletions(-) diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 8853b8592b..bf082518c9 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -1120,11 +1120,12 @@ certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline. -- If so, return a *stable* unfolding for it, that will always inline. certainlyWillInline dflags fn_info - = case unfoldingInfo fn_info of - CoreUnfolding { uf_tmpl = e, uf_guidance = g } - | loop_breaker -> Nothing -- Won't inline, so try w/w - | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] - | otherwise -> do_cunf e g -- Depends on size, so look at that + = case fn_unf of + CoreUnfolding { uf_tmpl = e, uf_guidance = g, uf_src = src } + | loop_breaker -> Nothing -- Won't inline, so try w/w + | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | compulsory src -> Just fn_unf + | otherwise -> do_cunf e g -- Depends on size, so look at that DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense -- to do so, and even if it is currently a @@ -1137,6 +1138,9 @@ certainlyWillInline dflags fn_info noinline = inlinePragmaSpec (inlinePragInfo fn_info) == InlSpecNoInline fn_unf = unfoldingInfo fn_info + compulsory InlineCompulsory = True + compulsory _ = False + do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding do_cunf _ UnfNever = Nothing do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 1ca5a6b438..342ad414f9 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -495,7 +495,9 @@ bindNonRec bndr rhs body -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" needsCaseBinding :: Type -> CoreExpr -> Bool -needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) +needsCaseBinding ty rhs + = not (isLiftedType_maybe ty `orElse` True) + && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index bee958afac..93e4a988a0 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -49,7 +49,7 @@ import TcEvidence import TcType import Type import Coercion -import TysWiredIn ( typeNatKind, typeSymbolKind ) +import TysWiredIn ( typeNatKind, typeSymbolKind, unitTy, unitDataConId ) import Id import MkId(proxyHashId) import Name @@ -187,7 +187,8 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_exports = exports , abs_ev_binds = ev_binds , abs_binds = binds, abs_sig = has_sig }) - = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource) + = do { ds_binds <- switchOffLevPolyCheck has_sig exports $ + applyWhen (needToRunPmCheck dflags FromSource) -- FromSource might not be accurate, but at worst -- we do superfluous calls to the pattern match -- oracle. @@ -197,8 +198,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts (addTyCsDs (listToBag dicts)) (dsLHsBinds binds) - ; ds_ev_binds <- switchOffLevPolyCheck has_sig exports $ - dsTcEvBinds_s ev_binds + ; ds_ev_binds <- dsTcEvBinds_s ev_binds -- dsAbsBinds does the hard work ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } @@ -382,7 +382,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs NoInlSpec -> (gbl_id, rhs) InlSpecNoInline -> (gbl_id, rhs) InlSpecInlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - InlSpecCompulsory -> (gbl_id `setIdUnfolding` compulsory_unf, rhs) + InlSpecCompulsory -> (gbl_id `setIdUnfolding` compulsory_unf, dummy_rhs) InlSpecInline -> inline_pair where @@ -402,6 +402,9 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs) + dummy_rhs = Var unitDataConId `mkCast` + mkUnsafeCo Representational unitTy (idType gbl_id) + dictArity :: [Var] -> Arity -- Don't count coercion variables in arity dictArity dicts = count isId dicts diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 7e09716223..c5a39c901a 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -1141,7 +1141,8 @@ checkLevPolyFun :: Var -> Type -> DsM () checkLevPolyFun var ty | hasNoBinding var = do { env <- getLclEnv - ; when (dsl_lev_poly_check env && not (null bad_tys)) $ + ; pprTrace "clpf" (ppr (dsl_lev_poly_check env)) $ + when (dsl_lev_poly_check env && not (null bad_tys)) $ levPolyPrimopErr var ty bad_tys } | otherwise = return () diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 874ccfb793..27b375f868 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -604,10 +604,14 @@ pprRuntimeTrace str doc expr = do switchOffLevPolyCheck :: Bool -> [ABExport GhcTc] -> DsM a -> DsM a switchOffLevPolyCheck has_sig exports thing_inside - | has_sig + | pprTrace "switch" (ppr has_sig $$ ppr exports) $ + has_sig , [ABE { abe_poly = poly_id }] <- exports - , InlSpecCompulsory <- inlinePragmaSpec (idInlinePragma poly_id) - = updLclEnv (\env -> env { dsl_lev_poly_check = False }) thing_inside + , InlSpecCompulsory <- pprTrace "sw2" (vcat [ ppr (idInlinePragma poly_id) + , ppr (inlinePragmaSpec (idInlinePragma poly_id)) ]) $ + inlinePragmaSpec (idInlinePragma poly_id) + = pprTrace "switch off" empty $ + updLclEnv (\env -> env { dsl_lev_poly_check = False }) thing_inside | otherwise = thing_inside -- cgit v1.2.1