1 files changed, 35 insertions, 4 deletions
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 165130a..331b42d 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -25,6 +25,8 @@ module DsUtils (
         wrapBind, wrapBinds,
 
         mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
+        mkStringExprAtTopLevel, mkStringExprFSAtTopLevel,
+        bindExprAtTopLevel,
 
         seqVar,
 
@@ -73,6 +75,8 @@ import SrcLoc
 import Util
 import DynFlags
 import FastString
+import Data.IORef
+import TcRnMonad
 import qualified GHC.LanguageExtensions as LangExt
 
 import TcEvidence
@@ -466,10 +470,9 @@ mkErrorAppDs :: Id              -- The error function
 mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
     dflags <- getDynFlags
-    let
-        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
-        core_msg = Lit (mkMachString full_msg)
-        -- mkMachString returns a result of type String#
+    let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
+                   -- mkMachString returns a result of type String#
+    core_msg <- bindExprAtTopLevel (Lit (mkMachString full_msg))
     return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])
 
 {-
@@ -567,6 +570,34 @@ mkCastDs :: CoreExpr -> Coercion -> CoreExpr
 mkCastDs e co | isReflCo co = e
               | otherwise   = Cast e co
 
+-- | Like 'mkStringExpr' except it makes the string a new top-level binder.
+mkStringExprAtTopLevel :: String -> DsM CoreExpr
+mkStringExprAtTopLevel = mkStringExprFSAtTopLevel . fsLit
+
+-- | Like 'mkStringExprFS' except it makes the string a new top-level binder.
+mkStringExprFSAtTopLevel :: FastString -> DsM CoreExpr
+mkStringExprFSAtTopLevel str = do
+  str_expr <- mkStringExprFS str
+  bindExprAtTopLevel str_expr
+
+-- | Attempt to bind an expression at the top level.
+--
+-- @bindExprAtTopLevel e@ returns a @Var v@ where @v@ is bound to @e@
+-- if we are compiling a whole module.
+-- If we are compiling an individual expression, e.g. in GHCi,
+-- it returns @e@ unmodified.
+bindExprAtTopLevel :: CoreExpr -> DsM CoreExpr
+-- see Note [Adding Top-Level Binders in the Desguarer]
+bindExprAtTopLevel expr = do
+  top_binds_var_maybe <- ds_top_binds <$> getGblEnv
+  case top_binds_var_maybe of
+    Nothing  -> return expr
+    Just var -> do
+      id <- newSysLocalDs (exprType expr)
+      liftIO $ modifyIORef var ((NonRec id expr) :)
+      return (Var id)
+
+
 {-
 ************************************************************************
 *                                                                      *