summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/Config/HsToCore.hs19
-rw-r--r--compiler/GHC/HsToCore/Foreign/Call.hs9
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs5
-rw-r--r--compiler/GHC/IfaceToCore.hs3
-rw-r--r--compiler/GHC/Tc/TyCl.hs1
-rw-r--r--compiler/GHC/Types/Id/Make.hs41
-rw-r--r--compiler/ghc.cabal.in1
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
View Lorry Controller Status