| ... |
... |
@@ -1311,7 +1311,7 @@ lambda-bound variables. |
|
1311
|
1311
|
|
|
1312
|
1312
|
So our solution is this:
|
|
1313
|
1313
|
|
|
1314
|
|
-* Use straightforward applicaion in the worker-wrapper pass, creating a eta-redex.
|
|
|
1314
|
+* Use straightforward applicaion in the worker-wrapper pass, creating a beta-redex.
|
|
1315
|
1315
|
See the call to `mkApps` in GHC.Core.Opt.WorkWrap.Utils.mkWwBodies.
|
|
1316
|
1316
|
|
|
1317
|
1317
|
* Tell Lint not to complain about a join-point invocation hidden under a
|
| ... |
... |
@@ -1443,19 +1443,13 @@ lintValArg arg mult fun_ue |
|
1443
|
1443
|
|
|
1444
|
1444
|
-----------------
|
|
1445
|
1445
|
lintAltBinders :: UsageEnv
|
|
1446
|
|
- -> Var -- Case binder
|
|
|
1446
|
+ -> Var -- Case binder
|
|
1447
|
1447
|
-> Type -- Scrutinee type
|
|
1448
|
1448
|
-> Type -- Constructor type
|
|
1449
|
1449
|
-> [(Mult, OutVar)] -- Binders
|
|
1450
|
1450
|
-> LintM UsageEnv
|
|
1451
|
1451
|
-- If you edit this function, you may need to update the GHC formalism
|
|
1452
|
1452
|
-- See Note [GHC Formalism]
|
|
1453
|
|
-{-
|
|
1454
|
|
-lintAltBinders rhs_ue _case_bndr scrut_ty con_ty bndrs
|
|
1455
|
|
- = do { (res_ty, rhs_ue') <- lintApp (text ".") lintTyBndr lintValBndr con_ty bndrs
|
|
1456
|
|
- ; ensureEqTys res_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
|
|
1457
|
|
- ; return rhs_ue }
|
|
1458
|
|
--}
|
|
1459
|
1453
|
lintAltBinders rhs_ue _case_bndr scrut_ty con_ty []
|
|
1460
|
1454
|
= do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
|
|
1461
|
1455
|
; return rhs_ue }
|
| ... |
... |
@@ -2069,19 +2063,19 @@ lint_tyco_app msg fun_kind arg_tys |
|
2069
|
2063
|
; return () }
|
|
2070
|
2064
|
|
|
2071
|
2065
|
----------------
|
|
2072
|
|
-lintApp :: forall in_a acc. Outputable in_a =>
|
|
|
2066
|
+lintApp :: forall a acc. Outputable a =>
|
|
2073
|
2067
|
SDoc
|
|
2074
|
|
- -> (in_a -> LintM Type) -- Lint the thing and return its value
|
|
2075
|
|
- -> (in_a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type
|
|
|
2068
|
+ -> (a -> LintM Type) -- Lint the thing and return its value
|
|
|
2069
|
+ -> (a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type
|
|
2076
|
2070
|
-> Type
|
|
2077
|
|
- -> [in_a] -- The arguments, always "In" things
|
|
2078
|
|
- -> acc -- Used (only) for UsageEnv in /term/ applications
|
|
|
2071
|
+ -> [a] -- The arguments
|
|
|
2072
|
+ -> acc -- Used (only) for UsageEnv in /term/ applications
|
|
2079
|
2073
|
-> LintM (Type,acc)
|
|
2080
|
2074
|
-- lintApp is a performance-critical function, which deals with multiple
|
|
2081
|
2075
|
-- applications such as (/\a./\b./\c. expr) @ta @tb @tc
|
|
2082
|
2076
|
-- When returning the type of this expression we want to avoid substituting a:=ta,
|
|
2083
|
2077
|
-- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge
|
|
2084
|
|
--- perf hole. So we gather all the arguments [in_a], and then gather the
|
|
|
2078
|
+-- perf hole. So we gather all the arguments [a], and then gather the
|
|
2085
|
2079
|
-- substitution incrementally in the `go` loop.
|
|
2086
|
2080
|
--
|
|
2087
|
2081
|
-- lintApp is used:
|
| ... |
... |
@@ -2101,7 +2095,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc |
|
2101
|
2095
|
|
|
2102
|
2096
|
; let init_subst = mkEmptySubst in_scope
|
|
2103
|
2097
|
|
|
2104
|
|
- go :: Subst -> Type -> acc -> [in_a] -> LintM (Type, acc)
|
|
|
2098
|
+ go :: Subst -> Type -> acc -> [a] -> LintM (Type, acc)
|
|
2105
|
2099
|
-- The Subst applies (only) to the fun_ty
|
|
2106
|
2100
|
-- c.f. GHC.Core.Type.piResultTys, which has a similar loop
|
|
2107
|
2101
|
|
| ... |
... |
@@ -2908,10 +2902,11 @@ data LintEnv |
|
2908
|
2902
|
, le_level :: LintLevel
|
|
2909
|
2903
|
, le_in_scope :: InScopeSet
|
|
2910
|
2904
|
|
|
2911
|
|
- , le_in_vars :: VarEnv (Var, LintLevel)
|
|
2912
|
|
- -- Maps an Var (i.e. its unique) to its binding Var and level
|
|
|
2905
|
+ , le_vars :: VarEnv (Var, LintLevel)
|
|
|
2906
|
+ -- Maps a Var (i.e. its unique) to its binding Var and level
|
|
2913
|
2907
|
-- /All/ in-scope variables are here (term variables,
|
|
2914
|
2908
|
-- type variables, and coercion variables)
|
|
|
2909
|
+ -- So the domain is the same as the le_in_scope in-scope set
|
|
2915
|
2910
|
-- Used at an occurrence of the Var
|
|
2916
|
2911
|
|
|
2917
|
2912
|
, le_joins :: UniqMap Id JoinOcc
|
| ... |
... |
@@ -2922,7 +2917,6 @@ data LintEnv |
|
2922
|
2917
|
-- See Note [Linting linearity]
|
|
2923
|
2918
|
-- Assigns usage environments to the alias-like binders,
|
|
2924
|
2919
|
-- as found in non-recursive lets.
|
|
2925
|
|
- -- Domain is Ids
|
|
2926
|
2920
|
|
|
2927
|
2921
|
, le_platform :: Platform -- ^ Target platform
|
|
2928
|
2922
|
, le_diagOpts :: DiagOpts -- ^ Target platform
|
| ... |
... |
@@ -3267,7 +3261,7 @@ initL cfg m |
|
3267
|
3261
|
init_level = 0
|
|
3268
|
3262
|
env = LE { le_flags = l_flags cfg
|
|
3269
|
3263
|
, le_level = init_level
|
|
3270
|
|
- , le_in_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ]
|
|
|
3264
|
+ , le_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ]
|
|
3271
|
3265
|
, le_in_scope = mkInScopeSetList vars
|
|
3272
|
3266
|
, le_joins = emptyUniqMap
|
|
3273
|
3267
|
, le_loc = []
|
| ... |
... |
@@ -3366,9 +3360,9 @@ addInScopeId id thing_inside |
|
3366
|
3360
|
= LintM $ \ env errs ->
|
|
3367
|
3361
|
unLintM thing_inside (add env) errs
|
|
3368
|
3362
|
where
|
|
3369
|
|
- add env@(LE { le_level = level, le_in_vars = id_vars, le_joins = valid_joins
|
|
|
3363
|
+ add env@(LE { le_level = level, le_vars = id_vars, le_joins = valid_joins
|
|
3370
|
3364
|
, le_ue_aliases = aliases, le_in_scope = in_scope })
|
|
3371
|
|
- = env { le_level = level1, le_in_vars = in_vars'
|
|
|
3365
|
+ = env { le_level = level1, le_vars = in_vars'
|
|
3372
|
3366
|
, le_in_scope = in_scope `extendInScopeSet` id
|
|
3373
|
3367
|
, le_joins = valid_joins', le_ue_aliases = aliases' }
|
|
3374
|
3368
|
where
|
| ... |
... |
@@ -3388,16 +3382,16 @@ addInScopeId id thing_inside |
|
3388
|
3382
|
addInScopeTyCoVar :: TyCoVar -> LintM a -> LintM a
|
|
3389
|
3383
|
-- This function clones to avoid shadowing of TyCoVars
|
|
3390
|
3384
|
addInScopeTyCoVar tcv thing_inside
|
|
3391
|
|
- = LintM $ \ env@(LE { le_level = level, le_in_vars = in_vars
|
|
|
3385
|
+ = LintM $ \ env@(LE { le_level = level, le_vars = in_vars
|
|
3392
|
3386
|
, le_in_scope = in_scope }) errs ->
|
|
3393
|
3387
|
let level' = level + 1
|
|
3394
|
3388
|
env' = env { le_level = level'
|
|
3395
|
3389
|
, le_in_scope = in_scope `extendInScopeSet` tcv
|
|
3396
|
|
- , le_in_vars = extendVarEnv in_vars tcv (tcv, level') }
|
|
|
3390
|
+ , le_vars = extendVarEnv in_vars tcv (tcv, level') }
|
|
3397
|
3391
|
in unLintM thing_inside env' errs
|
|
3398
|
3392
|
|
|
3399
|
3393
|
getInVarEnv :: LintM (VarEnv (Id, LintLevel))
|
|
3400
|
|
-getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs))
|
|
|
3394
|
+getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_vars env), errs))
|
|
3401
|
3395
|
|
|
3402
|
3396
|
markAllJoinsBad :: LintM a -> LintM a
|
|
3403
|
3397
|
markAllJoinsBad m
|