summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-rw-r--r--compiler/GHC/HsToCore/Binds.hs2
-rw-r--r--compiler/GHC/HsToCore/Expr.hs20
-rw-r--r--compiler/GHC/HsToCore/Match.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs12
4 files changed, 17 insertions, 19 deletions
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 3adecc0d5b..8081d921ac 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -1136,7 +1136,7 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1) doc)
= do { x <- newSysLocalDsNoLP w t1
; w1 <- dsHsWrapper c1
; w2 <- dsHsWrapper c2
- ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+ ; let app f a = mkCoreAppDs f a
arg = w1 (Var x)
; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
; if ok
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index be61777722..0e0402077a 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -315,10 +315,10 @@ dsExpr (HsLamCase _ matches)
= do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam discrim_var matching_code }
-dsExpr e@(HsApp _ fun arg)
+dsExpr (HsApp _ fun arg)
= do { fun' <- dsLExpr fun
; dsWhenNoErrs (dsLExprNoLP arg)
- (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
+ (\arg' -> mkCoreAppDs fun' arg') }
dsExpr (HsAppType ty e _)
= do { e' <- dsLExpr e
@@ -384,11 +384,11 @@ bindNonRec will automatically do the right thing, giving us:
See #18151.
-}
-dsExpr e@(OpApp _ e1 op e2)
+dsExpr (OpApp _ e1 op e2)
= -- for the type of y, we need the type of op's 2nd argument
do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
- (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
+ (\exprs' -> mkCoreAppsDs op' exprs') }
-- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y
--
@@ -404,26 +404,24 @@ dsExpr e@(SectionL _ expr op) = do
(newSysLocalsDsNoLP [x_ty, y_ty])
(\[x_id, y_id] ->
bindNonRec x_id x_core
- $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)
- core_op [Var x_id, Var y_id]))
+ $ Lam y_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
-- Postfix operator section
(_:_, _) -> do
- return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core
+ return $ mkCoreAppDs core_op x_core
_ -> pprPanic "dsExpr(SectionL)" (ppr e)
-- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr
--
-- See Note [Desugaring operator sections].
-dsExpr e@(SectionR _ op expr) = do
+dsExpr (SectionR _ op expr) = do
core_op <- dsLExpr op
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
y_core <- dsLExpr expr
dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty])
(\[x_id, y_id] -> bindNonRec y_id y_core $
- Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
- core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty)))
@@ -1083,7 +1081,7 @@ dsConLike :: ConLike -> DsM CoreExpr
dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)
dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of
Just (id, add_void)
- | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+ | add_void -> App (Var id) (Var voidPrimId)
| otherwise -> Var id
_ -> pprPanic "dsConLike" (ppr ps)
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a33e3d9b41..660b942525 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -300,7 +300,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
-- compile the view expressions
; viewExpr' <- dsLExpr viewExpr
; return (mkViewMatchResult var'
- (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+ (mkCoreAppDs viewExpr' (Var var))
match_result) }
matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index b4d1b1b761..bb8a869b09 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -326,7 +326,7 @@ mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
nlHsTyApp matcher [getRuntimeRep ty, ty]
cont <- mkCoreLams bndrs <$> runMatchResult fail match_result
- return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+ return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
alt_bndrs = bndrs,
@@ -485,8 +485,8 @@ There are a few subtleties in the desugaring of `seq`:
-}
-- NB: Make sure the argument is not levity polymorphic
-mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+mkCoreAppDs :: HasDebugCallStack => CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
| f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2)
= Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
where
@@ -495,11 +495,11 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg
-> v1 -- Note [Desugaring seq], points (2) and (3)
_ -> mkWildValBinder Many ty1
-mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make
+mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in GHC.Core.Make
-- NB: No argument can be levity polymorphic
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
+mkCoreAppsDs :: HasDebugCallStack => CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs fun args = foldl' mkCoreAppDs fun args
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific version of GHC.Core.Utils.mkCast,
View Lorry Controller Status