Do not init record accessors as exported

This was causing redundant code generation when accessors are not
actually exported, as they were being marked as "exported" at
initialization.

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D2270

3 files changed, 17 insertions, 2 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index b589809ded..6045937173 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -33,6 +33,7 @@ module Id (
         mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
         mkLocalIdOrCoVarWithInfo,
         mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
+        mkNonExportedLocalId,
         mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
         mkUserLocal, mkUserLocalOrCoVar,
         mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
@@ -287,6 +288,12 @@ mkExportedLocalId :: IdDetails -> Name -> Type -> Id
 mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
         -- Note [Free type variables]
 
+-- | Create a local 'Id' that is marked as not-exported.
+-- These may be removed as dead code.
+mkNonExportedLocalId :: IdDetails -> Name -> Type -> Id
+mkNonExportedLocalId details name ty =
+  Var.mkLocalVar details name ty vanillaIdInfo
+
 mkExportedVanillaId :: Name -> Type -> Id
 mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
         -- Note [Free type variables]
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 75f6a3491b..c7a869d5cd 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -296,7 +296,10 @@ deSugar hsc_env
                      (text "Desugar"<+>brackets (ppr mod))
                      (const ()) $
      do { -- Desugar the program
-        ; let export_set = availsToNameSet exports
+        ; let export_set =
+                -- Used to be 'availsToNameSet', but we now export selectors
+                -- only when necessary. See #12125.
+                availsToNameSetWithSelectors exports
               target     = hscTarget dflags
               hpcInfo    = emptyHpcInfo other_hpc_info
 
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 2d6637ea29..8c91b4897d 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -941,7 +941,12 @@ mkOneRecordSelector all_cons idDetails fl
     lbl      = flLabel fl
     sel_name = flSelector fl
 
-    sel_id = mkExportedLocalId rec_details sel_name sel_ty
+    sel_id =
+      -- Do not mark record selectors as exported to avoid keeping these Ids
+      -- alive unnecessarily. See #12125. Selectors are now marked as exported
+      -- when necessary by desugarer ('Desugar.addExportFlagsAndRules', also see
+      -- uses of 'availsToNameSetWithSelectors' in 'Desugar.hs').
+      mkNonExportedLocalId rec_details sel_name sel_ty
     rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1