diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Hs/Syn/Type.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 37 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 65 |
4 files changed, 94 insertions, 26 deletions
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index 1c9b1706bd..58af03f481 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -5,7 +5,7 @@ -- this task, see #12706, #15320, #16804, and #17331. module GHC.Hs.Syn.Type ( -- * Extracting types from HsExpr - lhsExprType, hsExprType, + lhsExprType, hsExprType, hsWrapperType, -- * Extracting types from HsSyn hsLitType, hsPatType, hsLPatType diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index b98f5c86f9..e06634fb3f 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -30,6 +30,7 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.HsToCore.Errors.Types +import GHC.Hs.Syn.Type ( hsExprType, hsWrapperType ) import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env @@ -302,7 +303,9 @@ dsExpr (HsLamCase _ matches) dsExpr e@(HsApp _ fun arg) = do { fun' <- dsLExpr fun - ; dsWhenNoErrs (dsLExprNoLP arg) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + ; dsWhenNoErrs (hsExprType e) (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } dsExpr e@(HsAppType {}) = dsHsWrapped e @@ -325,7 +328,7 @@ That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. -} -dsExpr (ExplicitTuple _ tup_args boxity) +dsExpr e@(ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (Missing (Scaled mult ty)) -- For every missing expression, we need -- another lambda in the desugaring. @@ -337,15 +340,20 @@ dsExpr (ExplicitTuple _ tup_args boxity) = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } - ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + ; dsWhenNoErrs (hsExprType e) (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right (\(lam_vars, args) -> mkCoreLams lam_vars $ mkCoreTupBoxity boxity args) } -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -dsExpr (ExplicitSum types alt arity expr) - = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types) +dsExpr e@(ExplicitSum types alt arity expr) + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + = dsWhenNoErrs (hsExprType e) (dsLExprNoLP expr) + (mkCoreUbxSum arity alt types) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -796,10 +804,21 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr = expr ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ]) - (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } - -- Use mkCoreApps instead of mkApps: - -- unboxed types are possible with RebindableSyntax (#19883) + -- We need to compute the type of the desugared expression without + -- actually performing the desugaring, which could be problematic + -- in the presence of representation polymorphism. + -- See Note [Desugaring representation-polymorphic applications] + -- in GHC.HsToCore.Utils + expr_type = hsWrapperType res_wrap + (applyTypeToArgs fun (exprType fun) wrapped_args) + ; dsWhenNoErrs expr_type + (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_msg n | n <- [1..] ]) + (\_ -> core_res_wrap (mkCoreApps fun wrapped_args)) } + -- Use mkCoreApps instead of mkApps: + -- unboxed types are possible with RebindableSyntax (#19883) + -- This won't be evaluated if there are any + -- representation-polymorphic arguments. + where mk_msg n = LevityCheckInSyntaxExpr (DsArgNum n) expr dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index d1689ce81a..6fd3ef10c4 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -49,7 +49,7 @@ module GHC.HsToCore.Monad ( EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Representation polymorphism - dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs, + dsNoLevPoly, dsNoLevPolyExpr, -- Trace injection pprRuntimeTrace @@ -610,20 +610,6 @@ dsNoLevPolyExpr e provenance | isExprLevPoly e = diagnosticDs (DsLevityPolyInExpr e provenance) | otherwise = return () --- | Runs the thing_inside. If there are no errors, then returns the expr --- given. Otherwise, returns unitExpr. This is useful for doing a bunch --- of representation polymorphism checks and then avoiding making a core App. --- (If we make a core App on a representation-polymorphic argument, detecting --- how to handle the let/app invariant might call isUnliftedType, which panics --- on a representation-polymorphic type.) --- See #12709 for an example of why this machinery is necessary. -dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr -dsWhenNoErrs thing_inside mk_expr - = do { (result, no_errs) <- askNoErrsDs thing_inside - ; return $ if no_errs - then mk_expr result - else unitExpr } - -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace -- captures that information and causes it to be printed *at runtime* diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 5c68525f12..333929c956 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -30,7 +30,7 @@ module GHC.HsToCore.Utils ( wrapBind, wrapBinds, mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - mkFailExpr, + mkFailExpr, dsWhenNoErrs, seqVar, @@ -982,6 +982,69 @@ mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLocA pat) +{- Note [Desugaring representation-polymorphic applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To desugar a function application + +> HsApp _ f e :: HsExpr GhcTc + +into Core, we need to know whether the argument e is lifted or unlifted, +in order to respect the let/app invariant. + (See Note [Core let/app invariant] in GHC.Core) + +This causes a problem when e is representation-polymorphic, as we aren't able +to determine whether to build a Core application + +> f_desugared e_desugared + +or a strict binding: + +> case e_desugared of { x -> f_desugared x } + +See GHC.Core.Make.mkValApp, which will call isUnliftedType, which panics +on a representation-polymorphic type. + +These representation-polymorphic applications are disallowed in source Haskell, +but we might want to continue desugaring as much as possible instead of +aborting as soon as we see such a problematic function application. + +When desugaring an expression which might have problems (such as disallowed +representation polymorphism as above), we check for errors first, and then: + + - if no problems were detected, desugar normally, + - if errors were found, we want to avoid desugaring, so we instead return + a runtime error Core expression which has the right type. + +This is what the function dsWhenNoErrs achieves: + +> dsWhenNoErrs result_ty thing_inside mk_expr + +We run thing_inside to check for errors. If there are no errors, we apply +mk_expr to desugar; otherwise, we construct a runtime error at type result_ty. + +Note that result_ty is only used when there is an error, and isn't inspected +otherwise; this means it's OK to pass something that can be a bit expensive +to compute. + +See #12709 for an example of why this machinery is necessary. +See also #14765 and #18149 for why it is important to return an expression +that has the proper type in case of an error. +-} + +-- | Runs the thing_inside. If there are no errors, use the provided +-- function to construct a Core expression, and return it. +-- Otherwise, return a runtime error, of the given type. +-- This is useful for doing a bunch of representation polymorphism checks +-- and then avoiding making a Core App. +-- See Note [Desugaring representation-polymorphic applications] +dsWhenNoErrs :: Type -> DsM a -> (a -> CoreExpr) -> DsM CoreExpr +dsWhenNoErrs result_ty thing_inside mk_expr + = do { (result, no_errs) <- askNoErrsDs thing_inside + ; if no_errs + then return $ mk_expr result + else mkErrorAppDs rUNTIME_ERROR_ID result_ty + (text "dsWhenNoErrs found errors") } + {- ********************************************************************* * * Ticks |