| ... |
... |
@@ -517,10 +517,10 @@ lintRecBindings top_lvl pairs thing_inside |
|
517
|
517
|
; return (a, ues) }
|
|
518
|
518
|
where
|
|
519
|
519
|
(bndrs, rhss) = unzip pairs
|
|
520
|
|
- lint_pair bndr' rhs
|
|
521
|
|
- = addLoc (RhsOf bndr') $
|
|
522
|
|
- do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs
|
|
523
|
|
- ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty
|
|
|
520
|
+ lint_pair bndr rhs
|
|
|
521
|
+ = addLoc (RhsOf bndr) $
|
|
|
522
|
+ do { (rhs_ty, ue) <- lintRhs bndr rhs -- Check the rhs
|
|
|
523
|
+ ; lintLetBind top_lvl Recursive bndr rhs rhs_ty
|
|
524
|
524
|
; return ue }
|
|
525
|
525
|
|
|
526
|
526
|
lintLetBody :: LintLocInfo -> [Id] -> CoreExpr -> LintM (Type, UsageEnv)
|
| ... |
... |
@@ -605,14 +605,17 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty |
|
605
|
605
|
|
|
606
|
606
|
_ -> return ()
|
|
607
|
607
|
|
|
608
|
|
- ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
|
|
|
608
|
+ -- Lint any RULES
|
|
|
609
|
+ ; addLoc (RuleOf binder) $
|
|
|
610
|
+ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
|
|
609
|
611
|
|
|
|
612
|
+ -- Lint the unfolding
|
|
|
613
|
+ -- Do this here, not in lintIdBinder, so that all the
|
|
|
614
|
+ -- binders of the letrec group are in scope
|
|
610
|
615
|
; addLoc (UnfoldingOf binder) $
|
|
611
|
616
|
lintIdUnfolding binder binder_ty (idUnfolding binder)
|
|
612
|
|
- ; return () }
|
|
613
|
617
|
|
|
614
|
|
- -- We should check the unfolding, if any, but this is tricky because
|
|
615
|
|
- -- the unfolding is a SimplifiableCoreExpr. Give up for now.
|
|
|
618
|
+ ; return () }
|
|
616
|
619
|
|
|
617
|
620
|
-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
|
|
618
|
621
|
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
|
| ... |
... |
@@ -669,17 +672,26 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () |
|
669
|
672
|
lintIdUnfolding bndr bndr_ty uf
|
|
670
|
673
|
| isStableUnfolding uf
|
|
671
|
674
|
, Just rhs <- maybeUnfoldingTemplate uf
|
|
672
|
|
- = noMultiplicityChecks $ -- Skip linearity checking for unfoldings
|
|
673
|
|
- -- See Note [Linting linearity]
|
|
674
|
|
- do { ty <- fst <$> (if isCompulsoryUnfolding uf
|
|
675
|
|
- then noFixedRuntimeRepChecks $ lintRhs bndr rhs
|
|
676
|
|
- -- ^^^^^^^^^^^^^^^^^^^^^^^
|
|
677
|
|
- -- See Note [Checking for representation polymorphism]
|
|
678
|
|
- else lintRhs bndr rhs)
|
|
679
|
|
- ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
|
|
680
|
|
-lintIdUnfolding _ _ _
|
|
681
|
|
- = return () -- Do not Lint unstable unfoldings, because that leads
|
|
682
|
|
- -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars
|
|
|
675
|
+ = do { -- Check the unfolding only if lf_check_stable_unfoldings is on
|
|
|
676
|
+ -- See (STL3) in Note [Substituting type-lets]
|
|
|
677
|
+ flags <- getLintFlags
|
|
|
678
|
+ ; when (lf_check_stable_unfoldings flags) $
|
|
|
679
|
+ suppress_rr_checks $
|
|
|
680
|
+ noMultiplicityChecks $ -- Skip linearity checking for unfoldings
|
|
|
681
|
+ -- See Note [Linting linearity]
|
|
|
682
|
+ do { (unf_ty, _unf_ue) <- lintRhs bndr rhs
|
|
|
683
|
+ ; ensureEqTys bndr_ty unf_ty (mkRhsMsg bndr (text "unfolding") unf_ty) } }
|
|
|
684
|
+
|
|
|
685
|
+ | otherwise
|
|
|
686
|
+ = -- Do not Lint the body of an unstable unfolding, because that leads
|
|
|
687
|
+ -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars
|
|
|
688
|
+ return ()
|
|
|
689
|
+
|
|
|
690
|
+ where
|
|
|
691
|
+ -- See Note [Checking for representation polymorphism]
|
|
|
692
|
+ suppress_rr_checks thing_inside
|
|
|
693
|
+ | isCompulsoryUnfolding uf = noFixedRuntimeRepChecks thing_inside
|
|
|
694
|
+ | otherwise = thing_inside
|
|
683
|
695
|
|
|
684
|
696
|
{- Note [Checking for INLINE loop breakers]
|
|
685
|
697
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... |
... |
@@ -893,7 +905,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body) |
|
893
|
905
|
= do { -- First Lint the RHS, before bringing the binder into scope
|
|
894
|
906
|
(rhs_ty, let_ue) <- lintRhs bndr rhs
|
|
895
|
907
|
|
|
896
|
|
- -- See Note [Multiplicity of let binders] in Var
|
|
|
908
|
+ -- See Note [Multiplicity of let binders] in Var
|
|
897
|
909
|
-- Now lint the binder
|
|
898
|
910
|
; lintBinder LetBind bndr $
|
|
899
|
911
|
do { lintLetBind NotTopLevel NonRecursive bndr rhs rhs_ty
|
| ... |
... |
@@ -1824,7 +1836,12 @@ lintIdBndr top_lvl bind_site id thing_inside |
|
1824
|
1836
|
; lintL (not (isCoVarType id_ty))
|
|
1825
|
1837
|
(text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)
|
|
1826
|
1838
|
|
|
1827
|
|
- ; lintLocalUnfolding bind_site id
|
|
|
1839
|
+ -- Check that lambda-bound Ids have no unfolding; not even OtherCon
|
|
|
1840
|
+ -- See #21496
|
|
|
1841
|
+ ; let unf = idUnfolding id
|
|
|
1842
|
+ ; checkL (not (bind_site == LambdaBind && hasSomeUnfolding unf)) $
|
|
|
1843
|
+ hang (text "Lambda binder" <+> quotes (ppr id) <+> text "has an unfolding")
|
|
|
1844
|
+ 2 (ppr unf)
|
|
1828
|
1845
|
|
|
1829
|
1846
|
; addLoc (IdTy id) (lintValueType id_ty)
|
|
1830
|
1847
|
|
| ... |
... |
@@ -1837,28 +1854,6 @@ lintIdBndr top_lvl bind_site id thing_inside |
|
1837
|
1854
|
LetBind -> True
|
|
1838
|
1855
|
_ -> False
|
|
1839
|
1856
|
|
|
1840
|
|
-lintLocalUnfolding :: BindingSite -> Id -> LintM ()
|
|
1841
|
|
-lintLocalUnfolding bind_site id
|
|
1842
|
|
- | Just unf_rhs <- maybeUnfoldingTemplate unf
|
|
1843
|
|
- , isStableUnfolding unf
|
|
1844
|
|
- = do { checkL (bind_site == LetBind) $
|
|
1845
|
|
- hang (text "Non-let-binder" <+> quotes (ppr id) <+> text "has a stable unfolding")
|
|
1846
|
|
- 2 (ppr unf)
|
|
1847
|
|
- ; flags <- getLintFlags
|
|
1848
|
|
- ; when (lf_check_stable_unfoldings flags) $
|
|
1849
|
|
- do { (unf_ty, _unf_ue) <- lintCoreExpr unf_rhs
|
|
1850
|
|
- ; ensureEqTys (idType id) unf_ty $
|
|
1851
|
|
- hang (text "Unfolding for:" <+> ppr id <+> dcolon <+> ppr (idType id))
|
|
1852
|
|
- 2 (text "has type:" <+> ppr unf_ty) } }
|
|
1853
|
|
-
|
|
1854
|
|
- | otherwise
|
|
1855
|
|
- = do { -- Check that the lambda binder has no value or OtherCon unfolding.
|
|
1856
|
|
- -- See #21496
|
|
1857
|
|
- ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))
|
|
1858
|
|
- (text "Lambda binder with value or OtherCon unfolding.") }
|
|
1859
|
|
- where
|
|
1860
|
|
- unf = idUnfolding id
|
|
1861
|
|
-
|
|
1862
|
1857
|
{-
|
|
1863
|
1858
|
%************************************************************************
|
|
1864
|
1859
|
%* *
|