[Git][ghc/ghc][wip/T25029] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Aug 3 11:13:14 UTC 2024
Simon Peyton Jones pushed to branch wip/T25029 at Glasgow Haskell Compiler / GHC
Commits:
436e0c15 by Simon Peyton Jones at 2024-08-03T12:12:50+01:00
Wibbles
- - - - -
13 changed files:
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
Changes:
=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -863,20 +863,21 @@ In short, sometimes we want to specialise on these incoherently-selected diction
and sometimes we don't. It would be best to have a per-instance pragma, but for now
we have a global flag:
-* If an instance has an `{-# INCOHERENT #-}` pragma, we use its `OverlapFlag` to
- label it as either
- * `Incoherent`: meaning incoherent but still specialisable, or
- * `NonCanonical`: meaning incoherent and not specialisable.
+* If an instance has an `{-# INCOHERENT #-}` pragma, we the `OverlapFlag` of the
+ `ClsInst` to label it as either
+ * `Incoherent`: meaning incoherent but still specialisable, or
+ * `NonCanonical`: meaning incoherent and not specialisable.
+ The module-wide `-fspecialise-incoherents` flag determines which choice is made.
-The module-wide `-fspecialise-incoherents` flag determines which
-choice is made. The rest of this note describes what happens for
-`NonCanonical` instances, i.e. with `-fno-specialise-incoherents`.
+ See GHC.Tc.Utils.Instantiate.getOverlapFlag.
+
+The rest of this note describes what happens for `NonCanonical`
+instances, i.e. with `-fno-specialise-incoherents`.
To avoid this incoherence breaking the specialiser,
-* We label as "non-canonical" the dictionary constructed by a
- (potentially) incoherent use of an instance declaration whose
- `OverlapFlag` is `NonCanonical`.
+* We label as "non-canonical" the dictionary constructed by a (potentiall))
+ incoherent use of an ClsInst whose `OverlapFlag` is `NonCanonical`.
* We do not specialise a function if there is a non-canonical
dictionary in the /transistive dependencies/ of its dictionary
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -85,7 +85,7 @@ mkCmdEnv tc_meths
where
mk_bind (std_name, expr)
= do { rhs <- dsExpr expr
- ; id <- newSysLocalDs ManyTy (exprType rhs)
+ ; id <- newSysLocalMDs (exprType rhs)
-- no check needed; these are functions
; return (NonRec id rhs, (std_name, id)) }
@@ -134,18 +134,18 @@ do_premap ids b_ty c_ty d_ty f g
-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
mkFstExpr :: Type -> Type -> DsM CoreExpr
mkFstExpr a_ty b_ty = do
- a_var <- newSysLocalDs ManyTy a_ty
- b_var <- newSysLocalDs ManyTy b_ty
- pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
+ a_var <- newSysLocalMDs a_ty
+ b_var <- newSysLocalMDs b_ty
+ pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty)
return (Lam pair_var
(coreCasePair pair_var a_var b_var (Var a_var)))
-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
mkSndExpr :: Type -> Type -> DsM CoreExpr
mkSndExpr a_ty b_ty = do
- a_var <- newSysLocalDs ManyTy a_ty
- b_var <- newSysLocalDs ManyTy b_ty
- pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
+ a_var <- newSysLocalMDs a_ty
+ b_var <- newSysLocalMDs b_ty
+ pair_var <- newSysLocalMDs (mkCorePairTy a_ty b_ty)
return (Lam pair_var
(coreCasePair pair_var a_var b_var (Var b_var)))
@@ -231,9 +231,9 @@ matchEnvStack :: [Id] -- x1..xn
-> CoreExpr -- e
-> DsM CoreExpr
matchEnvStack env_ids stack_id body = do
- tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
+ tup_var <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)
match_env <- coreCaseTuple tup_var env_ids body
- pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id))
+ pair_id <- newSysLocalMDs (mkCorePairTy (idType tup_var) (idType stack_id))
return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
----------------------------------------------
@@ -249,7 +249,7 @@ matchEnv :: [Id] -- x1..xn
-> CoreExpr -- e
-> DsM CoreExpr
matchEnv env_ids body = do
- tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
+ tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)
tup_case <- coreCaseTuple tup_id env_ids body
return (Lam tup_id tup_case)
@@ -265,7 +265,7 @@ matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
matchVarStack [] stack_id body = return (stack_id, body)
matchVarStack (param_id:param_ids) stack_id body = do
(tail_id, tail_code) <- matchVarStack param_ids stack_id body
- pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id))
+ pair_id <- newSysLocalMDs (mkCorePairTy (idType param_id) (idType tail_id))
return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
@@ -343,7 +343,7 @@ dsCmd ids local_vars stack_ty res_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
core_arrow <- dsLExpr arrow
core_arg <- dsLExpr arg
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
core_make_arg <- matchEnvStack env_ids stack_id core_arg
return (do_premap ids
(envStackType env_ids stack_ty)
@@ -369,7 +369,7 @@ dsCmd ids local_vars stack_ty res_ty
core_arrow <- dsLExpr arrow
core_arg <- dsLExpr arg
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
core_make_pair <- matchEnvStack env_ids stack_id
(mkCorePairExpr core_arrow core_arg)
@@ -396,8 +396,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
stack_ty' = mkCorePairTy arg_ty stack_ty
(core_cmd, free_vars, env_ids')
<- dsfixCmd ids local_vars stack_ty' res_ty cmd
- stack_id <- newSysLocalDs ManyTy stack_ty
- arg_id <- newSysLocalDs ManyTy arg_ty
+ stack_id <- newSysLocalMDs stack_ty
+ arg_id <- newSysLocalMDs arg_ty
-- push the argument expression onto the stack
let
stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
@@ -435,7 +435,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
<- dsfixCmd ids local_vars stack_ty res_ty then_cmd
(core_else, fvs_else, else_ids)
<- dsfixCmd ids local_vars stack_ty res_ty else_cmd
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
either_con <- dsLookupTyCon eitherTyConName
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
@@ -497,7 +497,7 @@ case bodies, containing the following fields:
-}
dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
(match', core_choices)
<- dsCases ids local_vars stack_id stack_ty res_ty match
let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
@@ -546,7 +546,7 @@ dsCmd ids local_vars stack_ty res_ty
-- construct and desugar a case expression with multiple scrutinees
(core_body, free_vars, env_ids') <- trimInput \env_ids -> do
- stack_id <- newSysLocalDs ManyTy stack_ty'
+ stack_id <- newSysLocalMDs stack_ty'
(match', core_choices)
<- dsCases ids local_vars' stack_id stack_ty' res_ty match
@@ -562,8 +562,8 @@ dsCmd ids local_vars stack_ty res_ty
return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars')
- param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
- stack_id' <- newSysLocalDs ManyTy stack_ty'
+ param_ids <- newSysLocalsMDs pat_tys
+ stack_id' <- newSysLocalMDs stack_ty'
-- the expression is built from the inside out, so the actions
-- are presented in reverse order
@@ -598,7 +598,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds at binds body) env_ids = do
(core_body, _free_vars, env_ids')
<- dsfixCmd ids local_vars' stack_ty res_ty body
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
-- build a new environment, plus the stack, using the let bindings
core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
-- match the old environment and stack against the input
@@ -662,7 +662,7 @@ dsTrimCmdArg local_vars env_ids
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids')
<- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
- stack_id <- newSysLocalDs ManyTy stack_ty
+ stack_id <- newSysLocalMDs stack_ty
trim_code
<- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
let
@@ -726,8 +726,8 @@ dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do
(pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
(core_body, free_vars, env_ids')
<- dsfixCmd ids local_vars' stack_ty' res_ty body
- param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
- stack_id' <- newSysLocalDs ManyTy stack_ty'
+ param_ids <- newSysLocalsMDs pat_tys
+ stack_id' <- newSysLocalMDs stack_ty'
-- the expression is built from the inside out, so the actions
-- are presented in reverse order
@@ -852,7 +852,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
let env_ty = mkBigCoreVarTupTy env_ids
- env_var <- newSysLocalDs ManyTy env_ty
+ env_var <- newSysLocalMDs env_ty
let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
return (do_premap ids
env_ty
@@ -954,7 +954,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
-- projection function
-- \ (p, (xs2)) -> (zs)
- env_id <- newSysLocalDs ManyTy env_ty2
+ env_id <- newSysLocalMDs env_ty2
let
after_c_ty = mkCorePairTy pat_ty env_ty2
out_ty = mkBigCoreVarTupTy out_ids
@@ -964,7 +964,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
pat_id <- selectSimpleMatchVarL ManyTy pat
match_code
<- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) ManyTy pat body_expr fail_expr
- pair_id <- newSysLocalDs ManyTy after_c_ty
+ pair_id <- newSysLocalMDs after_c_ty
let
proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
@@ -1026,7 +1026,7 @@ dsCmdStmt ids local_vars out_ids
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
- env2_id <- newSysLocalDs ManyTy env2_ty
+ env2_id <- newSysLocalMDs env2_ty
let
later_ty = mkBigCoreVarTupTy later_ids
post_pair_ty = mkCorePairTy later_ty env2_ty
@@ -1113,7 +1113,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
-- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
- rec_id <- newSysLocalDs ManyTy rec_ty
+ rec_id <- newSysLocalMDs rec_ty
let
env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
env1_ids = dVarSetElems env1_id_set
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -16,7 +16,8 @@ lower levels it is preserved with @let@/@letrec at s).
module GHC.HsToCore.Binds
( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
- , dsHsWrapper, dsHsWrappers, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
+ , dsHsWrapper, dsHsWrappers
+ , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
, dsWarnOrphanRule
)
where
@@ -31,6 +32,8 @@ import GHC.Unit.Module
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
+import GHC.HsToCore.Pmc.Utils( tracePm )
+
import GHC.HsToCore.Monad
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.GuardedRHSs
@@ -51,7 +54,6 @@ import GHC.Core.Predicate
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion
-import GHC.Core.Multiplicity
import GHC.Core.Rules
import GHC.Core.TyCo.Compare( eqType )
@@ -355,7 +357,7 @@ dsAbsBinds dflags tyvars dicts exports
mkLet aux_binds $
tup_expr
- ; poly_tup_id <- newSysLocalDs ManyTy (exprType poly_tup_rhs)
+ ; poly_tup_id <- newSysLocalMDs (exprType poly_tup_rhs)
-- Find corresponding global or make up a new one: sometimes
-- we need to make new export to desugar strict binds, see
@@ -366,7 +368,7 @@ dsAbsBinds dflags tyvars dicts exports
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [ABExport wrapper] in "GHC.Hs.Binds"
- = do { tup_id <- newSysLocalDs ManyTy tup_ty
+ = do { tup_id <- newSysLocalMDs tup_ty
; dsHsWrapper wrap $ \core_wrap -> do
{ let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
mkBigTupleSelector all_locals local tup_id $
@@ -426,7 +428,7 @@ dsAbsBinds dflags tyvars dicts exports
([],[]) lcls
mk_export local =
- do global <- newSysLocalDs ManyTy
+ do global <- newSysLocalMDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE { abe_poly = global
, abe_mono = local
@@ -838,7 +840,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- perhaps with the body of the lambda wrapped in some WpLets
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
- ; dsHsWrapper spec_app $ \core_app -> do
+ ; dsHsWrapperForRuleLHS spec_app $ \core_app -> do
{ let ds_lhs = core_app (Var poly_id)
spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
@@ -865,6 +867,12 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; dsWarnOrphanRule rule
+ ; tracePm "dsSpec" (vcat
+ [ text "fun:" <+> ppr poly_id
+ , text "spec_co:" <+> ppr spec_co
+ , text "spec_bndrs:" <+> ppr spec_bndrs
+ , text "ds_lhs:" <+> ppr ds_lhs
+ , text "args:" <+> ppr rule_lhs_args ])
; return (Just (unitOL (spec_id, spec_rhs), rule))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-- makeCorePair overwrites the unfolding, which we have
@@ -1332,37 +1340,74 @@ inter-evidence dependency analysis to generate well-scoped
bindings. We then record this specialisability information in the
dsl_unspecables field of DsM's local environment.
+Wrinkle:
+
+(NC1) Don't do this in the LHS of a RULE. In paritcular, if we have
+ f :: (Num a, HasCallStack) => a -> a
+ {-# SPECIALISE f :: Int -> Int #-}
+ then making a rule like
+ RULE forall d1:Num Int, d2:HasCallStack.
+ f @Int d1 d2 = $sf
+ is pretty dodgy, because $sf won't get the call stack passed in d2.
+ But that's what you asked for in the SPECIALISE pragma, so we'll obey.
+
+ We definitely can't desugar that LHS into this!
+ nospec (f @Int d1) d2
+
+ Hence the `is_rule_lhs` flag in `ds_hs_wrapper`.
-}
+dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
+dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)
+dsHsWrappers [] k = k []
+
dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
-dsHsWrapper WpHole k = k $ \e -> e
-dsHsWrapper (WpTyApp ty) k = k $ \e -> App e (Type ty)
-dsHsWrapper (WpEvLam ev) k = k $ Lam ev
-dsHsWrapper (WpTyLam tv) k = k $ Lam tv
-dsHsWrapper (WpLet ev_binds) k = do { dsTcEvBinds ev_binds $ \bs -> do
- { k (mkCoreLets bs) } }
-dsHsWrapper (WpCompose c1 c2) k = do { dsHsWrapper c1 $ \w1 -> do
- { dsHsWrapper c2 $ \w2 -> do
- { k (w1 . w2) } } }
-dsHsWrapper (WpFun c1 c2 (Scaled w t1)) k -- See Note [Desugaring WpFun]
- = do { x <- newSysLocalDs w t1
- ; dsHsWrapper c1 $ \w1 -> do
- { dsHsWrapper c2 $ \w2 -> do
- { let app f a = mkCoreAppDs (text "dsHsWrapper") f a
- arg = w1 (Var x)
- ; k (\e -> (Lam x (w2 (app e arg)))) } } }
-dsHsWrapper (WpCast co) k = assert (coercionRole co == Representational) $
- k $ \e -> mkCastDs e co
-dsHsWrapper (WpEvApp tm) k = do { core_tm <- dsEvTerm tm
- ; unspecables <- getUnspecables
- ; let vs = exprFreeVarsList core_tm
- is_unspecable_var v = v `S.member` unspecables
- is_specable = not $ any (is_unspecable_var) vs -- See Note [Desugaring non-canonical evidence]
- ; k (\e -> app_ev is_specable e core_tm) }
+dsHsWrapper = ds_hs_wrapper False
+
+dsHsWrapperForRuleLHS :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
+dsHsWrapperForRuleLHS = ds_hs_wrapper True
+
+ds_hs_wrapper :: Bool -- True <=> LHS of a RULE
+ -- See (NC1) in Note [Desugaring non-canonical evidence]
+ -> HsWrapper
+ -> ((CoreExpr -> CoreExpr) -> DsM a)
+ -> DsM a
+ds_hs_wrapper is_rule_lhs wrap = go wrap
+ where
+ go WpHole k = k $ \e -> e
+ go (WpTyApp ty) k = k $ \e -> App e (Type ty)
+ go (WpEvLam ev) k = k $ Lam ev
+ go (WpTyLam tv) k = k $ Lam tv
+ go (WpCast co) k = assert (coercionRole co == Representational) $
+ k $ \e -> mkCastDs e co
+ go (WpLet ev_binds) k = dsTcEvBinds ev_binds $ \bs ->
+ k (mkCoreLets bs)
+ go (WpCompose c1 c2) k = go c1 $ \w1 ->
+ go c2 $ \w2 ->
+ k (w1 . w2)
+ go (WpFun c1 c2 st) k = -- See Note [Desugaring WpFun]
+ do { x <- newSysLocalDs st
+ ; go c1 $ \w1 ->
+ go c2 $ \w2 ->
+ let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+ arg = w1 (Var x)
+ in k (\e -> (Lam x (w2 (app e arg)))) }
+ go (WpEvApp tm) k = do { core_tm <- dsEvTerm tm
+
+ -- See Note [Desugaring non-canonical evidence]
+ ; unspecables <- getUnspecables
+ ; let vs = exprFreeVarsList core_tm
+ is_unspecable_var v = v `S.member` unspecables
+ is_specable
+ | is_rule_lhs = True
+ | otherwise = not $ any (is_unspecable_var) vs
+
+ ; k (\e -> app_ev is_specable e core_tm) }
+
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-dsHsWrapper (WpMultCoercion co) k = do { unless (isReflexiveCo co) $
- diagnosticDs DsMultiplicityCoercionsNotSupported
- ; k $ \e -> e }
+ go (WpMultCoercion co) k = do { unless (isReflexiveCo co) $
+ diagnosticDs DsMultiplicityCoercionsNotSupported
+ ; k $ \e -> e }
-- We are about to construct an evidence application `f dict`. If the dictionary is
-- non-specialisable, instead construct
@@ -1376,10 +1421,6 @@ app_ev is_specable k core_tm
| otherwise
= k `App` core_tm
-dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
-dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)
-dsHsWrappers [] k = k []
-
--------------------------------------
dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s [] k = k []
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -423,10 +423,10 @@ converting to core it must become a CO.
-}
dsExpr (ExplicitTuple _ tup_args boxity)
- = do { let go (lam_vars, args) (Missing (Scaled mult ty))
+ = do { let go (lam_vars, args) (Missing st)
-- For every missing expression, we need
-- another lambda in the desugaring.
- = do { lam_var <- newSysLocalDs mult ty
+ = do { lam_var <- newSysLocalDs st
; return (lam_var : lam_vars, Var lam_var : args) }
go (lam_vars, args) (Present _ expr)
-- Expressions that are present don't generate
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -175,14 +175,14 @@ dsCFExportDynamic id co0 cconv = do
(moduleStableString mod ++ "$" ++ toCName id)
-- Construct the label based on the passed id, don't use names
-- depending on Unique. See #13807 and Note [Unique Determinism].
- cback <- newSysLocalDs arg_mult arg_ty
+ cback <- newSysLocalDs scaled_arg_ty
newStablePtrId <- dsLookupGlobalId newStablePtrName
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
- stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
+ stbl_value <- newSysLocalMDs stable_ptr_ty
(h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
@@ -219,10 +219,11 @@ dsCFExportDynamic id co0 cconv = do
return ([fed], h_code, c_code)
where
- ty = coercionLKind co0
- (tvs,sans_foralls) = tcSplitForAllInvisTyVars ty
- ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
- Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
+ ty = coercionLKind co0
+ (tvs,sans_foralls) = tcSplitForAllInvisTyVars ty
+ ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
+ arg_ty = scaledThing scaled_arg_ty
+ Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
-- Must have an IO type; hence Just
=====================================
compiler/GHC/HsToCore/Foreign/Call.hs
=====================================
@@ -152,7 +152,7 @@ unboxArg arg
tc `hasKey` boolTyConKey
= do dflags <- getDynFlags
let platform = targetPlatform dflags
- prim_arg <- newSysLocalDs ManyTy intPrimTy
+ prim_arg <- newSysLocalMDs intPrimTy
return (Var prim_arg,
\ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
prim_arg
@@ -164,8 +164,8 @@ unboxArg arg
| is_product_type && data_con_arity == 1
= assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $
-- Typechecker ensures this
- do case_bndr <- newSysLocalDs ManyTy arg_ty
- prim_arg <- newSysLocalDs ManyTy data_con_arg_ty1
+ do case_bndr <- newSysLocalMDs arg_ty
+ prim_arg <- newSysLocalMDs data_con_arg_ty1
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
)
@@ -179,7 +179,7 @@ unboxArg arg
Just arg3_tycon <- maybe_arg3_tycon,
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
- = do case_bndr <- newSysLocalDs ManyTy arg_ty
+ = do case_bndr <- newSysLocalMDs arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
@@ -228,7 +228,7 @@ boxResult result_ty
; (ccall_res_ty, the_alt) <- mk_alt return_result res
- ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ ; state_id <- newSysLocalMDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
@@ -264,7 +264,7 @@ mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-> DsM (Type, CoreAlt)
mk_alt return_result (Nothing, wrap_result)
= do -- The ccall returns ()
- state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ state_id <- newSysLocalMDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (panic "boxResult"))
@@ -278,8 +278,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
= -- The ccall returns a non-() value
assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $
-- True because resultWrapper ensures it is so
- do { result_id <- newSysLocalDs ManyTy prim_res_ty
- ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ do { result_id <- newSysLocalMDs prim_res_ty
+ ; state_id <- newSysLocalMDs realWorldStatePrimTy
; let the_rhs = return_result (Var state_id)
(wrap_result (Var result_id))
ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -263,7 +263,8 @@ dsJsFExportDynamic id co0 cconv = do
let
ty = coercionLKind co0
(tvs,sans_foralls) = tcSplitForAllTyVars ty
- ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
+ ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
+ arg_ty = scaledThing scaled_arg_ty
(io_tc, res_ty) = expectJust "dsJsFExportDynamic: IO type expected"
-- Must have an IO type; hence Just
$ tcSplitIOType_maybe fn_res_ty
@@ -272,14 +273,14 @@ dsJsFExportDynamic id co0 cconv = do
("h$" ++ moduleStableString mod ++ "$" ++ toJsName id)
-- Construct the label based on the passed id, don't use names
-- depending on Unique. See #13807 and Note [Unique Determinism].
- cback <- newSysLocalDs arg_mult arg_ty
+ cback <- newSysLocalDs scaled_arg_ty
newStablePtrId <- dsLookupGlobalId newStablePtrName
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
- stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
+ stbl_value <- newSysLocalMDs stable_ptr_ty
(h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
{-
@@ -414,8 +415,8 @@ unboxJsArg arg
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
- = do case_bndr <- newSysLocalDs ManyTy arg_ty
- prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)
+ = do case_bndr <- newSysLocalMDs arg_ty
+ prim_arg <- newSysLocalMDs (scaledThing data_con_arg_ty1)
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
)
@@ -429,7 +430,7 @@ unboxJsArg arg
Just arg3_tycon <- maybe_arg3_tycon,
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
- = do case_bndr <- newSysLocalDs ManyTy arg_ty
+ = do case_bndr <- newSysLocalMDs arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
@@ -476,7 +477,7 @@ boxJsResult result_ty
; (ccall_res_ty, the_alt) <- mk_alt return_result res
- ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ ; state_id <- newSysLocalMDs realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
@@ -511,7 +512,7 @@ mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-> DsM (Type, CoreAlt)
mk_alt return_result (Nothing, wrap_result)
= do -- The ccall returns ()
- state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ state_id <- newSysLocalMDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result $ panic "jsBoxResult")
@@ -525,8 +526,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
let
ls = dropRuntimeRepArgs (tyConAppArgs prim_res_ty)
arity = 1 + length ls
- args_ids <- mapM (newSysLocalDs ManyTy) ls
- state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ args_ids <- newSysLocalsMDs ls
+ state_id <- newSysLocalMDs realWorldStatePrimTy
let
result_tup = mkCoreUnboxedTuple (map Var args_ids)
the_rhs = return_result (Var state_id)
@@ -538,8 +539,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
return (ccall_res_ty, the_alt)
| otherwise = do
- result_id <- newSysLocalDs ManyTy prim_res_ty
- state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ result_id <- newSysLocalMDs prim_res_ty
+ state_id <- newSysLocalMDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id))
@@ -561,7 +562,7 @@ jsResultWrapper result_ty
, isUnboxedTupleTyCon tc {- && False -} = do
let args' = dropRuntimeRepArgs args
(tys, wrappers) <- unzip <$> mapM jsResultWrapper args'
- matched <- mapM (mapM (newSysLocalDs ManyTy)) tys
+ matched <- mapM (mapM newSysLocalMDs) tys
let tys' = catMaybes tys
-- arity = length args'
-- resCon = tupleDataCon Unboxed (length args)
@@ -590,7 +591,7 @@ jsResultWrapper result_ty
, isBoxedTupleTyCon tc = do
let innerTy = mkTupleTy Unboxed args
(inner_res, w) <- jsResultWrapper innerTy
- matched <- mapM (newSysLocalDs ManyTy) args
+ matched <- newSysLocalsMDs args
let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty
[ Alt (DataAlt (tupleDataCon Unboxed (length args)))
matched
=====================================
compiler/GHC/HsToCore/Foreign/Wasm.hs
=====================================
@@ -113,7 +113,7 @@ dsWasmJSDynamicExport fn_id co mUnitId = do
([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty
sp_ty = mkTyConApp sp_tycon [arg_ty]
(real_arg_tys, _) = tcSplitFunTys arg_ty
- sp_id <- newSysLocalDs ManyTy sp_ty
+ sp_id <- newSysLocalMDs sp_ty
work_uniq <- newUnique
work_export_name <- uniqueCFunName
deRefStablePtr_id <- lookupGhcInternalVarId "GHC.Internal.Stable" "deRefStablePtr"
@@ -315,7 +315,7 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do
jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"
bindIO_id <- dsLookupGlobalId bindIOName
returnIO_id <- dsLookupGlobalId returnIOName
- promise_id <- newSysLocalDs ManyTy jsval_ty
+ promise_id <- newSysLocalMDs jsval_ty
blockPromise_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" "stg_blockPromise"
msgPromise_id <-
lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty
@@ -388,8 +388,8 @@ importBindingRHS mUnitId safety cfun_name tvs arg_tys orig_res_ty res_trans =
-- res_wrapper: turn the_call to (IO a) or a
(ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of
Just (io_tycon, res_ty) -> do
- s0_id <- newSysLocalDs ManyTy realWorldStatePrimTy
- s1_id <- newSysLocalDs ManyTy realWorldStatePrimTy
+ s0_id <- newSysLocalMDs realWorldStatePrimTy
+ s1_id <- newSysLocalMDs realWorldStatePrimTy
let io_data_con = tyConSingleDataCon io_tycon
toIOCon = dataConWorkId io_data_con
(ccall_res_ty, wrap)
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -365,8 +365,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do
let b_ty = idType n_id
-- create some new local id's
- b <- newSysLocalDs ManyTy b_ty
- x <- newSysLocalDs ManyTy x_ty
+ b <- newSysLocalMDs b_ty
+ x <- newSysLocalMDs x_ty
-- build rest of the comprehension
core_rest <- dfListComp c_id b quals
@@ -396,11 +396,11 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr)
-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
mkZipBind elt_tys = do
- ass <- mapM (newSysLocalDs ManyTy) elt_list_tys
- as' <- mapM (newSysLocalDs ManyTy) elt_tys
- as's <- mapM (newSysLocalDs ManyTy) elt_list_tys
+ ass <- newSysLocalsMDs elt_list_tys
+ as' <- newSysLocalsMDs elt_tys
+ as's <- newSysLocalsMDs elt_list_tys
- zip_fn <- newSysLocalDs ManyTy zip_fn_ty
+ zip_fn <- newSysLocalMDs zip_fn_ty
let inner_rhs = mkConsExpr elt_tuple_ty
(mkBigCoreVarTup as')
@@ -435,13 +435,13 @@ mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
mkUnzipBind ThenForm _
= return Nothing -- No unzipping for ThenForm
mkUnzipBind _ elt_tys
- = do { ax <- newSysLocalDs ManyTy elt_tuple_ty
- ; axs <- newSysLocalDs ManyTy elt_list_tuple_ty
- ; ys <- newSysLocalDs ManyTy elt_tuple_list_ty
- ; xs <- mapM (newSysLocalDs ManyTy) elt_tys
- ; xss <- mapM (newSysLocalDs ManyTy) elt_list_tys
+ = do { ax <- newSysLocalMDs elt_tuple_ty
+ ; axs <- newSysLocalMDs elt_list_tuple_ty
+ ; ys <- newSysLocalMDs elt_tuple_list_ty
+ ; xs <- newSysLocalsMDs elt_tys
+ ; xss <- newSysLocalsMDs elt_list_tys
- ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty
+ ; unzip_fn <- newSysLocalMDs unzip_fn_ty
; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
@@ -541,7 +541,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
-- Build a pattern that ensures the consumer binds into the NEW binders,
-- which hold monads rather than single values
; body <- dsMcStmts stmts_rest
- ; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty'
+ ; n_tup_var' <- newSysLocalMDs n_tup_ty'
; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
; let rhs' = mkApps usingExpr' usingArgs'
; body' <- mkBigTupleCase to_bndrs body tup_n_expr'
@@ -588,7 +588,7 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
-- returns the Core term
-- \x. case x of (a,b,c) -> body
matchTuple ids body
- = do { tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)
+ = do { tup_id <- newSysLocalMDs (mkBigCoreVarTupTy ids)
; tup_case <- mkBigTupleCase ids body (Var tup_id)
; return (Lam tup_id tup_case) }
@@ -646,9 +646,9 @@ mkMcUnzipM ThenForm _ ys _
mkMcUnzipM _ fmap_op ys elt_tys
= do { fmap_op' <- dsExpr fmap_op
- ; xs <- mapM (newSysLocalDs ManyTy) elt_tys
+ ; xs <- newSysLocalsMDs elt_tys
; let tup_ty = mkBigCoreTupTy elt_tys
- ; tup_xs <- newSysLocalDs ManyTy tup_ty
+ ; tup_xs <- newSysLocalMDs tup_ty
; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
[ Type tup_ty, Type (getNth elt_tys i)
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -19,9 +19,9 @@ module GHC.HsToCore.Monad (
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
Applicative(..),(<$>),
- duplicateLocalDs, newSysLocalDs,
- newSysLocalsDs, newUniqueId,
- newFailLocalDs, newPredVarDs,
+ duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
+ newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
+ newUniqueId, newPredVarDs,
getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
mkNamePprCtxDs,
newUnique,
@@ -438,12 +438,19 @@ newPredVarDs :: PredType -> DsM Var
newPredVarDs
= mkSysLocalOrCoVarM (fsLit "ds") ManyTy -- like newSysLocalDs, but we allow covars
-newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
-newSysLocalDs = mkSysLocalM (fsLit "ds")
-newFailLocalDs = mkSysLocalM (fsLit "fail")
+newSysLocalMDs, newFailLocalMDs :: Type -> DsM Id
+-- Implicitly have ManyTy multiplicity, hence the "M"
+newSysLocalMDs = mkSysLocalM (fsLit "ds") ManyTy
+newFailLocalMDs = mkSysLocalM (fsLit "fail") ManyTy
+
+newSysLocalsMDs :: [Type] -> DsM [Id]
+newSysLocalsMDs = mapM newSysLocalMDs
+
+newSysLocalDs :: Scaled Type -> DsM Id
+newSysLocalDs (Scaled w t) = mkSysLocalM (fsLit "ds") w t
newSysLocalsDs :: [Scaled Type] -> DsM [Id]
-newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
+newSysLocalsDs = mapM newSysLocalDs
{-
We can also reach out and either set/grab location information from
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.Type
import GHC.Core.Coercion
+import GHC.Core.TyCo.Rep( Scaled(..) )
import GHC.Builtin.Types
import GHC.Core.ConLike
import GHC.Types.Unique.Set
@@ -141,7 +142,7 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var))
-- itself. It's easier to pull it from the
-- variable, so we ignore the multiplicity.
selectMatchVar _w (AsPat _ var _) = assert (isManyTy _w ) (return (localiseId (unLoc var)))
-selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat)
+selectMatchVar w other_pat = newSysLocalDs (Scaled w (hsPatType other_pat))
{- Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -749,7 +750,7 @@ mkSelectorBinds ticks pat ctx val_expr
| is_flat_prod_lpat pat' -- Special case (B)
= do { let pat_ty = hsLPatType pat'
- ; val_var <- newSysLocalDs ManyTy pat_ty
+ ; val_var <- newSysLocalMDs pat_ty
; let mk_bind tick bndr_var
-- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
@@ -767,7 +768,7 @@ mkSelectorBinds ticks pat ctx val_expr
; return ( val_var, (val_var, val_expr) : binds) }
| otherwise -- General case (C)
- = do { tuple_var <- newSysLocalDs ManyTy tuple_ty
+ = do { tuple_var <- newSysLocalMDs tuple_ty
; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
; tuple_expr <- matchSimply val_expr ctx ManyTy pat
local_tuple error_expr
@@ -924,8 +925,8 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression
CoreExpr) -- Fail variable applied to (# #)
-- See Note [Failure thunks and CPR]
mkFailurePair expr
- = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty)
- ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy
+ = do { fail_fun_var <- newFailLocalMDs (unboxedUnitTy `mkVisFunTyMany` ty)
+ ; fail_fun_arg <- newSysLocalMDs unboxedUnitTy
; let real_arg = setOneShotLambda fail_fun_arg
; return (NonRec fail_fun_var (Lam real_arg expr),
App (Var fail_fun_var) unboxedUnitExpr) }
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -507,10 +507,12 @@ simplifyTopWanteds wanteds
tryDefaulting :: WantedConstraints -> TcS WantedConstraints
tryDefaulting wc
= do { dflags <- getDynFlags
+ ; traceTcS "tryDefaulting:before" (ppr wc)
; wc1 <- tryTyVarDefaulting dflags wc
; wc2 <- tryConstraintDefaulting wc1
; wc3 <- tryTypeClassDefaulting wc2
; wc4 <- tryUnsatisfiableGivens wc3
+ ; traceTcS "tryDefaulting:after" (ppr wc)
; return wc4 }
solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -935,43 +935,51 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
************************************************************************
-}
-getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+getOverlapFlag :: Maybe OverlapMode -- User pragma if any
+ -> TcM OverlapFlag
-- Construct the OverlapFlag from the global module flags,
-- but if the overlap_mode argument is (Just m),
-- set the OverlapMode to 'm'
-getOverlapFlag overlap_mode
+--
+-- The overlap_mode argument comes from a user pragma on the instance decl:
+-- Pragma overlap_mode_prag
+-- -----------------------------------------
+-- {-# OVERLAPPABLE #-} Overlappable
+-- {-# OVERLAPPING #-} Overlapping
+-- {-# OVERLAPS #-} Overlaps
+-- {-# INCOHERENT #-} Incoherent
+
+getOverlapFlag overlap_mode_prag
= do { dflags <- getDynFlags
; let overlap_ok = xopt LangExt.OverlappingInstances dflags
incoherent_ok = xopt LangExt.IncoherentInstances dflags
noncanonical_incoherence = not $ gopt Opt_SpecialiseIncoherents dflags
- use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
- , overlapMode = x }
- default_oflag | incoherent_ok = use (Incoherent NoSourceText)
- | overlap_ok = use (Overlaps NoSourceText)
- | otherwise = use (NoOverlap NoSourceText)
+ overlap_mode
+ | Just m <- overlap_mode_prag = m
+ | incoherent_ok = Incoherent NoSourceText
+ | overlap_ok = Overlaps NoSourceText
+ | otherwise = NoOverlap NoSourceText
- oflag = setOverlapModeMaybe default_oflag overlap_mode
- final_oflag = effective_oflag noncanonical_incoherence oflag
- ; return final_oflag }
- where
- effective_oflag noncanonical_incoherence oflag at OverlapFlag{ overlapMode = overlap_mode }
- = oflag { overlapMode = effective_overlap_mode noncanonical_incoherence overlap_mode }
+ -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the
+ -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap
+ -- flag, or a NonCanonical overlap flag.
+ -- See GHC.Core.InstEnv Note [Coherence and specialisation: overview]
+ final_overlap_mode
+ | Incoherent s <- overlap_mode
+ , noncanonical_incoherence = NonCanonical s
+ | otherwise = overlap_mode
- -- The `-fspecialise-incoherents` flag controls the meaning of the
- -- `Incoherent` overlap mode: as either an Incoherent overlap
- -- flag, or a NonCanonical overlap flag. See Note [Coherence and specialisation: overview]
- -- in GHC.Core.InstEnv for why we care about this distinction.
- effective_overlap_mode noncanonical_incoherence = \case
- Incoherent s | noncanonical_incoherence -> NonCanonical s
- overlap_mode -> overlap_mode
+ ; return (OverlapFlag { isSafeOverlap = safeLanguageOn dflags
+ , overlapMode = final_overlap_mode }) }
tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv
-newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
+newClsInst :: Maybe OverlapMode -- User pragma
+ -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys warn
= do { (subst, tvs') <- freshenTyVarBndrs tvs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436e0c1521e6813570037de0272ec2b71fdd2b57
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436e0c1521e6813570037de0272ec2b71fdd2b57
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240803/a5dc68c7/attachment-0001.html>
More information about the ghc-commits
mailing list