Add -expose-package flag

The `-package` flag does two things:
* it makes the package avaliable, and
* it eagerly links the package when running under the interpreter.

When compiling a program using Template Haskell this is unnecessarily
expensive when only a small part of the packages is used for evaluating
TH splices.

This introduces a new flag that only makes the package avaliable and
since the interpreter already implements lazy loading everything still
works.

There are still reasons to want the behavior that `-package` provides, like
C library referring to a symbol from a Haskell package.

Test Plan:
contbuild
manual testing looking at 'Linking' lines in '-v' output for a TH program
I can write a test if anyone feels strongly about it.

Reviewers: simonmar, austin, ezyang

Subscribers: ezyang, thomie, bgamari

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

GHC Trac Issues: #2437

(this is still not in GHC master)

(cherry picked from commit 23ab5162041591eeb67cbc583c0c17c929915cca)
(cherry picked from commit 9f3f20548c3de64ffe5ddac1b5421c41d7326281)

4 files changed, 47 insertions, 20 deletions

diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index c770eddd6e..1c1f20fe76 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -194,7 +194,7 @@ withBkpSession cid insts deps session_type do_this = do
           in ExposePackage
             (showSDoc dflags
                 (text "-unit-id" <+> ppr uid <+> ppr rn))
-            (UnitIdArg uid) rn) deps
+            (UnitIdArg uid) ExposeEager rn) deps
       } )) $ do
         dflags <- getSessionDynFlags
         -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3707ab11e3..b3c08f6ad0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -52,6 +52,7 @@ module DynFlags (
         GhcLink(..), isNoLink,
         PackageFlag(..), PackageArg(..), ModRenaming(..),
         packageFlagsChanged,
+        ExposeFlag(..),
         IgnorePackageFlag(..), TrustFlag(..),
         PackageDBFlag(..), PkgConfRef(..),
         Option(..), showOpt,
@@ -1565,6 +1566,16 @@ data ModRenaming = ModRenaming {
 instance Outputable ModRenaming where
     ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)
 
+-- | Decides if the package should be eagerly linked when running inside
+-- the interpreter.
+-- @-package foo@ makes it eager
+-- @-expose-package foo@ makes it lazy
+-- This speeds up TH when the packages are explicitly listed. See #2437
+data ExposeFlag
+  = ExposeEager
+  | ExposeLazy
+  deriving (Eq)
+
 -- | Flags for manipulating the set of non-broken packages.
 newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@
   deriving (Eq)
@@ -1577,7 +1588,10 @@ data TrustFlag
 
 -- | Flags for manipulating packages visibility.
 data PackageFlag
-  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@
+  = ExposePackage   String
+                    PackageArg
+                    ExposeFlag
+                    ModRenaming -- ^ @-package@, @-package-id@
   | HidePackage     String -- ^ @-hide-package@
   deriving (Eq) -- NB: equality instance is used by packageFlagsChanged
 
@@ -1603,7 +1617,7 @@ packageFlagsChanged idflags1 idflags0 =
      , Opt_AutoLinkPackages ]
 
 instance Outputable PackageFlag where
-    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)
+    ppr (ExposePackage n arg _ rn) = text n <> braces (ppr arg <+> ppr rn)
     ppr (HidePackage str) = text "-hide-package" <+> text str
 
 defaultHscTarget :: Platform -> HscTarget
@@ -3796,6 +3810,7 @@ package_flags_deps = [
                                                   "Use -this-unit-id instead"
   , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)
   , make_ord_flag defFlag "package"               (HasArg exposePackage)
+  , make_ord_flag defFlag "expose-package"        (HasArg onlyExposePackage)
   , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)
   , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)
   , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)
@@ -5105,17 +5120,18 @@ clearPkgConf = upd $ \s ->
   s { packageDBFlags = ClearPackageDBs : packageDBFlags s }
 
 parsePackageFlag :: String                 -- the flag
+                 -> ExposeFlag
                  -> ReadP PackageArg       -- type of argument
                  -> String                 -- string to parse
                  -> PackageFlag
-parsePackageFlag flag arg_parse str
+parsePackageFlag flag exposeFlag arg_parse str
  = case filter ((=="").snd) (readP_to_S parse str) of
     [(r, "")] -> r
     _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)
   where doc = flag ++ " " ++ str
         parse = do
             pkg_arg <- tok arg_parse
-            let mk_expose = ExposePackage doc pkg_arg
+            let mk_expose = ExposePackage doc pkg_arg exposeFlag
             ( do _ <- tok $ string "with"
                  fmap (mk_expose . ModRenaming True) parseRns
              <++ fmap (mk_expose . ModRenaming False) parseRns
@@ -5133,20 +5149,21 @@ parsePackageFlag flag arg_parse str
              return (orig, orig))
         tok m = m >>= \x -> skipSpaces >> return x
 
-exposePackage, exposePackageId, hidePackage,
+exposePackage, onlyExposePackage, exposePackageId, hidePackage,
         exposePluginPackage, exposePluginPackageId,
         ignorePackage,
         trustPackage, distrustPackage :: String -> DynP ()
