[Git][ghc/ghc][wip/T11531] 3 commits: Fix ApplicativeDo regression #17835
Peter Trommler
gitlab at gitlab.haskell.org
Wed Mar 25 12:56:21 UTC 2020
Peter Trommler pushed to branch wip/T11531 at Glasgow Haskell Compiler / GHC
Commits:
19f12557 by Josef Svenningsson at 2020-03-23T14:05:33-04:00
Fix ApplicativeDo regression #17835
A previous fix for #15344 made sure that monadic 'fail' is used properly
when translating ApplicativeDo. However, it didn't properly account
for when a 'fail' will be inserted which resulted in some programs
failing with a type error.
- - - - -
2643ba46 by Paavo at 2020-03-24T08:31:32-04:00
Add example and doc for Arg (Fixes #17153)
- - - - -
883f5933 by Peter Trommler at 2020-03-25T13:55:17+01:00
Do not panic on linker errors
- - - - -
14 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Runtime/Linker.hs
- libraries/base/Data/Semigroup.hs
- testsuite/tests/ado/T13242a.stderr
- + testsuite/tests/ado/T17835.hs
- testsuite/tests/ado/ado001.stdout
- testsuite/tests/ado/all.T
- testsuite/tests/ghci/linking/Makefile
- + testsuite/tests/ghci/linking/T11531.c
- + testsuite/tests/ghci/linking/T11531.h
- + testsuite/tests/ghci/linking/T11531.hs
- + testsuite/tests/ghci/linking/T11531.stderr
- testsuite/tests/ghci/linking/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2274,22 +2274,31 @@ pprStmt (ApplicativeStmt _ args mb_join)
(if lengthAtLeast args 2 then parens else id) ap_expr
pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
- pp_arg (_, ApplicativeArgOne _ pat expr isBody _)
- | isBody = -- See Note [Applicative BodyStmt]
- ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+ pp_arg (_, applicativeArg) = ppr applicativeArg
+
+pprStmt (XStmtLR x) = ppr x
+
+
+instance (OutputableBndrId idL)
+ => Outputable (ApplicativeArg (GhcPass idL)) where
+ ppr = pprArg
+
+pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
+pprArg (ApplicativeArgOne _ pat expr isBody _)
+ | isBody = -- See Note [Applicative BodyStmt]
+ ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
- | otherwise =
- ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+ | otherwise =
+ ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
- pp_arg (_, ApplicativeArgMany _ stmts return pat) =
+pprArg (ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
ppr (HsDo (panic "pprStmt") DoExpr (noLoc
(stmts ++
[noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
- pp_arg (_, XApplicativeArg x) = ppr x
-pprStmt (XStmtLR x) = ppr x
+pprArg (XApplicativeArg x) = ppr x
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1498,7 +1498,7 @@ ApplicativeDo touches a few phases in the compiler:
scheduled as outlined above and transformed into applicative
combinators. However, the code is still represented as a do-block
with special forms of applicative statements. This allows us to
- recover the original do-block when e.g. printing type errors, where
+ recover the original do-block when e.g. printing type errors, where
we don't want to show any of the applicative combinators since they
don't exist in the source code.
See ApplicativeStmt and ApplicativeArg in HsExpr.
@@ -1682,7 +1682,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op
, is_body_stmt = False
, fail_operator = fail_op}]
False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
@@ -1691,7 +1691,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
- , fail_operator = fail_op}] False tail'
+ , fail_operator = noSyntaxExpr}] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
@@ -1706,7 +1706,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
let (stmts', fvss) = unzip pairs
let (need_join, tail') =
- if any hasStrictPattern trees
+ -- See Note [ApplicativeDo and refutable patterns]
+ if any hasRefutablePattern stmts'
then (True, tail)
else needJoin monad_names tail
@@ -1721,13 +1722,13 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
, is_body_stmt = False
, fail_operator = fail_op
}, emptyFVs)
- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
return (ApplicativeArgOne
{ xarg_app_arg_one = noExtField
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
- , fail_operator = fail_op
+ , fail_operator = noSyntaxExpr
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
@@ -1854,12 +1855,19 @@ isStrictPattern lpat =
SplicePat{} -> True
_otherwise -> panic "isStrictPattern"
-hasStrictPattern :: ExprStmtTree -> Bool
-hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat
-hasStrictPattern (StmtTreeOne _) = False
-hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b
-hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees
+{-
+Note [ApplicativeDo and refutable patterns]
+
+Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
+This means that sometimes an applicative block needs to be wrapped in 'join' simply because
+of a refutable pattern, in order for the types to work out.
+
+-}
+hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
+hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat
+ , is_body_stmt = False}) = not (isIrrefutableHsPat pat)
+hasRefutablePattern _ = False
isLetStmt :: LStmt a b -> Bool
isLetStmt (L _ LetStmt{}) = True
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -187,7 +187,7 @@ getHValue hsc_env name = do
m <- lookupClosure hsc_env (unpackFS sym_to_find)
case m of
Just hvref -> mkFinalizedHValue hsc_env hvref
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE"
+ Nothing -> linkFail "GHC.Runtime.Linker.getHValue"
(unpackFS sym_to_find)
linkDependencies :: HscEnv -> PersistentLinkerState
@@ -472,7 +472,7 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
return pls
- else panic "preloadLib Framework"
+ else throwGhcExceptionIO (ProgramError "preloadLib Framework")
where
dflags = hsc_dflags hsc_env
@@ -964,7 +964,9 @@ dynLoadObjs hsc_env pls at PersistentLinkerState{..} objs = do
m <- loadDLL hsc_env soFile
case m of
Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
- Just err -> panic ("Loading temp shared object failed: " ++ err)
+ Just err -> linkFail msg err
+ where
+ msg = "GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed"
rmDupLinkables :: [Linkable] -- Already loaded
-> [Linkable] -- New linkables
=====================================
libraries/base/Data/Semigroup.hs
=====================================
@@ -286,7 +286,15 @@ instance Num a => Num (Max a) where
-- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be
-- placed inside 'Min' and 'Max' to compute an arg min or arg max.
-data Arg a b = Arg a b deriving
+--
+-- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ]
+-- Arg 0 0
+data Arg a b = Arg
+ a
+ -- ^ The argument used for comparisons in 'Eq' and 'Ord'.
+ b
+ -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances.
+ deriving
( Show -- ^ @since 4.9.0.0
, Read -- ^ @since 4.9.0.0
, Data -- ^ @since 4.9.0.0
=====================================
testsuite/tests/ado/T13242a.stderr
=====================================
@@ -32,10 +32,15 @@ T13242a.hs:13:11: error:
...plus 21 others
...plus six instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
- • In the first argument of ‘return’, namely ‘(x == x)’
In a stmt of a 'do' block: return (x == x)
In the expression:
do A x <- undefined
_ <- return 'a'
_ <- return 'b'
return (x == x)
+ In an equation for ‘test’:
+ test
+ = do A x <- undefined
+ _ <- return 'a'
+ _ <- return 'b'
+ return (x == x)
=====================================
testsuite/tests/ado/T17835.hs
=====================================
@@ -0,0 +1,38 @@
+-- Build.hs
+{-# LANGUAGE ApplicativeDo #-}
+module Build (configRules) where
+
+type Action = IO
+type Rules = IO
+
+type Config = ()
+
+(%>) :: String -> (String -> Action ()) -> Rules ()
+(%>) = undefined
+
+command_ :: [String] -> String -> [String] -> Action ()
+command_ = undefined
+
+recursive :: Config -> String -> [String] -> IO (FilePath, [String])
+recursive = undefined
+
+liftIO :: IO a -> Action a
+liftIO = id
+
+need :: [String] -> Action ()
+need = undefined
+
+historyDisable :: Action ()
+historyDisable = undefined
+
+get_config :: () -> Action Config
+get_config = undefined
+
+configRules :: Rules ()
+configRules = do
+ "snapshot" %> \out -> do
+ historyDisable -- 8.10-rc1 refuses to compile without bind here
+ config <- get_config ()
+ need []
+ (exe,args) <- liftIO $ recursive config "snapshot" []
+ command_ [] exe args
=====================================
testsuite/tests/ado/ado001.stdout
=====================================
@@ -9,4 +9,4 @@ a; ((b | c) | d)
((a | (b; c)) | d) | e
((a | b); (c | d)) | e
a | b
-(a | (b; c))
+a | (b; c)
=====================================
testsuite/tests/ado/all.T
=====================================
@@ -17,3 +17,4 @@ test('T13875', normal, compile_and_run, [''])
test('T14163', normal, compile_and_run, [''])
test('T15344', normal, compile_and_run, [''])
test('T16628', normal, compile_fail, [''])
+test('T17835', normal, compile, [''])
=====================================
testsuite/tests/ghci/linking/Makefile
=====================================
@@ -127,6 +127,11 @@ T3333:
"$(TEST_HC)" -c T3333.c -o T3333.o
echo "weak_test 10" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) T3333.hs T3333.o
+.PHONY: T11531
+T11531:
+ "$(TEST_HC)" -dynamic -fPIC -c T11531.c -o T11531.o
+ - echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) T11531.o T11531.hs 2>&1 | sed -e '/undefined symbol:/d' 1>&2
+
.PHONY: T14708
T14708:
$(RM) -rf T14708scratch
=====================================
testsuite/tests/ghci/linking/T11531.c
=====================================
@@ -0,0 +1,9 @@
+extern void undefined_function(void);
+
+int some_function(int d) {
+ return 64;
+}
+
+void __attribute__ ((constructor)) setup(void) {
+ undefined_function();
+}
=====================================
testsuite/tests/ghci/linking/T11531.h
=====================================
@@ -0,0 +1,2 @@
+int some_function(int d);
+
=====================================
testsuite/tests/ghci/linking/T11531.hs
=====================================
@@ -0,0 +1,3 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+foreign import ccall "T11531.h some_function" someFunction :: Int -> Int
=====================================
testsuite/tests/ghci/linking/T11531.stderr
=====================================
@@ -0,0 +1,11 @@
+
+GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed
+During interactive linking, GHCi couldn't find the following symbol:
+This may be due to you not asking GHCi to load extra object files,
+archives or DLLs needed by your current session. Restart GHCi, specifying
+the missing library using the -L/path/to/object/dir and -lmissinglibname
+flags, or simply by naming the relevant files on the GHCi command line.
+Alternatively, this link failure might indicate a bug in GHCi.
+If you suspect the latter, please report this as a GHC bug:
+ https://www.haskell.org/ghc/reportabug
+
=====================================
testsuite/tests/ghci/linking/all.T
=====================================
@@ -43,6 +43,12 @@ test('T3333',
expect_broken(3333))],
makefile_test, ['T3333'])
+test('T11531',
+ [extra_files(['T11531.hs', 'T11531.c', 'T11531.h']),
+ unless(doing_ghci, skip),
+ unless(opsys('linux'), skip)],
+ makefile_test, ['T11531'])
+
test('T14708',
[extra_files(['T14708.hs', 'add.c']),
unless(doing_ghci, skip),
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7334c1bca3d151aed224d708e65feb9afa22fd8...883f59332c53f23a77bdbda69fa54d37a5ab708d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7334c1bca3d151aed224d708e65feb9afa22fd8...883f59332c53f23a77bdbda69fa54d37a5ab708d
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/20200325/fdb3f7ba/attachment-0001.html>
More information about the ghc-commits
mailing list