summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-rw-r--r--compiler/GHC/HsToCore/Binds.hs20
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs8
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Oracle.hs5
-rw-r--r--compiler/GHC/HsToCore/Usage.hs1
4 files changed, 22 insertions, 12 deletions
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 8e54489f1e..b05162aa3c 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -42,7 +42,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( etaExpand )
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Data.Graph.Directed
import GHC.Core.Predicate
@@ -72,6 +72,7 @@ import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Driver.Ppr
+import GHC.Driver.Config
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
@@ -380,7 +381,7 @@ makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
makeCorePair dflags gbl_id is_default_method dict_arity rhs
| is_default_method -- Default methods are *always* inlined
-- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
- = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+ = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding simpl_opts rhs, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
@@ -390,20 +391,21 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
Inline -> inline_pair
where
+ simpl_opts = initSimpleOptOpts dflags
inline_prag = idInlinePragma gbl_id
- inlinable_unf = mkInlinableUnfolding dflags rhs
+ inlinable_unf = mkInlinableUnfolding simpl_opts rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
-- Add an Unfolding for an INLINE (but not for NOINLINE)
-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity
-- NB: The arity in the InlineRule takes account of the dictionaries
- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
+ = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs
, etaExpand real_arity rhs)
| otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
- (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
+ (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts rhs, rhs)
dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
@@ -704,8 +706,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf
- spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.
+ simpl_opts = initSimpleOptOpts dflags
+ spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
+ spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
@@ -863,8 +866,9 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs
| otherwise
= Left bad_shape_msg
where
+ simpl_opts = initSimpleOptOpts dflags
lhs1 = drop_dicts orig_lhs
- lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS]
+ lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS]
(fun2,args2) = collectArgs lhs2
lhs_fvs = exprFreeVars lhs2
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 2790137912..0c5d8676eb 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -27,7 +27,7 @@ import GHC.HsToCore.Monad
import GHC.Hs
import GHC.Core.DataCon
-import GHC.Core.Unfold
+import GHC.Core.Unfold.Make
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Unit.Module
@@ -53,6 +53,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Platform
import GHC.Data.OrdList
import GHC.Utils.Misc
@@ -286,8 +287,11 @@ dsFCall fn_id co fcall mDeclHeader = do
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkLams (tvs ++ args) wrapper_body
wrap_rhs' = Cast wrap_rhs co
+ simpl_opts = initSimpleOptOpts dflags
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
- (length args) wrap_rhs'
+ (length args)
+ simpl_opts
+ wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index bf21c8594b..3919b91893 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import GHC.HsToCore.PmCheck.Types
import GHC.Driver.Session
+import GHC.Driver.Config
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Misc
@@ -1667,8 +1668,8 @@ representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e
-- want to record @x ~ y@.
addCoreCt :: Delta -> Id -> CoreExpr -> MaybeT DsM Delta
addCoreCt delta x e = do
- dflags <- getDynFlags
- let e' = simpleOptExpr dflags e
+ simpl_opts <- initSimpleOptOpts <$> getDynFlags
+ let e' = simpleOptExpr simpl_opts e
lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')
execStateT (core_expr x e') delta
where
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 7fe799ebe4..b3de3cc4ce 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -20,6 +20,7 @@ import GHC.Tc.Types
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Unit
+import GHC.Unit.State
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.Unique.Set
View Lorry Controller Status