[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: StgCmmPrim: remove an unnecessary instruction in doNewArrayOp
Marge Bot
gitlab at gitlab.haskell.org
Fri Apr 19 23:22:02 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f5766c24 by Michal Terepeta at 2019-04-19T23:21:50Z
StgCmmPrim: remove an unnecessary instruction in doNewArrayOp
Previously we would generate a local variable pointing after the array
header and use it to initialize the array elements. But we already use
stores with offset, so it's easy to just add the header to those offsets
during compilation and avoid generating the local variable (which would
become a LEA instruction when using native codegen; LLVM already
optimizes it away).
Signed-off-by: Michal Terepeta <michal.terepeta at gmail.com>
- - - - -
45851059 by klebinger.andreas at gmx.at at 2019-04-19T23:21:52Z
Don't indent single alternative case expressions for STG.
Makes the width of STG dumps slightly saner.
Especially for things like unboxing.
Fixes #16580
- - - - -
9249b8e8 by Vladislav Zavialov at 2019-04-19T23:21:52Z
Tagless final encoding of ExpCmdI in the parser
Before this change, we used a roundabout encoding:
1. a GADT (ExpCmdG)
2. a class to pass it around (ExpCmdI)
3. helpers to match on it (ecHsApp, ecHsIf, ecHsCase, ...)
It is more straightforward to turn these helpers into class methods,
removing the need for a GADT.
- - - - -
6f4800a0 by Alec Theriault at 2019-04-19T23:21:55Z
Haddock: support strict GADT args with docs
Rather than massaging the output of the parser to re-arrange docs and
bangs, it is simpler to patch the two places in which the strictness
info is needed (to accept that the `HsBangTy` may be inside an
`HsDocTy`).
Fixes #16585.
- - - - -
eca59e21 by Andrey Mokhov at 2019-04-19T23:21:55Z
Hadrian: Drop old/unused CI scripts
- - - - -
12 changed files:
- compiler/codeGen/StgCmmPrim.hs
- compiler/hsSyn/HsTypes.hs
- compiler/parser/RdrHsSyn.hs
- compiler/stgSyn/StgSyn.hs
- − hadrian/.travis.yml
- − hadrian/appveyor.yml
- − hadrian/circle.yml
- + testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs
- + testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr
- + testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs
- + testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/all.T
Changes:
=====================================
compiler/codeGen/StgCmmPrim.hs
=====================================
@@ -2143,11 +2143,8 @@ doNewArrayOp res_r rep info payload n init = do
emit $ mkAssign arr base
-- Initialise all elements of the array
- p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
- let initialization =
- [ mkStore (cmmOffsetW dflags (CmmReg (CmmLocal p)) off) init
- | off <- [0.. n - 1]
- ]
+ let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)
+ initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
emit (catAGraphs initialization)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
=====================================
compiler/hsSyn/HsTypes.hs
=====================================
@@ -105,14 +105,22 @@ import Data.Data hiding ( Fixity, Prefix, Infix )
type LBangType pass = Located (BangType pass)
-- | Bang Type
+--
+-- In the parser, strictness and packedness annotations bind more tightly
+-- than docstrings. This means that when consuming a 'BangType' (and looking
+-- for 'HsBangTy') we must be ready to peer behind a potential layer of
+-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
type BangType pass = HsType pass -- Bangs are in the HsType data type
getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ _ ty)) = ty
-getBangType ty = ty
+getBangType (L _ (HsBangTy _ _ lty)) = lty
+getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
+ addCLoc lty lds (HsDocTy x lty lds)
+getBangType lty = lty
getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy _ s _)) = s
+getBangStrictness (L _ (HsBangTy _ s _)) = s
+getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
{-
=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -50,7 +50,6 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for
-- checking and constructing values
- checkBlockArguments,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
@@ -61,7 +60,6 @@ module RdrHsSyn (
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
- checkDoAndIfThenElse,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs, mkRuleTyVarBndrs,
checkRuleTyVarBndrNames,
@@ -94,14 +92,6 @@ module RdrHsSyn (
ExpCmdI(..),
ecFromExp,
ecFromCmd,
- ecHsLam,
- ecHsLet,
- ecOpApp,
- ecHsCase,
- ecHsApp,
- ecHsIf,
- ecHsDo,
- ecHsPar,
) where
@@ -672,10 +662,8 @@ mkConDeclH98 name mb_forall mb_cxt args
, con_forall = noLoc $ isJust mb_forall
, con_ex_tvs = mb_forall `orElse` []
, con_mb_cxt = mb_cxt
- , con_args = args'
+ , con_args = args
, con_doc = Nothing }
- where
- args' = nudgeHsSrcBangs args
mkGadtDecl :: [Located RdrName]
-> LHsType GhcPs -- Always a HsForAllTy
@@ -686,7 +674,7 @@ mkGadtDecl names ty
, con_forall = cL l $ isLHsForAllTy ty'
, con_qvars = mkHsQTvs tvs
, con_mb_cxt = mcxt
- , con_args = args'
+ , con_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns1 ++ anns2)
@@ -703,7 +691,6 @@ mkGadtDecl names ty
= (Nothing, tau, ann)
(args, res_ty) = split_tau tau
- args' = nudgeHsSrcBangs args
-- See Note [GADT abstract syntax] in HsDecls
split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
@@ -715,27 +702,6 @@ mkGadtDecl names ty
(ann++mkParensApiAnn l)
peel_parens ty ann = (ty, ann)
-nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
--- ^ This function ensures that fields with strictness or packedness
--- annotations put these annotations on an outer 'HsBangTy'.
---
--- The problem is that in the parser, strictness and packedness annotations
--- bind more tightly that docstrings. However, the expectation downstream of
--- the parser (by functions such as 'getBangType' and 'getBangStrictness')
--- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
--- top-level type.
---
--- See #15206
-nudgeHsSrcBangs details
- = case details of
- PrefixCon as -> PrefixCon (map go as)
- RecCon r -> RecCon r
- InfixCon a1 a2 -> InfixCon (go a1) (go a2)
- where
- go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
- cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
- go lty = lty
-
setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
@@ -1004,8 +970,9 @@ checkTyClHdr is_cls ty
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
-checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
-checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
+checkExpBlockArguments :: LHsExpr GhcPs -> P ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> P ()
checkExpr expr = case unLoc expr of
@@ -1315,19 +1282,6 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
-checkDoAndIfThenElse
- :: forall b. ExpCmdI b =>
- LHsExpr GhcPs
- -> Bool
- -> Located (b GhcPs)
- -> Bool
- -> Located (b GhcPs)
- -> P ()
-checkDoAndIfThenElse =
- case expCmdG @b of
- ExpG -> checkDoAndIfThenElse'
- CmdG -> checkDoAndIfThenElse'
-
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> P ()
@@ -1924,73 +1878,78 @@ checkMonadComp = do
newtype ExpCmdP =
ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
--- See Note [Ambiguous syntactic categories]
-data ExpCmdG b where
- ExpG :: ExpCmdG HsExpr
- CmdG :: ExpCmdG HsCmd
-
--- See Note [Ambiguous syntactic categories]
-class ExpCmdI b where expCmdG :: ExpCmdG b
-instance ExpCmdI HsExpr where expCmdG = ExpG
-instance ExpCmdI HsCmd where expCmdG = CmdG
-
-ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
-ecFromCmd c@(getLoc -> l) = ExpCmdP onB
- where
- onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }
- onExp :: P (LHsExpr GhcPs)
- onExp = do
- addError l $ vcat
- [ text "Arrow command found where an expression was expected:",
- nest 2 (ppr c) ]
- return (cL l hsHoleExpr)
-
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
-ecFromExp e@(getLoc -> l) = ExpCmdP onB
- where
- onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
- onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }
- onCmd :: P (LHsCmd GhcPs)
- onCmd =
- addFatalError l $
- text "Parse error in command:" <+> ppr e
+ecFromExp a = ExpCmdP (ecFromExp' a)
-hsHoleExpr :: HsExpr (GhcPass id)
-hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
-
-ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }
-
-ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
-ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
+ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
+ecFromCmd a = ExpCmdP (ecFromCmd' a)
-ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
- -> Located (b GhcPs) -> b GhcPs
-ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
- where
- cmdOpApp c1 op c2 =
+-- See Note [Ambiguous syntactic categories]
+class ExpCmdI b where
+ -- | Return a command without ambiguity, or fail in a non-command context.
+ ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))
+ -- | Return an expression without ambiguity, or fail in a non-expression context.
+ ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))
+ -- | Disambiguate "\... -> ..." (lambda)
+ ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+ -- | Disambiguate "let ... in ..."
+ ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "f # x" (infix operator)
+ ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "case ... of ..."
+ ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+ -- | Disambiguate "f x" (function application)
+ ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
+ -- | Disambiguate "if ... then ... else ..."
+ ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
+ -- | Disambiguate "do { ... }" (do notation)
+ ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
+ -- | Disambiguate "( ... )" (parentheses)
+ ecHsPar :: Located (b GhcPs) -> b GhcPs
+ -- | Check if the argument requires -XBlockArguments.
+ checkBlockArguments :: Located (b GhcPs) -> PV ()
+ -- | Check if -XDoAndIfThenElse is enabled.
+ checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
+ -> Bool -> Located (b GhcPs) -> P ()
+
+instance ExpCmdI HsCmd where
+ ecFromCmd' = return
+ ecFromExp' (dL-> L l e) =
+ addFatalError l $
+ text "Parse error in command:" <+> ppr e
+ ecHsLam = HsCmdLam noExt
+ ecHsLet = HsCmdLet noExt
+ ecOpApp c1 op c2 =
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
+ ecHsCase = HsCmdCase noExt
+ ecHsApp = HsCmdApp noExt
+ ecHsIf = mkHsCmdIf
+ ecHsDo = HsCmdDo noExt
+ ecHsPar = HsCmdPar noExt
+ checkBlockArguments = checkCmdBlockArguments
+ checkDoAndIfThenElse = checkDoAndIfThenElse'
+
+instance ExpCmdI HsExpr where
+ ecFromCmd' (dL -> L l c) = do
+ addError l $ vcat
+ [ text "Arrow command found where an expression was expected:",
+ nest 2 (ppr c) ]
+ return (cL l hsHoleExpr)
+ ecFromExp' = return
+ ecHsLam = HsLam noExt
+ ecHsLet = HsLet noExt
+ ecOpApp = OpApp noExt
+ ecHsCase = HsCase noExt
+ ecHsApp = HsApp noExt
+ ecHsIf = mkHsIf
+ ecHsDo = HsDo noExt DoExpr
+ ecHsPar = HsPar noExt
+ checkBlockArguments = checkExpBlockArguments
+ checkDoAndIfThenElse = checkDoAndIfThenElse'
-ecHsCase :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }
-
-ecHsApp :: forall b. ExpCmdI b =>
- Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
-ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
-
-ecHsIf :: forall b. ExpCmdI b =>
- LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
-ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
-
-ecHsDo :: forall b. ExpCmdI b =>
- Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
-ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }
-
-ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
-ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2043,19 +2002,12 @@ we decided against, see Note [Resolving parsing ambiguities: non-taken alternati
The solution that keeps basic definitions (such as HsExpr) clean, keeps the
concerns local to the parser, and does not require duplication of hsSyn types,
-or an extra pass over the entire AST, is to parse into a function from a GADT
-to a parser-validator:
-
- data ExpCmdG b where
- ExpG :: ExpCmdG HsExpr
- CmdG :: ExpCmdG HsCmd
+or an extra pass over the entire AST, is to parse into an overloaded
+parser-validator (a so-called tagless final encoding):
- type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
-
- checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
- checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
- checkExp f = f ExpG -- interpret as an expression
- checkCmd f = f CmdG -- interpret as a command
+ class ExpCmdI b where ...
+ instance ExpCmdI HsCmd where ...
+ instance ExpCmdI HsExp where ...
Consider the 'alts' production used to parse case-of alternatives:
@@ -2065,30 +2017,6 @@ Consider the 'alts' production used to parse case-of alternatives:
We abstract over LHsExpr, and it becomes:
- alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
- : alts1
- { \tag -> $1 tag >>= \ $1 ->
- return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
- | ';' alts
- { \tag -> $2 tag >>= \ $2 ->
- return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
-
-Note that 'ExpCmdG' is a singleton type, the value is completely
-determined by the type:
-
- when (b~HsExpr), tag = ExpG
- when (b~HsCmd), tag = CmdG
-
-This is a clear indication that we can use a class to pass this value behind
-the scenes:
-
- class ExpCmdI b where expCmdG :: ExpCmdG b
- instance ExpCmdI HsExpr where expCmdG = ExpG
- instance ExpCmdI HsCmd where expCmdG = CmdG
-
-And now the 'alts' production is simplified, as we no longer need to
-thread 'tag' explicitly:
-
alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
: alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
@@ -2331,6 +2259,63 @@ each reduction rule:
And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
+Alternative VIII, a function from a GADT
+----------------------------------------
+We could avoid code duplication of the Alternative VII by representing the product
+as a function from a GADT:
+
+ data ExpCmdG b where
+ ExpG :: ExpCmdG HsExpr
+ CmdG :: ExpCmdG HsCmd
+
+ type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+
+ checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
+ checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
+ checkExp f = f ExpG -- interpret as an expression
+ checkCmd f = f CmdG -- interpret as a command
+
+Consider the 'alts' production used to parse case-of alternatives:
+
+ alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
+ : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+We abstract over LHsExpr, and it becomes:
+
+ alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1
+ { \tag -> $1 tag >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts
+ { \tag -> $2 tag >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+Note that 'ExpCmdG' is a singleton type, the value is completely
+determined by the type:
+
+ when (b~HsExpr), tag = ExpG
+ when (b~HsCmd), tag = CmdG
+
+This is a clear indication that we can use a class to pass this value behind
+the scenes:
+
+ class ExpCmdI b where expCmdG :: ExpCmdG b
+ instance ExpCmdI HsExpr where expCmdG = ExpG
+ instance ExpCmdI HsCmd where expCmdG = CmdG
+
+And now the 'alts' production is simplified, as we no longer need to
+thread 'tag' explicitly:
+
+ alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+ : alts1 { $1 >>= \ $1 ->
+ return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+ | ';' alts { $2 >>= \ $2 ->
+ return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to
+more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.
+
-}
---------------------------------------------------------------------------
=====================================
compiler/stgSyn/StgSyn.hs
=====================================
@@ -831,18 +831,31 @@ pprStgExpr (StgTick tickish expr)
else sep [ ppr tickish, pprStgExpr expr ]
+-- Don't indent for a single case alternative.
+pprStgExpr (StgCase expr bndr alt_type [alt])
+ = sep [sep [text "case",
+ nest 4 (hsep [pprStgExpr expr,
+ whenPprDebug (dcolon <+> ppr alt_type)]),
+ text "of", pprBndr CaseBind bndr, char '{'],
+ pprStgAlt False alt,
+ char '}']
+
pprStgExpr (StgCase expr bndr alt_type alts)
= sep [sep [text "case",
nest 4 (hsep [pprStgExpr expr,
whenPprDebug (dcolon <+> ppr alt_type)]),
text "of", pprBndr CaseBind bndr, char '{'],
- nest 2 (vcat (map pprStgAlt alts)),
+ nest 2 (vcat (map (pprStgAlt True) alts)),
char '}']
-pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
-pprStgAlt (con, params, expr)
- = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
- 4 (ppr expr <> semi)
+
+pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
+pprStgAlt indent (con, params, expr)
+ | indent = hang altPattern 4 (ppr expr <> semi)
+ | otherwise = sep [altPattern, ppr expr <> semi]
+ where
+ altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp op) = ppr op
=====================================
hadrian/.travis.yml deleted
=====================================
@@ -1,110 +0,0 @@
-sudo: true
-matrix:
- include:
- - os: linux
- env: MODE="selftest"
- compiler: "GHC 8.4.3"
- addons:
- apt:
- packages:
- - ghc-8.4.3
- - cabal-install-2.4
- - zlib1g-dev
- sources: hvr-ghc
-
- before_install:
- - PATH="/opt/ghc/8.4.3/bin:$PATH"
- - PATH="/opt/cabal/2.4/bin:$PATH"
-
- script:
- # Run internal Hadrian tests, after boot and configure.
- - hadrian/build.sh -c selftest
-
- - os: linux
- env: MODE="--flavour=quickest"
- compiler: "GHC 8.4.3"
- addons:
- apt:
- packages:
- - ghc-8.4.3
- - cabal-install-2.4
- - zlib1g-dev
- sources: hvr-ghc
-
- before_install:
- - PATH="/opt/ghc/8.4.3/bin:$PATH"
- - PATH="/opt/cabal/2.4/bin:$PATH"
-
- script:
- # Build GHC, letting hadrian boot & configure the ghc source tree
- - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=-
-
- - os: linux
- env: MODE="--flavour=quickest --integer-simple"
- compiler: "GHC 8.6.1"
- addons:
- apt:
- packages:
- - ghc-8.6.1
- - cabal-install-2.4
- - zlib1g-dev
- sources: hvr-ghc
-
- before_install:
- - PATH="/opt/ghc/8.6.1/bin:$PATH"
- - PATH="/opt/cabal/2.4/bin:$PATH"
-
- script:
- # boot, configure and build GHC
- - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=-
-
- # Test GHC binary
- - _build/stage1/bin/ghc -e 1+2
-
- - os: osx
- osx_image: xcode8
- env: MODE="--flavour=quickest --integer-simple"
- before_install:
- - brew update
- - brew install ghc cabal-install
- - brew upgrade python
-
- script:
- # Due to timeout limit of OS X build on Travis CI,
- # we will ignore selftest
- - hadrian/build.sh -j -c $MODE --no-progress --progress-colour=never --profile=-
-
- # Test GHC binary
- - _build/stage1/bin/ghc -e 1+2
-
-install:
- # Add Cabal to PATH
- - PATH="$HOME/.cabal/bin:$PATH"
- - export PATH
- - env
-
- # Fetch GHC sources into ./ghc
- - git --version
- - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/
- - git clone --depth 1 --recursive git://github.com/ghc/ghc
- # --shallow-submodules is not supported on travis standard git 1.8 (linux), but it is supported
- # on Travis Mac OS X machines. But it does not work with github mirrors because it cannot
- # find commits.
-
- # Install all Hadrian and GHC build dependencies
- - cabal update
- - cabal install alex happy
-
- # GHC comes with an older version of Hadrian, so we delete it
- - rm -rf ghc/hadrian/.git
-
- # Travis has already cloned Hadrian into ./ and we need to move it
- # to ./ghc/hadrian -- one way to do it is to move the .git directory
- # and perform a hard reset in order to regenerate Hadrian files
- - mv .git ghc/hadrian
- - cd ghc/hadrian && git reset --hard HEAD && cd ..
-
-cache:
- directories:
- - $HOME/.cabal
- - $HOME/.ghc
=====================================
hadrian/appveyor.yml deleted
=====================================
@@ -1,38 +0,0 @@
-clone_folder: "c:\\new-hadrian"
-environment:
- global:
- STACK_ROOT: "c:\\sr"
-
-cache:
- - "c:\\sr -> appveyor.yml"
-
-install:
- # Get Stack
- - curl -ostack.zip -LsS --insecure https://www.stackage.org/stack/windows-x86_64
- - 7z x stack.zip stack.exe
-
- # Note: AppVeyor has already cloned Hadrian into c:\new-hadrian
- # Fetch GHC sources into c:\ghc
- - cd ..
- - git clone --recursive git at gitlab.haskell.org:ghc/ghc.git
- # GHC comes with an older version of Hadrian, so we delete it
- - rm -rf ghc\hadrian
- # Copy new Hadrian into ./ghc/hadrian
- - cp -r new-hadrian ghc\hadrian
-
- # Install Alex and Happy
- - set PATH=C:\Users\appveyor\AppData\Roaming\local\bin;%PATH%
- - ghc\hadrian\stack install --install-ghc alex happy > nul
-
- # Install all Hadrian and GHC build dependencies
- - cd ghc\hadrian
- - stack setup > nul
- - appveyor-retry stack exec -- pacman -S autoconf automake-wrapper make patch python3 tar --noconfirm
-
-build_script:
- # Build GHC
- - cd ..
- - hadrian\build -c -j --flavour=quickest --integer-simple --no-progress --progress-colour=never --profile=-
-
- # Test GHC binary
- - _build\stage1\bin\ghc -e 1+2
=====================================
hadrian/circle.yml deleted
=====================================
@@ -1,45 +0,0 @@
-machine:
- xcode:
- version: 8.0
- environment:
- MODE: --flavour=quickest --integer-simple
-
-dependencies:
- override:
- - brew update
- - brew install ghc cabal-install python3
- - brew link ghc cabal-install python3
- - cabal update
- - cabal install alex 'happy >= 1.19.4' mtl shake QuickCheck
- cache_directories:
- - ~/.cabal
- - ~/.ghc
- - /usr/local/Cellar
-
-compile:
- override:
- # Fetch GHC sources into ./ghc
- - git --version
- - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/
- - git clone --depth 1 --recursive git://github.com/ghc/ghc
-
- # GHC comes with an older version of Hadrian, so we delete it
- - rm -rf ghc/hadrian/.git
- # move hadrian's .git into ./ghc/hadrian and perform a hard reset in order to regenerate Hadrian files
- - mv .git ghc/hadrian
- # NOTE: we must write them in the same line because each line
- # in CircleCI is a separate process, thus you can't "cd" for the other lines
- - cd ghc/hadrian; git reset --hard HEAD
- - cd ghc; ./boot && PATH=~/.cabal/bin:$PATH ./configure
-
- # XXX: export PATH doesn't work well either, so we use inline env
- # Self test
- - cd ghc; PATH=~/.cabal/bin:$PATH hadrian/build.sh selftest
-
- # Build GHC
- - cd ghc; PATH=~/.cabal/bin:$PATH hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=-
-
-test:
- override:
- # Test GHC binary
- - ghc/_build/stage1/bin/ghc -e 1+2
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T15206.hs
=====================================
@@ -0,0 +1,4 @@
+module T15206 where
+data Point = Point -- ^ a 2D point
+ !Int -- ^ x coord
+ !Int -- ^ y coord
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr
=====================================
@@ -0,0 +1,6 @@
+
+==================== Parser ====================
+module T15206 where
+data Point = " a 2D point" Point !Int " x coord" !Int " y coord"
+
+
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T16585.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE GADTs #-}
+module T16585 where
+data F a where
+ X :: !Int -- ^ comment
+ -> F Int
+
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr
=====================================
@@ -0,0 +1,6 @@
+
+==================== Parser ====================
+module T16585 where
+data F a where X :: !Int " comment" -> F Int
+
+
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/all.T
=====================================
@@ -51,3 +51,5 @@ test('haddockA033', normal, compile, ['-haddock -ddump-parsed'])
test('haddockA034', normal, compile, ['-haddock -ddump-parsed'])
test('T10398', normal, compile, ['-haddock -ddump-parsed'])
test('T11768', normal, compile, ['-haddock -ddump-parsed'])
+test('T15206', normal, compile, ['-haddock -ddump-parsed'])
+test('T16585', normal, compile, ['-haddock -ddump-parsed'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/7c3c8295f225ae7c733538fa6e6853e07a360980...eca59e213ef81ef62948af7e165e196fd1d83b88
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/7c3c8295f225ae7c733538fa6e6853e07a360980...eca59e213ef81ef62948af7e165e196fd1d83b88
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/20190419/1c79eda3/attachment-0001.html>
More information about the ghc-commits
mailing list