[commit: ghc] ghc-8.0: Have reify work for local variables with functional dependencies. (e7c12cd)
git at git.haskell.org
git at git.haskell.org
Thu Nov 17 18:11:11 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/e7c12cdaa7df8a7c71395da026c003ed36d3cbe6/ghc
>---------------------------------------------------------------
commit e7c12cdaa7df8a7c71395da026c003ed36d3cbe6
Author: Facundo DomÃnguez <facundo.dominguez at tweag.io>
Date: Thu Nov 17 10:04:13 2016 -0500
Have reify work for local variables with functional dependencies.
It turned out that finalizers were run too early and information
resulting from simplifying constraints was not available.
This patch runs finalizers after a first call to simplifyTop, and
then calls simplifyTop a second time to deal with constraints
that could result from running the finalizers.
Fixes T12777
Test Plan: ./validate
Reviewers: goldfire, simonpj, bgamari, austin
Reviewed By: simonpj
Subscribers: mpickering, mboes, thomie
Differential Revision: https://phabricator.haskell.org/D2659
GHC Trac Issues: #12777
(cherry picked from commit 231a3ae1644403c1f295e993105c4346d0db22db)
>---------------------------------------------------------------
e7c12cdaa7df8a7c71395da026c003ed36d3cbe6
compiler/typecheck/TcRnDriver.hs | 50 +++++++++++++++++-----------
compiler/typecheck/TcRnMonad.hs | 14 +++++++-
testsuite/tests/th/TH_reifyLocalDefs2.hs | 24 +++++++++++++
testsuite/tests/th/TH_reifyLocalDefs2.stderr | 1 +
testsuite/tests/th/all.T | 1 +
5 files changed, 70 insertions(+), 20 deletions(-)
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 7dd7774..25c243f 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -476,9 +476,8 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls explicit_mod_hdr decls
= do { -- Do all the declarations
- ; ((tcg_env, tcl_env), lie) <- captureConstraints $
- do { envs <- tc_rn_src_decls decls
- ; (tcg_env, tcl_env) <- setEnvs envs run_th_modfinalizers
+ ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $
+ do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
@@ -490,13 +489,6 @@ tcRnSrcDecls explicit_mod_hdr decls
; setGblEnv tcg_env $ do {
-#ifdef GHCI
- ; finishTH
-#endif /* GHCI */
-
- -- wanted constraints from static forms
- ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
-
-- Finish simplifying class constraints
--
-- simplifyTop deals with constant or ambiguous InstIds.
@@ -512,7 +504,17 @@ tcRnSrcDecls explicit_mod_hdr decls
-- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
; new_ev_binds <- {-# SCC "simplifyTop" #-}
- simplifyTop (andWC stWC lie)
+ simplifyTop lie
+
+#ifdef GHCI
+ -- Finalizers must run after constraints are simplified, or some types
+ -- might not be complete when using reify (see #12777).
+ ; (tcg_env, tcl_env) <- run_th_modfinalizers
+ ; setEnvs (tcg_env, tcl_env) $ do {
+
+ ; finishTH
+#endif /* GHCI */
+
; traceTc "Tc9" empty
; failIfErrsM -- Don't zonk if there have been errors
@@ -548,6 +550,9 @@ tcRnSrcDecls explicit_mod_hdr decls
; setGlobalTypeEnv tcg_env' final_type_env
+#ifdef GHCI
+ }
+#endif /* GHCI */
} } }
#ifdef GHCI
@@ -561,14 +566,21 @@ run_th_modfinalizers = do
then getEnvs
else do
writeTcRef th_modfinalizers_var []
- sequence_ th_modfinalizers
- -- Finalizers can add top-level declarations with addTopDecls.
- envs <- tc_rn_src_decls []
- -- addTopDecls can add declarations which add new finalizers.
- setEnvs envs run_th_modfinalizers
-#else
-run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
-run_th_modfinalizers = getEnvs
+ (envs, lie) <- captureTopConstraints $ do
+ sequence_ th_modfinalizers
+ -- Finalizers can add top-level declarations with addTopDecls.
+ tc_rn_src_decls []
+ setEnvs envs $ do
+ -- Subsequent rounds of finalizers run after any new constraints are
+ -- simplified, or some types might not be complete when using reify
+ -- (see #12777).
+ new_ev_binds <- {-# SCC "simplifyTop2" #-}
+ simplifyTop lie
+ updGblEnv (\tcg_env ->
+ tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds }
+ )
+ -- addTopDecls can add declarations which add new finalizers.
+ run_th_modfinalizers
#endif /* GHCI */
tc_rn_src_decls :: [LHsDecl RdrName]
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 278082e..f2fc28d 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -96,7 +96,7 @@ module TcRnMonad(
getConstraintVar, setConstraintVar,
emitConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, emitInsoluble,
- discardConstraints, captureConstraints,
+ discardConstraints, captureConstraints, captureTopConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
@@ -1437,6 +1437,18 @@ captureConstraints thing_inside
; failM }
Right res -> return (res, lie) }
+captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureTopConstraints m) runs m, and returns the type constraints it
+-- generates plus the constraints produced by static forms inside.
+captureTopConstraints thing_inside
+ = do { (res, lie) <- captureConstraints thing_inside ;
+ -- wanted constraints from static forms
+ ; tcg_static_wc_ref <- tcg_static_wc <$> getGblEnv
+ ; stWC <- readTcRef tcg_static_wc_ref
+ ; writeTcRef tcg_static_wc_ref emptyWC
+ ; return (res, andWC stWC lie)
+ }
+
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
= do { env <- getLclEnv
diff --git a/testsuite/tests/th/TH_reifyLocalDefs2.hs b/testsuite/tests/th/TH_reifyLocalDefs2.hs
new file mode 100644
index 0000000..06564eb
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyLocalDefs2.hs
@@ -0,0 +1,24 @@
+-- Tests that a complete type is yielded by reify for local definitions,
+-- even when using functional dependencies which are resolved at the very end of
+-- type checking.
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module TH_reifyLocalDefs2 where
+import Language.Haskell.TH as TH
+import Language.Haskell.TH.Syntax as TH
+import System.IO
+
+class C a b | a -> b where
+ yo :: a -> IO b
+
+instance C Bool Int where
+ yo _ = return 0
+
+t3 :: IO ()
+t3 = do
+ x <- yo True
+ $(do addModFinalizer $ do
+ VarI _ t _ <- TH.reify 'x
+ runIO $ hPutStrLn stderr $ show t
+ [| return () |]
+ )
diff --git a/testsuite/tests/th/TH_reifyLocalDefs2.stderr b/testsuite/tests/th/TH_reifyLocalDefs2.stderr
new file mode 100644
index 0000000..e1b28ad
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyLocalDefs2.stderr
@@ -0,0 +1 @@
+ConT GHC.Types.Int
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index bee7e43..773b360 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -76,6 +76,7 @@ test('TH_spliceD2',
test('TH_reifyDecl1', normal, compile, ['-v0'])
test('TH_reifyDecl2', normal, compile, ['-v0'])
test('TH_reifyLocalDefs', normal, compile, ['-v0'])
+test('TH_reifyLocalDefs2', normal, compile, ['-v0'])
test('TH_reifyMkName', normal, compile, ['-v0'])
More information about the ghc-commits
mailing list