[Git][ghc/ghc][wip/T17923] Progress

[Simon Peyton Jones]

Simon Peyton Jones pushed to branch wip/T17923 at Glasgow Haskell Compiler / GHC


Commits:
95ecfa58 by Simon Peyton Jones at 2020-03-18T08:22:44Z
Progress

- - - - -


1 changed file:

- compiler/GHC/Core/Lint.hs


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -575,28 +575,23 @@ lintExpr dflags vars expr
 Check a core binding, returning the list of variables bound.
 -}
 
-lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
+lintRecBinding :: TopLevelFlag -> RecFlag -> (LintedId, CoreExpr) -> LintM ()
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
+lintRecBinding top_lvl_flag rec_flag (binder,rhs)
   = addLoc (RhsOf binder) $
-         -- Check the rhs
-    do { ty <- lintRhs binder rhs
-       ; binder_ty <- applySubstTy (idType binder)
-       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
+    do { rhs_ty <- lintRhs binder rhs         -- Check the rhs
+       ; lintLetBinder top_lvl rec_flag binder rhs_ty }
+
+lintRecBinding :: TopLevelFlag -> RecFlag -> LintedId -> LintedType -> LintM ()
+lintLetBinder top_lvl rec_flag binder rhs_ty
+  = do { ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)
 
        -- If the binding is for a CoVar, the RHS should be (Coercion co)
        -- See Note [Core type and coercion invariant] in GHC.Core
        ; checkL (not (isCoVar binder) || isCoArg rhs)
                 (mkLetErr binder rhs)
 
-       -- Check that it's not levity-polymorphic
-       -- Do this first, because otherwise isUnliftedType panics
-       -- Annoyingly, this duplicates the test in lintIdBdr,
-       -- because for non-rec lets we call lintSingleBinding first
-       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
-                (badBndrTyMsg binder (text "levity-polymorphic"))
-
         -- Check the let/app invariant
         -- See Note [Core let/app invariant] in GHC.Core
        ; checkL ( isJoinId binder
@@ -822,11 +817,12 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
 
 lintCoreExpr (Let (NonRec bndr rhs) body)
   | isId bndr
-  = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
-        ; addLoc (BodyOfLetRec [bndr])
-                 (lintBinder LetBind bndr $ \_ ->
-                  addGoodJoins [bndr] $
-                  lintCoreExpr body) }
+  = do { rhs_ty <- lintCoreExpr rhs
+       ; lintBinder LetBind bndr $ \bndr' ->
+    do { lintLetBinder NotTopLevel NonRecursive bndr' rhs_ty
+       ; addLoc (BodyOfLetRec [bndr]) $
+         addGoodJoins [bndr] $
+         lintCoreExpr body } }
 
   | otherwise
   = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
@@ -1138,10 +1134,10 @@ lintCaseExpr scrut var alt_ty alts =
           -- See Note [Join points are less general than the paper]
           -- in GHC.Core
 
-     ; (alt_ty, _) <- addLoc (CaseTy scrut) $
-                      lintValueType alt_ty
-     ; (var_ty, _) <- addLoc (IdTy var) $
-                      lintValueType (idType var)
+     ; alt_ty <- addLoc (CaseTy scrut) $
+                 lintValueType alt_ty
+     ; var_ty <- addLoc (IdTy var) $
+                 lintValueType (idType var)
 
      -- We used to try to check whether a case expression with no
      -- alternatives was legitimate, but this didn't work.
@@ -1333,14 +1329,15 @@ lintIdBndr top_lvl bind_site id linterF
        ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
            (mkNonTopExternalNameMsg id)
 
-       ; (id_ty, k) <- addLoc (IdTy id) $
-                       lintValueType (idType id)
+       ; id_ty <- addLoc (IdTy id) $
+                  lintValueType (idType id)
        ; let id' = setIdType id id_ty
 
           -- See Note [Levity polymorphism invariants] in GHC.Core
-       ; lintL (isJoinId id || not (lf_check_levity_poly flags) || not (isKindLevPoly k))
-           (text "Levity-polymorphic binder:" <+>
-                 (ppr id <+> dcolon <+> parens (ppr id_ty <+> dcolon <+> ppr k)))
+       ; lintL (isJoinId id || not (lf_check_levity_poly flags)
+                || not (isTypeLevPoly id_ty)) $
+         text "Levity-polymorphic binder:" <+> ppr id <+> dcolon <+>
+            parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)
 
        -- Check that a join-id is a not-top-level let-binding
        ; when (isJoinId id) $
@@ -2404,9 +2401,6 @@ getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
 getInScope :: LintM InScopeSet
 getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
 
-applySubstTy :: InType -> LintM OutType
-applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
-
 lookupIdInScope :: Id -> LintM Id
 lookupIdInScope id_occ
   = do { in_scope_ids <- getInScopeIds



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/95ecfa58c2b106c5521a4f3738bc7a4b0ca02857

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/95ecfa58c2b106c5521a4f3738bc7a4b0ca02857
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/20200318/97fefcb8/attachment-0001.html>