[Git][ghc/ghc][wip/runRW] 2 commits: Make Lint check return type of a join point
Simon Peyton Jones
gitlab at gitlab.haskell.org
Tue Apr 21 23:06:27 UTC 2020
Simon Peyton Jones pushed to branch wip/runRW at Glasgow Haskell Compiler / GHC
Commits:
5736297f by Simon Peyton Jones at 2020-04-22T00:06:23+01:00
Make Lint check return type of a join point
Consider
join x = rhs in body
It's important that the type of 'rhs' is the same as the type of
'body', but Lint wasn't checking that invariant.
Now it does! This was exposed by investigation into !3113.
- - - - -
cb9824a6 by Simon Peyton Jones at 2020-04-22T00:06:23+01:00
Do not float join points in exprIsConApp_maybe
We hvae been making exprIsConApp_maybe cleverer in recent times:
commit b78cc64e923716ac0512c299f42d4d0012306c05
Date: Thu Nov 15 17:14:31 2018 +0100
Make constructor wrappers inline only during the final phase
commit 7833cf407d1f608bebb1d38bb99d3035d8d735e6
Date: Thu Jan 24 17:58:50 2019 +0100
Look through newtype wrappers (Trac #16254)
commit c25b135ff5b9c69a90df0ccf51b04952c2dc6ee1
Date: Thu Feb 21 12:03:22 2019 +0000
Fix exprIsConApp_maybe
But alas there was still a bug, now immortalised in
Note [Don't float join points]
in SimpleOpt.
It's quite hard to trigger because it requires a dead
join point, but it came up when compiling Cabal
Cabal.Distribution.Fields.Lexer.hs, when working on
!3113.
Happily, the fix is extremly easy. Finding the
bug was not so easy.
- - - - -
2 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/SimpleOpt.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -461,7 +461,7 @@ lintCoreBindings dflags pass local_in_scope binds
addLoc TopLevelBindings $
do { checkL (null dups) (dupVars dups)
; checkL (null ext_dups) (dupExtVars ext_dups)
- ; lintRecBindings TopLevel all_pairs $
+ ; lintRecBindings TopLevel all_pairs $ \_ ->
return () }
where
all_pairs = flattenBinds binds
@@ -572,11 +572,11 @@ Check a core binding, returning the list of variables bound.
-}
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
- -> LintM a -> LintM a
+ -> ([LintedId] -> LintM a) -> LintM a
lintRecBindings top_lvl pairs thing_inside
= lintIdBndrs top_lvl bndrs $ \ bndrs' ->
do { zipWithM_ lint_pair bndrs' rhss
- ; thing_inside }
+ ; thing_inside bndrs' }
where
(bndrs, rhss) = unzip pairs
lint_pair bndr' rhs
@@ -584,6 +584,12 @@ lintRecBindings top_lvl pairs thing_inside
do { rhs_ty <- lintRhs bndr' rhs -- Check the rhs
; lintLetBind top_lvl Recursive bndr' rhs rhs_ty }
+lintLetBody :: [LintedId] -> CoreExpr -> LintM LintedType
+lintLetBody bndrs body
+ = do { body_ty <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ ; mapM_ (lintJoinBndrType body_ty) bndrs
+ ; return body_ty }
+
lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
-> CoreExpr -> LintedType -> LintM ()
-- Binder's type, and the RHS, have already been linted
@@ -839,7 +845,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
-- Now lint the binder
; lintBinder LetBind bndr $ \bndr' ->
do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
- ; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } }
+ ; lintLetBody [bndr'] body } }
| otherwise
= failWithL (mkLetErr bndr rhs) -- Not quite accurate
@@ -856,9 +862,8 @@ lintCoreExpr e@(Let (Rec pairs) body)
; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
mkInconsistentRecMsg bndrs
- ; lintRecBindings NotTopLevel pairs $
- addLoc (BodyOfLetRec bndrs) $
- lintCoreExpr body }
+ ; lintRecBindings NotTopLevel pairs $ \ bndrs' ->
+ lintLetBody bndrs' body }
where
bndrs = map fst pairs
@@ -972,6 +977,25 @@ checkDeadIdOcc id
= return ()
------------------
+lintJoinBndrType :: LintedType -- Type of the body
+ -> LintedId -- Possibly a join Id
+ -> LintM ()
+-- Checks that the return type of a join Id matches the body
+-- E.g. join j x = rhs in body
+-- The type of 'rhs' must be the same as the type of 'body'
+lintJoinBndrType body_ty bndr
+ | Just arity <- isJoinId_maybe bndr
+ , let bndr_ty = idType bndr
+ , (bndrs, res) <- splitPiTys bndr_ty
+ = checkL (length bndrs >= arity
+ && body_ty `eqType` mkPiTys (drop arity bndrs) res) $
+ hang (text "Join point returns different type than body")
+ 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)
+ , text "Join arity:" <+> ppr arity
+ , text "Body type:" <+> ppr body_ty ])
+ | otherwise
+ = return ()
+
checkJoinOcc :: Id -> JoinArity -> LintM ()
-- Check that if the occurrence is a JoinId, then so is the
-- binding site, and it's a valid join Id
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -949,6 +949,31 @@ exprIsConApp_maybe does not return Just) then nothing happens, and nothing
will happen the next time either.
See test T16254, which checks the behavior of newtypes.
+
+Note [Don't float join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe should succeed on
+ let v = e in Just v
+returning [x=e] as one of the [FloatBind]. But it must
+NOT succeed on
+ join j x = rhs in Just v
+because join-points can't be gaily floated. Consider
+ case (join j x = rhs in Just) of
+ K p q -> blah
+We absolutely must not "simplify" this to
+ join j x = rhs
+ in blah
+because j's return type is (Maybe t), quite different to blah's.
+
+You might think this could never happen, because j can't be
+tail-called in the body if the body returns a constructor. But
+in !3113 we had a /dead/ join point (which is not illegal),
+and its return type was wonky.
+
+The simple thing is not to float a join point. The next iteration
+of the simplifier will sort everything out. And it there is
+a join point, the chances are that the body is not a constructor
+application, so failing faster is good.
-}
data ConCont = CC [CoreExpr] Coercion
@@ -1004,6 +1029,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr
in go subst' (float:floats) body (CC args co)
go subst floats (Let (NonRec bndr rhs) expr) cont
+ | not (isJoinId bndr)
+ -- Crucial guard! See Note [Don't float join points]
= let rhs' = subst_expr subst rhs
(subst', bndr') = subst_bndr subst bndr
float = FloatLet (NonRec bndr' rhs')
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1f35320a1ee3885ff8291cac9dfeefb6b32fb06...cb9824a6d725ec932b4531641f3b23cef2b3fecb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1f35320a1ee3885ff8291cac9dfeefb6b32fb06...cb9824a6d725ec932b4531641f3b23cef2b3fecb
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/20200421/7fbb81f0/attachment-0001.html>
More information about the ghc-commits
mailing list