Untangled GHC.Types.Id.Make from the driver

7 files changed, 44 insertions, 35 deletions

diff --git a/compiler/GHC/Driver/Config/HsToCore.hs b/compiler/GHC/Driver/Config/HsToCore.hs
new file mode 100644
index 0000000000..ef8d6347e2
--- /dev/null
+++ b/compiler/GHC/Driver/Config/HsToCore.hs
@@ -0,0 +1,19 @@
+module GHC.Driver.Config.HsToCore
+  ( initBangOpts
+  )
+where
+
+import GHC.Types.Id.Make
+import GHC.Driver.Session
+import qualified GHC.LanguageExtensions as LangExt
+
+initBangOpts :: DynFlags -> BangOpts
+initBangOpts dflags = BangOpts
+  { bang_opt_strict_data   = xopt LangExt.StrictData dflags
+  , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags
+      -- Don't unbox if we aren't optimising; rather arbitrarily,
+      -- we use -fomit-iface-pragmas as the indication
+  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags
+  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags
+  }
+
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
index 26331002f3..6ffed05ee9 100644
--- a/compiler/GHC/HsToCore/Foreign/Call.hs
+++ b/compiler/GHC/HsToCore/Foreign/Call.hs
@@ -97,14 +97,13 @@ dsCCall lbl args may_gc result_ty
   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
        (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
-       dflags <- getDynFlags
        let
            target = StaticTarget NoSourceText lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
-           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
+           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
-mkFCall :: DynFlags -> Unique -> ForeignCall
+mkFCall :: Unique -> ForeignCall
         -> [CoreExpr]     -- Args
         -> Type           -- Result type
         -> CoreExpr
@@ -117,7 +116,7 @@ mkFCall :: DynFlags -> Unique -> ForeignCall
 -- Here we build a ccall thus
 --      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 --                      a b s x c
-mkFCall dflags uniq the_fcall val_args res_ty
+mkFCall uniq the_fcall val_args res_ty
   = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level
     mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
   where
@@ -125,7 +124,7 @@ mkFCall dflags uniq the_fcall val_args res_ty
     body_ty = (mkVisFunTysMany arg_tys res_ty)
     tyvars  = tyCoVarsOfTypeWellScoped body_ty
     ty      = mkInfForAllTys tyvars body_ty
-    the_fcall_id = mkFCallId dflags uniq the_fcall ty
+    the_fcall_id = mkFCallId uniq the_fcall ty
 
 unboxArg :: CoreExpr                    -- The supplied argument, not representation-polymorphic
          -> DsM (CoreExpr,              -- To pass as the actual argument
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 8eae17e414..0c04929984 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -283,7 +283,7 @@ dsFCall fn_id co fcall mDeclHeader = do
         -- Build the worker
         worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
         tvs           = map binderVar tv_bndrs
-        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
         work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
 
@@ -326,9 +326,8 @@ dsPrimCall fn_id co fcall = do
     args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
 
     ccall_uniq <- newUnique
-    dflags <- getDynFlags
     let
-        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
+        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
         rhs      = mkLams tvs (mkLams args call_app)
         rhs'     = Cast rhs co
     return ([(fn_id, rhs')], mempty, mempty)
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 88fb6cb0ff..8f8b858d31 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1471,8 +1471,7 @@ tcIfaceExpr (IfaceLit lit)
 tcIfaceExpr (IfaceFCall cc ty) = do
     ty' <- tcIfaceType ty
     u <- newUnique
-    dflags <- getDynFlags
-    return (Var (mkFCallId dflags u cc ty'))
+    return (Var (mkFCallId u cc ty'))
 
 tcIfaceExpr (IfaceTuple sort args)
   = do { args' <- mapM tcIfaceExpr args
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 7890bce91f..9e7dca9bd4 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
 
 import GHC.Driver.Env
 import GHC.Driver.Session
+import GHC.Driver.Config.HsToCore
 
 import GHC.Hs
 
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 657f33dd91..6fe9f0dafe 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -24,7 +24,7 @@ module GHC.Types.Id.Make (
         unwrapNewTypeBody, wrapFamInstBody,
         DataConBoxer(..), vanillaDataConBoxer,
         mkDataConRep, mkDataConWorkId,
-        DataConBangOpts (..), BangOpts (..), initBangOpts,
+        DataConBangOpts (..), BangOpts (..),
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
@@ -40,45 +40,46 @@ import GHC.Prelude
 
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Types
+import GHC.Builtin.Names
+
+import GHC.Core
 import GHC.Core.Type
 import GHC.Core.Multiplicity
 import GHC.Core.TyCo.Rep
 import GHC.Core.FamInstEnv
 import GHC.Core.Coercion
 import GHC.Core.Reduction
-import GHC.Tc.Utils.TcType as TcType
 import GHC.Core.Make
 import GHC.Core.FVs     ( mkRuleInfo )
 import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase )
 import GHC.Core.Unfold.Make
 import GHC.Core.SimpleOpt
-import GHC.Types.Literal
-import GHC.Types.SourceText
 import GHC.Core.TyCon
 import GHC.Core.Class
+import GHC.Core.DataCon
+
+import GHC.Types.Literal
+import GHC.Types.SourceText
 import GHC.Types.Name.Set
 import GHC.Types.Name
 import GHC.Types.ForeignCall
-import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Demand
 import GHC.Types.Cpr
-import GHC.Core
-import GHC.Types.Unique
 import GHC.Types.Unique.Supply
-import GHC.Builtin.Names
 import GHC.Types.Basic       hiding ( SuccessFlag(..) )
+import GHC.Types.Var (VarBndr(Bndr))
+
+import GHC.Tc.Utils.TcType as TcType
+
 import GHC.Utils.Misc
-import GHC.Driver.Session
-import GHC.Driver.Ppr
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
+
 import GHC.Data.FastString
 import GHC.Data.List.SetOps
-import GHC.Types.Var (VarBndr(Bndr))
-import qualified GHC.LanguageExtensions as LangExt
 
 
 {-
@@ -668,16 +669,6 @@ data BangOpts = BangOpts
   , bang_opt_unbox_small   :: !Bool -- ^ Unbox small strict fields
   }
 
-initBangOpts :: DynFlags -> BangOpts
-initBangOpts dflags = BangOpts
-  { bang_opt_strict_data   = xopt LangExt.StrictData dflags
-  , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags
-      -- Don't unbox if we aren't optimising; rather arbitrarily,
-      -- we use -fomit-iface-pragmas as the indication
-  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags
-  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags
-  }
-
 mkDataConRep :: DataConBangOpts
              -> FamInstEnvs
              -> Name
@@ -1310,14 +1301,14 @@ wrapFamInstBody tycon args body
 -- details of the ccall, type and all.  This means that the interface
 -- file reader can reconstruct a suitable Id
 
-mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
-mkFCallId dflags uniq fcall ty
+mkFCallId :: Unique -> ForeignCall -> Type -> Id
+mkFCallId uniq fcall ty
   = assert (noFreeVarsOfType ty) $
     -- A CCallOpId should have no free type variables;
     -- when doing substitutions won't substitute over it
     mkGlobalId (FCallId fcall) name ty info
   where
-    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
+    occ_str = renderWithContext defaultSDocContext (braces (ppr fcall <+> ppr ty))
     -- The "occurrence name" of a ccall is the full info about the
     -- ccall; it is encoded, but may have embedded spaces etc!
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 8be3744846..689d291755 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -394,6 +394,7 @@ Library
         GHC.Driver.Config.CmmToLlvm
         GHC.Driver.Config.Diagnostic
         GHC.Driver.Config.Finder
+        GHC.Driver.Config.HsToCore
         GHC.Driver.Config.Logger
         GHC.Driver.Config.Parser
         GHC.Driver.Env