From 3bbd2bf2b9befaae53effb6bfc593b5ff7ff0c76 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Sat, 11 Mar 2023 14:25:13 -0500
Subject: [PATCH] compiler/tc: Small optimisation of evCallStack
Don't lookupIds unless we actually need them.
---
compiler/GHC/Tc/Types/EvTerm.hs | 10 ++++------
1 file changed, 4 insertions(+), 6 deletions(-)
diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs
index 905cf1fa1444..fe845acf4929 100644
--- a/compiler/GHC/Tc/Types/EvTerm.hs
+++ b/compiler/GHC/Tc/Types/EvTerm.hs
@@ -38,7 +38,9 @@ evDelayedError ty msg
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
EvCallStack -> m EvExpr
-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-evCallStack cs = do
+evCallStack EvCsEmpty =
+ Var <$> lookupId emptyCallStackName
+evCallStack (EvCsPushCall fs loc tm) = do
df <- getDynFlags
let platform = targetPlatform df
m <- getModule
@@ -53,8 +55,6 @@ evCallStack cs = do
, return $ mkIntExprInt platform (srcSpanEndCol l)
]
- emptyCS <- Var <$> lookupId emptyCallStackName
-
pushCSVar <- lookupId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
@@ -69,6 +69,4 @@ evCallStack cs = do
let ip_co = unwrapIP (exprType tm)
return (pushCS nameExpr locExpr (Cast tm ip_co))
- case cs of
- EvCsPushCall fs loc tm -> mkPush fs loc tm
- EvCsEmpty -> return emptyCS
+ mkPush fs loc tm
--
GitLab