[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure
Marge Bot
gitlab at gitlab.haskell.org
Fri Aug 7 22:38:12 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3907ee01 by Cale Gibbard at 2020-08-07T08:34:46-04:00
A fix to an error message in monad comprehensions, and a move of dsHandleMonadicFailure
as suggested by comments on !2330.
- - - - -
fa9bb70a by Cale Gibbard at 2020-08-07T08:34:46-04:00
Add some tests for fail messages in do-expressions and monad-comprehensions.
- - - - -
5f036063 by Ben Gamari at 2020-08-07T08:35:21-04:00
cmm: Clean up Notes a bit
- - - - -
6402c124 by Ben Gamari at 2020-08-07T08:35:21-04:00
CmmLint: Check foreign call argument register invariant
As mentioned in Note [Register parameter passing] the arguments of
foreign calls cannot refer to caller-saved registers.
- - - - -
15b36de0 by Ben Gamari at 2020-08-07T08:35:21-04:00
nativeGen: One approach to fix #18527
Previously the code generator could produce corrupt C call sequences due
to register overlap between MachOp lowerings and the platform's calling
convention. We fix this using a hack described in Note [Evaluate C-call
arguments before placing in destination registers].
- - - - -
3847ae0c by Ben Gamari at 2020-08-07T08:35:21-04:00
testsuite: Add test for #18527
- - - - -
dd51d53b by Ben Gamari at 2020-08-07T08:35:21-04:00
testsuite: Fix prog001
Previously it failed as the `ghc` package was not visible.
- - - - -
649f9104 by Alan Zimmerman at 2020-08-07T18:38:06-04:00
ApiAnnotations; tweaks for ghc-exactprint update
Remove unused ApiAnns, add one for linear arrow.
Include API Annotations for trailing comma in export list.
- - - - -
15932b2a by Ben Gamari at 2020-08-07T18:38:06-04:00
configure: Fix double-negation in ld merge-objects check
We want to only run the check if ld is gold.
Fixes the fix to #17962.
- - - - -
27 changed files:
- aclocal.m4
- compiler/GHC.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Expr.hs-boot
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Utils.hs
- includes/stg/MachRegs.h
- + testsuite/tests/codeGen/should_run/T18527.hs
- + testsuite/tests/codeGen/should_run/T18527.stdout
- + testsuite/tests/codeGen/should_run/T18527FFI.c
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/concurrent/prog001/all.T
- + testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
- + testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
- + testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
- + testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
- testsuite/tests/deSugar/should_run/all.T
- utils/check-api-annotations/Main.hs
Changes:
=====================================
aclocal.m4
=====================================
@@ -2543,7 +2543,7 @@ AC_DEFUN([FIND_LD],[
# Sets $result to 0 if not affected, 1 otherwise
AC_DEFUN([CHECK_FOR_GOLD_T22266],[
AC_MSG_CHECKING([for ld.gold object merging bug (binutils 22266)])
- if ! $1 --version | grep -v -q "GNU gold"; then
+ if ! $1 --version | grep -q "GNU gold"; then
# Not gold
result=0
elif test "$cross_compiling" = "yes"; then
=====================================
compiler/GHC.hs
=====================================
@@ -248,7 +248,7 @@ module GHC (
srcSpanStartCol, srcSpanEndCol,
-- ** Located
- GenLocated(..), Located,
+ GenLocated(..), Located, RealLocated,
-- *** Constructing Located
noLoc, mkGeneralLocated,
@@ -274,7 +274,7 @@ module GHC (
parser,
-- * API Annotations
- ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
+ ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
=====================================
compiler/GHC/Cmm/Lint.hs
=====================================
@@ -6,6 +6,7 @@
--
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module GHC.Cmm.Lint (
cmmLint, cmmLintGraph
@@ -14,6 +15,7 @@ module GHC.Cmm.Lint (
import GHC.Prelude
import GHC.Platform
+import GHC.Platform.Regs (callerSaves)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
@@ -26,7 +28,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Utils.Outputable
import GHC.Driver.Session
-import Control.Monad (ap)
+import Control.Monad (ap, unless)
-- Things to check:
-- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
@@ -160,7 +162,13 @@ lintCmmMiddle node = case node of
CmmUnsafeForeignCall target _formals actuals -> do
lintTarget target
- mapM_ lintCmmExpr actuals
+ let lintArg expr = do
+ -- Arguments can't mention caller-saved
+ -- registers. See Note [Register parameter passing].
+ mayNotMentionCallerSavedRegs (text "foreign call argument") expr
+ lintCmmExpr expr
+
+ mapM_ lintArg actuals
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
@@ -188,18 +196,40 @@ lintCmmLast labels node = case node of
CmmForeignCall tgt _ args succ _ _ _ -> do
lintTarget tgt
- mapM_ lintCmmExpr args
+ let lintArg expr = do
+ -- Arguments can't mention caller-saved
+ -- registers. See Note [Register
+ -- parameter passing].
+ -- N.B. This won't catch local registers
+ -- which the NCG's register allocator later
+ -- places in caller-saved registers.
+ mayNotMentionCallerSavedRegs (text "foreign call argument") expr
+ lintCmmExpr expr
+ mapM_ lintArg args
checkTarget succ
where
checkTarget id
| setMember id labels = return ()
| otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-
lintTarget :: ForeignTarget -> CmmLint ()
-lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (ForeignTarget e _) = do
+ mayNotMentionCallerSavedRegs (text "foreign target") e
+ _ <- lintCmmExpr e
+ return ()
lintTarget (PrimTarget {}) = return ()
+-- | As noted in Note [Register parameter passing], the arguments and
+-- 'ForeignTarget' of a foreign call mustn't mention
+-- caller-saved registers.
+mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)
+ => SDoc -> a -> CmmLint ()
+mayNotMentionCallerSavedRegs what thing = do
+ dflags <- getDynFlags
+ let badRegs = filter (callerSaves (targetPlatform dflags))
+ $ foldRegsUsed dflags (flip (:)) [] thing
+ unless (null badRegs)
+ $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -45,6 +45,9 @@ native code generators to handle.
Most operations are parameterised by the 'Width' that they operate on.
Some operations have separate signed and unsigned versions, and float
and integer versions.
+
+Note that there are variety of places in the native code generator where we
+assume that the code produced for a MachOp does not introduce new blocks.
-}
data MachOp
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -93,7 +93,7 @@ data CmmNode e x where
--
-- Invariant: the arguments and the ForeignTarget must not
-- mention any registers for which GHC.Platform.callerSaves
- -- is True. See Note [Register Parameter Passing].
+ -- is True. See Note [Register parameter passing].
CmmBranch :: ULabel -> CmmNode O C
-- Goto another block in the same procedure
@@ -223,11 +223,12 @@ convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
argument passing. These are registers R3-R6, which our generated
code may also be using; as a result, it's necessary to save these
values before doing a foreign call. This is done during initial
-code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. However,
-one result of doing this is that the contents of these registers
-may mysteriously change if referenced inside the arguments. This
-is dangerous, so you'll need to disable inlining much in the same
-way is done in GHC.Cmm.Opt currently. We should fix this!
+code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.
+
+However, one result of doing this is that the contents of these registers may
+mysteriously change if referenced inside the arguments. This is dangerous, so
+you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink
+currently. We should fix this!
-}
---------------------------------------------
=====================================
compiler/GHC/Cmm/Sink.hs
=====================================
@@ -772,6 +772,7 @@ regAddr _ _ _ _ = AnyMem
{-
Note [Inline GlobalRegs?]
+~~~~~~~~~~~~~~~~~~~~~~~~~
Should we freely inline GlobalRegs?
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -287,11 +287,11 @@ we construct as a separate data type and the actual control flow graph in the co
Instead we now return the new basic block if a statement causes a change
in the current block and use the block for all following statements.
-For this reason genCCall is also split into two parts.
-One for calls which *won't* change the basic blocks in
-which successive instructions will be placed.
-A different one for calls which *are* known to change the
-basic block.
+For this reason genCCall is also split into two parts. One for calls which
+*won't* change the basic blocks in which successive instructions will be
+placed (since they only evaluate CmmExpr, which can only contain MachOps, which
+cannot introduce basic blocks in their lowerings). A different one for calls
+which *are* known to change the basic block.
-}
@@ -1028,6 +1028,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
tmp. This is likely to be better, because the reg alloc can
eliminate this reg->reg move here (it won't eliminate the other one,
because the move is into the fixed %ecx).
+ * in the case of C calls the use of ecx here can interfere with arguments.
+ We avoid this with the hack described in Note [Evaluate C-call
+ arguments before placing in destination registers]
-}
shift_code width instr x y{-amount-} = do
x_code <- getAnyReg x
@@ -2022,6 +2025,7 @@ genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))
arg <- getNewRegNat format
arg_code <- getAnyReg n
platform <- ncgPlatform <$> getConfig
+
let dst_r = getRegisterReg platform (CmmLocal dst)
(code, lbl) <- op_code dst_r arg amode
return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)
@@ -2667,9 +2671,12 @@ genCCall' _ is32Bit target dest_regs args bid = do
return code
_ -> panic "genCCall: Wrong number of arguments/results for imul2"
- _ -> if is32Bit
- then genCCall32' target dest_regs args
- else genCCall64' target dest_regs args
+ _ -> do
+ (instrs0, args') <- evalArgs bid args
+ instrs1 <- if is32Bit
+ then genCCall32' target dest_regs args'
+ else genCCall64' target dest_regs args'
+ return (instrs0 `appOL` instrs1)
where divOp1 platform signed width results [arg_x, arg_y]
= divOp platform signed width results Nothing arg_x arg_y
@@ -2732,6 +2739,83 @@ genCCall' _ is32Bit target dest_regs args bid = do
addSubIntC _ _ _ _ _ _ _ _
= panic "genCCall: Wrong number of arguments/results for addSubIntC"
+{-
+Note [Evaluate C-call arguments before placing in destination registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When producing code for C calls we must take care when placing arguments
+in their final registers. Specifically, we must ensure that temporary register
+usage due to evaluation of one argument does not clobber a register in which we
+already placed a previous argument (e.g. as the code generation logic for
+MO_Shl can clobber %rcx due to x86 instruction limitations).
+
+This is precisely what happened in #18527. Consider this C--:
+
+ (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));
+
+Here we are calling the C function `doSomething` with three arguments, the last
+involving a non-trivial expression involving MO_Shl. In this case the NCG could
+naively generate the following assembly (where $tmp denotes some temporary
+register and $argN denotes the register for argument N, as dictated by the
+platform's calling convention):
+
+ mov _s2hp, $arg1 # place first argument
+ mov _s2hq, $arg2 # place second argument
+
+ # Compute 1 << _s2hz
+ mov _s2hz, %rcx
+ shl %cl, $tmp
+
+ # Compute (_s2hw | (1 << _s2hz))
+ mov _s2hw, $arg3
+ or $tmp, $arg3
+
+ # Perform the call
+ call func
+
+This code is outright broken on Windows which assigns $arg1 to %rcx. This means
+that the evaluation of the last argument clobbers the first argument.
+
+To avoid this we use a rather awful hack: when producing code for a C call with
+at least one non-trivial argument, we first evaluate all of the arguments into
+local registers before moving them into their final calling-convention-defined
+homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an
+expression which might contain a MachOp since these are the only cases which
+might clobber registers. Furthermore, we use a conservative approximation of
+this condition (only looking at the top-level of CmmExprs) to avoid spending
+too much effort trying to decide whether we want to take the fast path.
+
+Note that this hack *also* applies to calls to out-of-line PrimTargets (which
+are lowered via a C call) since outOfLineCmmOp produces the call via
+(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up
+back in genCCall{32,64}.
+-}
+
+-- | See Note [Evaluate C-call arguments before placing in destination registers]
+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
+evalArgs bid actuals
+ | any mightContainMachOp actuals = do
+ regs_blks <- mapM evalArg actuals
+ return (concatOL $ map fst regs_blks, map snd regs_blks)
+ | otherwise = return (nilOL, actuals)
+ where
+ mightContainMachOp (CmmReg _) = False
+ mightContainMachOp (CmmRegOff _ _) = False
+ mightContainMachOp (CmmLit _) = False
+ mightContainMachOp _ = True
+
+ evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
+ evalArg actual = do
+ platform <- getPlatform
+ lreg <- newLocalReg $ cmmExprType platform actual
+ (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
+ -- The above assignment shouldn't change the current block
+ MASSERT(isNothing bid1)
+ return (instrs, CmmReg $ CmmLocal lreg)
+
+ newLocalReg :: CmmType -> NatM LocalReg
+ newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty
+
-- Note [DIV/IDIV for bytes]
--
-- IDIV reminder:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -16,7 +16,6 @@ Desugaring expressions.
module GHC.HsToCore.Expr
( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr
- , dsHandleMonadicFailure
)
where
@@ -989,7 +988,7 @@ dsDo ctx stmts
; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
; match <- matchSinglePatVar var (StmtCtxt ctx) pat
(xbstc_boundResultType xbs) (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
+ ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
go _ (ApplicativeStmt body_ty args mb_join) stmts
@@ -1010,7 +1009,7 @@ dsDo ctx stmts
= do { var <- selectSimpleMatchVarL Many pat
; match <- matchSinglePatVar var (StmtCtxt ctx) pat
body_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
+ ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
; return (var:vs, match_code)
}
@@ -1065,31 +1064,6 @@ dsDo ctx stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
- -- In a do expression, pattern-match failure just calls
- -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match m_fail_op =
- case shareFailureHandler match of
- MR_Infallible body -> body
- MR_Fallible body -> do
- fail_op <- case m_fail_op of
- -- Note that (non-monadic) list comprehension, pattern guards, etc could
- -- have fallible bindings without an explicit failure op, but this is
- -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
- -- breakdown of regular and special binds.
- Nothing -> pprPanic "missing fail op" $
- text "Pattern match:" <+> ppr pat <+>
- text "is failable, and fail_expr was left unset"
- Just fail_op -> pure fail_op
- dflags <- getDynFlags
- fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
- fail_expr <- dsSyntaxExpr fail_op [fail_msg]
- body fail_expr
-
-mk_fail_msg :: DynFlags -> Located e -> String
-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
- showPpr dflags (getLoc pat)
-
{-
************************************************************************
* *
=====================================
compiler/GHC/HsToCore/Expr.hs-boot
=====================================
@@ -1,6 +1,6 @@
module GHC.HsToCore.Expr where
-import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )
-import GHC.HsToCore.Monad ( DsM, MatchResult )
+import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
+import GHC.HsToCore.Monad ( DsM )
import GHC.Core ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
@@ -8,5 +8,3 @@ dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -16,7 +16,7 @@ module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
import GHC.Prelude
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
import GHC.Hs
import GHC.Tc.Utils.Zonk
@@ -618,7 +618,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
; var <- selectSimpleMatchVarL Many pat
; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat
res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
+ ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.HsToCore.Utils (
extractMatchResult, combineMatchResults,
adjustMatchResultDs,
shareFailureHandler,
+ dsHandleMonadicFailure,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
@@ -49,7 +50,7 @@ module GHC.HsToCore.Utils (
import GHC.Prelude
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr )
import GHC.Hs
import GHC.Tc.Utils.Zonk
@@ -895,9 +896,33 @@ entered at most once. Adding a dummy 'realWorld' token argument makes
it clear that sharing is not an issue. And that in turn makes it more
CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see #3403.
+-}
+dsHandleMonadicFailure :: Outputable (IdP p) => HsStmtContext p -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+ -- In a do expression, pattern-match failure just calls
+ -- the monadic 'fail' rather than throwing an exception
+dsHandleMonadicFailure ctx pat match m_fail_op =
+ case shareFailureHandler match of
+ MR_Infallible body -> body
+ MR_Fallible body -> do
+ fail_op <- case m_fail_op of
+ -- Note that (non-monadic) list comprehension, pattern guards, etc could
+ -- have fallible bindings without an explicit failure op, but this is
+ -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+ -- breakdown of regular and special binds.
+ Nothing -> pprPanic "missing fail op" $
+ text "Pattern match:" <+> ppr pat <+>
+ text "is failable, and fail_expr was left unset"
+ Just fail_op -> pure fail_op
+ dflags <- getDynFlags
+ fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)
+ fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+ body fail_expr
+
+mk_fail_msg :: Outputable (IdP p) => DynFlags -> HsStmtContext p -> Located e -> String
+mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
-************************************************************************
+{- *********************************************************************
* *
Ticks
* *
=====================================
compiler/GHC/Parser.y
=====================================
@@ -863,17 +863,17 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
-- The Export List
maybeexports :: { (Maybe (Located [LIE GhcPs])) }
- : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >>
- return (Just (sLL $1 $> (fromOL $2))) }
+ : '(' exportlist ')' {% amsL (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >>
+ return (Just (sLL $1 $> (fromOL $ snd $2))) }
| {- empty -} { Nothing }
-exportlist :: { OrdList (LIE GhcPs) }
- : exportlist1 { $1 }
- | {- empty -} { nilOL }
+exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) }
+ : exportlist1 { ([], $1) }
+ | {- empty -} { ([], nilOL) }
-- trailing comma:
- | exportlist1 ',' { $1 }
- | ',' { nilOL }
+ | exportlist1 ',' { ([mj AnnComma $2], $1) }
+ | ',' { ([mj AnnComma $1], nilOL) }
exportlist1 :: { OrdList (LIE GhcPs) }
: exportlist1 ',' export
@@ -1019,11 +1019,11 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
impspec :: { Located (Bool, Located [LIE GhcPs]) }
: '(' exportlist ')' {% ams (sLL $1 $> (False,
- sLL $1 $> $ fromOL $2))
- [mop $1,mcp $3] }
+ sLL $1 $> $ fromOL (snd $2)))
+ ([mop $1,mcp $3] ++ (fst $2)) }
| 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True,
- sLL $1 $> $ fromOL $3))
- [mj AnnHiding $1,mop $2,mcp $4] }
+ sLL $1 $> $ fromOL (snd $3)))
+ ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) }
-----------------------------------------------------------------------------
-- Fixity Declarations
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -259,6 +259,8 @@ data AnnKeywordId
| AnnLarrow -- ^ '<-'
| AnnLarrowU -- ^ '<-', unicode variant
| AnnLet
+ | AnnLolly -- ^ '#->'
+ | AnnLollyU -- ^ '#->', unicode variant
| AnnMdo
| AnnMinus -- ^ '-'
| AnnModule
@@ -291,8 +293,6 @@ data AnnKeywordId
| AnnStatic -- ^ 'static'
| AnnStock
| AnnThen
- | AnnThIdSplice -- ^ '$'
- | AnnThIdTySplice -- ^ '$$'
| AnnThTyQuote -- ^ double '''
| AnnTilde -- ^ '~'
| AnnType
@@ -364,6 +364,7 @@ unicodeAnn AnnOpenB = AnnOpenBU
unicodeAnn AnnCloseB = AnnCloseBU
unicodeAnn AnnOpenEQ = AnnOpenEQU
unicodeAnn AnnCloseQ = AnnCloseQU
+unicodeAnn AnnLolly = AnnLollyU
unicodeAnn ann = ann
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -261,7 +261,7 @@ load_target_into_temp other_target@(PrimTarget _) =
-- What we want to do here is create a new temporary for the foreign
-- call argument if it is not safe to use the expression directly,
-- because the expression mentions caller-saves GlobalRegs (see
--- Note [Register Parameter Passing]).
+-- Note [Register parameter passing]).
--
-- However, we can't pattern-match on the expression here, because
-- this is used in a loop by GHC.Cmm.Parser, and testing the expression
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -243,7 +243,7 @@ emitRtsCallGen res lbl args safe
-- shouldn't be doing the workaround at this point in the pipeline, see
-- Note [Register parameter passing] and the ToDo on CmmCall in
-- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across
--- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly
-- temporary.
callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs platform = (caller_save, caller_load)
=====================================
includes/stg/MachRegs.h
=====================================
@@ -61,6 +61,8 @@
are the RX, FX, DX and USER registers; as a result, if you
decide to caller save a system register (e.g. SP, HP, etc), note that
this code path is completely untested! -- EZY
+
+ See Note [Register parameter passing] for details.
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
=====================================
testsuite/tests/codeGen/should_run/T18527.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Main where
+
+import Data.Bits (setBit)
+import Data.Word (Word32)
+import Data.Int (Int64)
+
+main :: IO ()
+main = offending 100 0 1
+
+offending :: Int64 -> Int64 -> Word32 -> IO ()
+offending h i id = do
+ oldMask <- sendMessage h (2245) i 0
+ let newMask = setBit oldMask (fromIntegral id)
+ sendMessage h (2244) i newMask
+ return ()
+
+foreign import ccall "func"
+ sendMessage :: Int64 -> Word32 -> Int64 -> Int64 -> IO Int64
=====================================
testsuite/tests/codeGen/should_run/T18527.stdout
=====================================
@@ -0,0 +1,3 @@
+ffi call
+ffi call
+
=====================================
testsuite/tests/codeGen/should_run/T18527FFI.c
=====================================
@@ -0,0 +1,14 @@
+#include <stdio.h>
+#include <stdint.h>
+
+int64_t func(int64_t a, uint32_t b, int64_t c, int64_t d) {
+ printf("ffi call");
+ if (a == 1) {
+ printf(" with corrupted convention\n");
+ }
+ else {
+ printf("\n");
+ }
+ return 0;
+}
+
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -207,3 +207,4 @@ test('T16449_2', exit_code(0), compile_and_run, [''])
test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
test('T17920', cmm_src, compile_and_run, [''])
+test('T18527', normal, compile_and_run, ['T18527FFI.c'])
=====================================
testsuite/tests/concurrent/prog001/all.T
=====================================
@@ -16,4 +16,4 @@ test('concprog001', [extra_files(['Arithmetic.hs', 'Converter.hs', 'Mult.hs', 'S
when(fast(), skip), only_ways(['threaded2']),
fragile(16604),
run_timeout_multiplier(2)],
- multimod_compile_and_run, ['Mult', ''])
+ multimod_compile_and_run, ['Mult', '-package ghc'])
=====================================
testsuite/tests/deSugar/should_run/DsDoExprFailMsg.hs
=====================================
@@ -0,0 +1,3 @@
+main = do
+ (x:xs) <- return []
+ return ()
=====================================
testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr
=====================================
@@ -0,0 +1 @@
+DsDoExprFailMsg: user error (Pattern match failure in 'do' block at DsDoExprFailMsg.hs:2:3-8)
=====================================
testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.hs
=====================================
@@ -0,0 +1,2 @@
+{-# LANGUAGE MonadComprehensions #-}
+main = [() | (x:xs) <- return []]
=====================================
testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr
=====================================
@@ -0,0 +1 @@
+DsMonadCompFailMsg: user error (Pattern match failure in monad comprehension at DsMonadCompFailMsg.hs:2:14-19)
=====================================
testsuite/tests/deSugar/should_run/all.T
=====================================
@@ -66,3 +66,6 @@ test('T12595', normal, compile_and_run, [''])
test('T13285', normal, compile_and_run, [''])
test('T18151', normal, compile_and_run, [''])
test('T18172', [], ghci_script, ['T18172.script'])
+
+test('DsDoExprFailMsg', exit_code(1), compile_and_run, [''])
+test('DsMonadCompFailMsg', exit_code(1), compile_and_run, [''])
=====================================
utils/check-api-annotations/Main.hs
=====================================
@@ -5,7 +5,6 @@ import Data.List
import GHC
import GHC.Driver.Session
import GHC.Utils.Outputable
-import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import System.Environment( getArgs )
import System.Exit
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2edc326efadb1d9cb9e412ecbee47cc9bf3d9b31...15932b2a8d418a5e6b13acd4fc20e34fde9844df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2edc326efadb1d9cb9e412ecbee47cc9bf3d9b31...15932b2a8d418a5e6b13acd4fc20e34fde9844df
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/20200807/586770f2/attachment-0001.html>
More information about the ghc-commits
mailing list