-exposePackage p = upd (exposePackage' p)
+exposePackage p = upd (exposePackage' p ExposeEager)
+onlyExposePackage p = upd (exposePackage' p ExposeLazy)
 exposePackageId p =
   upd (\s -> s{ packageFlags =
-    parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s })
+    parsePackageFlag "-package-id" ExposeEager parseUnitIdArg p : packageFlags s })
 exposePluginPackage p =
   upd (\s -> s{ pluginPackageFlags =
-    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })
+    parsePackageFlag "-plugin-package" ExposeEager parsePackageArg p : pluginPackageFlags s })
 exposePluginPackageId p =
   upd (\s -> s{ pluginPackageFlags =
-    parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s })
+    parsePackageFlag "-plugin-package-id" ExposeEager parseUnitIdArg p : pluginPackageFlags s })
 hidePackage p =
   upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 ignorePackage p =
@@ -5157,10 +5174,10 @@ trustPackage p = exposePackage p >> -- both trust and distrust also expose a pac
 distrustPackage p = exposePackage p >>
   upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })
 
-exposePackage' :: String -> DynFlags -> DynFlags
-exposePackage' p dflags
+exposePackage' :: String -> ExposeFlag -> DynFlags -> DynFlags
+exposePackage' p exposeFlag dflags
     = dflags { packageFlags =
-            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }
+            parsePackageFlag "-package" exposeFlag parsePackageArg p : packageFlags dflags }
 
 parsePackageArg :: ReadP PackageArg
 parsePackageArg =
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index e80574c0d1..6dfb04115f 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -739,7 +739,7 @@ applyPackageFlag
 
 applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
   case flag of
-    ExposePackage _ arg (ModRenaming b rns) ->
+    ExposePackage _ arg exposeFlag (ModRenaming b rns) ->
        case findPackages prec_map pkg_db arg pkgs unusable of
          Left ps         -> packageFlagErr dflags flag ps
          Right (p:_) -> return vm'
@@ -773,7 +773,7 @@ applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
                 , uv_renamings = rns
                 , uv_package_name = First (Just n)
                 , uv_requirements = reqs
-                , uv_explicit = True
+                , uv_explicit = exposeFlag == ExposeEager
                 }
            vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
            -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
@@ -936,6 +936,16 @@ packageFlagErr :: DynFlags
                -> PackageFlag
                -> [(PackageConfig, UnusablePackageReason)]
                -> IO a
+
+-- for missing DPH package we emit a more helpful error message, because
+-- this may be the result of using -fdph-par or -fdph-seq.
+packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _ _) []
+  | is_dph_package pkg
+  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
+  where dph_err = text "the " <> text pkg <> text " package is not installed."
+                  $$ text "To install it: \"cabal install dph\"."
+        is_dph_package pkg = "dph" `isPrefixOf` pkg
+
 packageFlagErr dflags flag reasons
   = packageFlagErr' dflags (pprFlag flag) reasons
 
@@ -963,7 +973,7 @@ packageFlagErr' dflags flag_doc reasons
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
     HidePackage p   -> text "-hide-package " <> text p
-    ExposePackage doc _ _ -> text doc
+    ExposePackage doc _ _ _ -> text doc
 
 pprTrustFlag :: TrustFlag -> SDoc
 pprTrustFlag flag = case flag of
@@ -1470,8 +1480,8 @@ mkPackageState dflags dbs preload0 = do
             _  -> unit'
       addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
       -- This is the set of maximally preferable packages. In fact, it is a set of
-      -- most preferable *units* keyed by package name, which act as stand-ins in 
-      -- for "a package in a database". We use units here because we don't have 
+      -- most preferable *units* keyed by package name, which act as stand-ins in
+      -- for "a package in a database". We use units here because we don't have
       -- "a package in a database" as a type currently.
       mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags
                     then emptyUDFM
@@ -1481,7 +1491,7 @@ mkPackageState dflags dbs preload0 = do
       -- with the most preferable unit for package. Being equi-preferable means that
       -- they must be in the same database, with the same version, and the same pacakge name.
       --
-      -- We must take care to consider all these units and not just the most 
+      -- We must take care to consider all these units and not just the most
       -- preferable one, otherwise we can end up with problems like #16228.
       mostPreferable u =
         case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
@@ -1576,7 +1586,6 @@ mkPackageState dflags dbs preload0 = do
       req_ctx = Map.map (Set.toList)
               $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map))
 
-
   let preload2 = preload1
 
   let
diff --git a/testsuite/tests/ghc-api/T9595.hs b/testsuite/tests/ghc-api/T9595.hs
index 0f71d7700b..d26186f757 100644
--- a/testsuite/tests/ghc-api/T9595.hs
+++ b/testsuite/tests/ghc-api/T9595.hs
@@ -20,6 +20,7 @@ main =
                 setSessionDynFlags (dflags {
                     packageFlags = [ExposePackage "-package ghc"
                                                   (PackageArg "ghc")
+                                                  ExposeEager
                                                   (ModRenaming True [])]
                     })
                 dflags <- getSessionDynFlags