Skip to content
Commits on Source (3)
  • Vladislav Zavialov's avatar
    Introduce MonadP, make PV a newtype · 28738c78
    Vladislav Zavialov authored and Marge Bot's avatar Marge Bot committed 
    Previously we defined   type PV = P,
this had the downside that if we wanted to change PV,
we would have to modify P as well.

Now PV is free to evolve independently from P.

The common operations addError, addFatalError, getBit, addAnnsAt,
were abstracted into a class called MonadP.
    28738c78
  • Vladislav Zavialov's avatar
    checkPattern error hint is PV context · 051375ff
    Vladislav Zavialov authored and Marge Bot's avatar Marge Bot committed 
    There is a hint added to error messages reported in checkPattern.
Instead of passing it manually, we put it in a ReaderT environment inside PV.
    051375ff
  • Ömer Sinan Ağacan's avatar
    Minor RTS refactoring: · 10d70b9d
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed 
    - Remove redundant casting in evacuate_static_object
- Remove redundant parens in STATIC_LINK
- Fix a typo in GC.c
    10d70b9d
Hide whitespace changes
Inline Side-by-side
compiler/parser/Lexer.x
View file @ 10d70b9d
......@@ -50,16 +50,17 @@
module Lexer (
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
MonadP(..),
getRealSrcLoc, getPState, withThisPackage,
failLocMsgP, srcParseFail,
getErrorMessages, getMessages,
popContext, pushModuleContext, setLastToken, setSrcLoc,
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
ExtBits(..), getBit,
addWarning, addError, addFatalError,
ExtBits(..),
addWarning,
lexTokenStream,
addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
AddAnn,mkParensApiAnn,
commentToAnnotation
) where
......@@ -2276,11 +2277,6 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- stored in a @Word64@.
type ExtsBitmap = Word64
-- | Check if a given flag is currently set in the bitmap.
getBit :: ExtBits -> P Bool
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
xbit :: ExtBits -> ExtsBitmap
xbit = bit . fromEnum
......@@ -2474,34 +2470,59 @@ mkPStatePure options buf loc =
annotations_comments = []
}
-- | Add a non-fatal error. Use this when the parser can produce a result
-- despite the error.
--
-- For example, when GHC encounters a @forall@ in a type,
-- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
-- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
-- the accumulator.
-- | An mtl-style class for monads that support parsing-related operations.
-- For example, sometimes we make a second pass over the parsing results to validate,
-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume
-- input but can report parsing errors, check for extension bits, and accumulate
-- parsing annotations. Both P and PV are instances of MonadP.
--
-- Control flow wise, non-fatal errors act like warnings: they are added
-- to the accumulator and parsing continues. This allows GHC to report
-- more than one parse error per file.
-- MonadP grants us convenient overloading. The other option is to have separate operations
-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.
--
addError :: SrcSpan -> SDoc -> P ()
addError srcspan msg
= P $ \s@PState{messages=m} ->
let
m' d =
let (ws, es) = m d
errormsg = mkErrMsg d srcspan alwaysQualify msg
es' = es `snocBag` errormsg
in (ws, es')
in POk s{messages=m'} ()
-- | Add a fatal error. This will be the last error reported by the parser, and
-- the parser will not produce any result, ending in a 'PFailed' state.
addFatalError :: SrcSpan -> SDoc -> P a
addFatalError span msg =
addError span msg >> P PFailed
class Monad m => MonadP m where
-- | Add a non-fatal error. Use this when the parser can produce a result
-- despite the error.
--
-- For example, when GHC encounters a @forall@ in a type,
-- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
-- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
-- the accumulator.
--
-- Control flow wise, non-fatal errors act like warnings: they are added
-- to the accumulator and parsing continues. This allows GHC to report
-- more than one parse error per file.
--
addError :: SrcSpan -> SDoc -> m ()
-- | Add a fatal error. This will be the last error reported by the parser, and
-- the parser will not produce any result, ending in a 'PFailed' state.
addFatalError :: SrcSpan -> SDoc -> m a
-- | Check if a given flag is currently set in the bitmap.
getBit :: ExtBits -> m Bool
-- | Given a location and a list of AddAnn, apply them all to the location.
addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
-> AnnKeywordId -- The first two parameters are the key
-> SrcSpan -- The location of the keyword itself
-> m ()
instance MonadP P where
addError srcspan msg
= P $ \s@PState{messages=m} ->
let
m' d =
let (ws, es) = m d
errormsg = mkErrMsg d srcspan alwaysQualify msg
es' = es `snocBag` errormsg
in (ws, es')
in POk s{messages=m'} ()
addFatalError span msg =
addError span msg >> P PFailed
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
addAnnsAt loc anns = mapM_ (\a -> a loc) anns
addAnnotation l a v = do
addAnnotationOnly l a v
allocateComments l
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
......@@ -3042,23 +3063,11 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
-- function, and then it can be discharged using the 'ams' function.
type AddAnn = SrcSpan -> P ()
addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct
-> AnnKeywordId -- The first two parameters are the key
-> SrcSpan -- The location of the keyword itself
-> P ()
addAnnotation l a v = do
addAnnotationOnly l a v
allocateComments l
addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
-- |Given a location and a list of AddAnn, apply them all to the location.
addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
addAnnsAt loc anns = mapM_ (\a -> a loc) anns
-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddAnn' values for the opening and closing bordering on the start
-- and end of the span
......
compiler/parser/Parser.y
View file @ 10d70b9d
......@@ -2396,8 +2396,8 @@ decl_no_th :: { LHsDecl GhcPs }
| '!' aexp rhs {% runExpCmdP $2 >>= \ $2 ->
do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
; l = comb2 $1 $> };
(ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
hintBangPat (comb2 $1 $2) (unLoc e) ;
(ann, r) <- checkValDef SrcStrict e Nothing $3 ;
runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
......@@ -2410,7 +2410,7 @@ decl_no_th :: { LHsDecl GhcPs }
_ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
return $! (sL l $ ValD noExt r) } }
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
......@@ -2582,8 +2582,8 @@ exp :: { ExpCmdP }
infixexp :: { ExpCmdP }
: exp10 { $1 }
| infixexp qop exp10 { ExpCmdP $
runExpCmdP $1 >>= \ $1 ->
runExpCmdP $3 >>= \ $3 ->
runExpCmdPV $1 >>= \ $1 ->
runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> (ecOpApp $1 $2 $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
......@@ -2670,13 +2670,13 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
fexp :: { ExpCmdP }
: fexp aexp {% runExpCmdP $2 >>= \ $2 ->
checkBlockArguments $2 >>= \_ ->
runPV (checkBlockArguments $2) >>= \_ ->
return $ ExpCmdP $
runExpCmdP $1 >>= \ $1 ->
runExpCmdPV $1 >>= \ $1 ->
checkBlockArguments $1 >>= \_ ->
return (sLL $1 $> (ecHsApp $1 $2)) }
| fexp TYPEAPP atype {% runExpCmdP $1 >>= \ $1 ->
checkBlockArguments $1 >>= \_ ->
runPV (checkBlockArguments $1) >>= \_ ->
fmap ecFromExp $
ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
......@@ -2699,7 +2699,7 @@ aexp :: { ExpCmdP }
| '\\' apat apats '->' exp
{ ExpCmdP $
runExpCmdP $5 >>= \ $5 ->
runExpCmdPV $5 >>= \ $5 ->
ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match { m_ext = noExt
, m_ctxt = LambdaExpr
......@@ -2707,12 +2707,12 @@ aexp :: { ExpCmdP }
, m_grhss = unguardedGRHSs $5 }]))
[mj AnnLam $1, mu AnnRarrow $4] }
| 'let' binds 'in' exp { ExpCmdP $
runExpCmdP $4 >>= \ $4 ->
runExpCmdPV $4 >>= \ $4 ->
ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
(mj AnnLet $1:mj AnnIn $3
:(fst $ unLoc $2)) }
| '\\' 'lcase' altslist
{% $3 >>= \ $3 ->
{% runPV $3 >>= \ $3 ->
fmap ecFromExp $
ams (sLL $1 $> $ HsLamCase noExt
(mkMatchGroup FromSource (snd $ unLoc $3)))
......@@ -2720,8 +2720,8 @@ aexp :: { ExpCmdP }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runExpCmdP $2 >>= \ $2 ->
return $ ExpCmdP $
runExpCmdP $5 >>= \ $5 ->
runExpCmdP $8 >>= \ $8 ->
runExpCmdPV $5 >>= \ $5 ->
runExpCmdPV $8 >>= \ $8 ->
checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
ams (sLL $1 $> $ ecHsIf $2 $5 $8)
(mj AnnIf $1:mj AnnThen $4
......@@ -2746,13 +2746,13 @@ aexp :: { ExpCmdP }
ams (cL (comb2 $1 $2)
(ecHsDo (mapLoc snd $2)))
(mj AnnDo $1:(fst $ unLoc $2)) }
| 'mdo' stmtlist {% $2 >>= \ $2 ->
| 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
fmap ecFromExp $
ams (cL (comb2 $1 $2)
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
{% (checkPattern empty <=< runExpCmdP) $2 >>= \ p ->
{% (checkPattern <=< runExpCmdP) $2 >>= \ p ->
runExpCmdP $4 >>= \ $4@cmd ->
fmap ecFromExp $
ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
......@@ -2788,7 +2788,7 @@ aexp2 :: { ExpCmdP }
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { ExpCmdP $
runExpCmdP $2 >>= \ $2 ->
runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] }
| '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
; fmap ecFromExp $
......@@ -2825,7 +2825,7 @@ aexp2 :: { ExpCmdP }
(if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
| '[t|' ktype '|]' {% fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
| '[p|' infixexp '|]' {% (checkPattern empty <=< runExpCmdP) $2 >>= \p ->
| '[p|' infixexp '|]' {% (checkPattern <=< runExpCmdP) $2 >>= \p ->
fmap ecFromExp $
ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
[mo $1,mu AnnCloseQ $3] }
......@@ -3022,12 +3022,12 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau
amsL (comb2 $1 $>) (fst $ unLoc $3) >>
return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
| squals ',' qual
{% $3 >>= \ $3 ->
{% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| transformqual {% ams $1 (fst $ unLoc $1) >>
return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
| qual {% $1 >>= \ $1 ->
| qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
-- | '{|' pquals '|}' { sL1 $1 [$2] }
......@@ -3068,11 +3068,11 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
: guardquals1 ',' qual {% $3 >>= \ $3 ->
: guardquals1 ',' qual {% runPV $3 >>= \ $3 ->
addAnnotation (gl $ head $ unLoc $1) AnnComma
(gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| qual {% $1 >>= \ $1 ->
| qual {% runPV $1 >>= \ $1 ->
return $ sL1 $1 [$1] }
-----------------------------------------------------------------------------
......@@ -3126,7 +3126,7 @@ alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (
return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) }
ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
: '->' exp { runExpCmdP $2 >>= \ $2 ->
: '->' exp { runExpCmdPV $2 >>= \ $2 ->
ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
[mu AnnRarrow $1] }
| gdpats { $1 >>= \gdpats ->
......@@ -3142,14 +3142,14 @@ gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
: '{' gdpats '}' {% $2 >>= \ $2 ->
: '{' gdpats '}' {% runPV $2 >>= \ $2 ->
return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) }
| gdpats close {% $1 >>= \ $1 ->
| gdpats close {% runPV $1 >>= \ $1 ->
return $ sL1 $1 ([],unLoc $1) }
gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
: '|' guardquals '->' exp
{ runExpCmdP $4 >>= \ $4 ->
{ runExpCmdPV $4 >>= \ $4 ->
ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
[mj AnnVbar $1,mu AnnRarrow $3] }
......@@ -3158,26 +3158,26 @@ gdpat :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
-- Bangs inside are parsed as infix operator applications, so that
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
pat : exp {% (checkPattern empty <=< runExpCmdP) $1 }
pat : exp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
amms (checkPattern empty (sLL $1 $> (SectionR noExt
amms (checkPattern (sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
bindpat :: { LPat GhcPs }
bindpat : exp {% runExpCmdP $1 >>= \ $1 ->
checkPattern
(text "Possibly caused by a missing 'do'?") $1 }
-- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
checkPattern_msg (text "Possibly caused by a missing 'do'?") $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
amms (checkPattern
(text "Possibly caused by a missing 'do'?")
-- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
amms (checkPattern_msg (text "Possibly caused by a missing 'do'?")
(sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
apat :: { LPat GhcPs }
apat : aexp {% (checkPattern empty <=< runExpCmdP) $1 }
apat : aexp {% (checkPattern <=< runExpCmdP) $1 }
| '!' aexp {% runExpCmdP $2 >>= \ $2 ->
amms (checkPattern empty
amms (checkPattern
(sLL $1 $> (SectionR noExt
(sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
[mj AnnBang $1] }
......@@ -3229,12 +3229,12 @@ stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b
-- For typing stmts at the GHCi prompt, where
-- the input may consist of just comments.
maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
: stmt {% fmap Just $1 }
: stmt {% fmap Just (runPV $1) }
| {- nothing -} { Nothing }
-- For GHC API.
e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
: stmt {% $1 }
: stmt {% runPV $1 }
stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
: qual { $1 }
......@@ -3243,10 +3243,10 @@ stmt :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
(mj AnnRec $1:(fst $ unLoc $2)) }
qual :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
: bindpat '<-' exp { runExpCmdP $3 >>= \ $3 ->
: bindpat '<-' exp { runExpCmdPV $3 >>= \ $3 ->
ams (sLL $1 $> $ mkBindStmt $1 $3)
[mu AnnLarrow $2] }
| exp { runExpCmdP $1 >>= \ $1 ->
| exp { runExpCmdPV $1 >>= \ $1 ->
return $ sL1 $1 $ mkBodyStmt $1 }
| 'let' binds { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2))
(mj AnnLet $1:(fst $ unLoc $2)) }
......@@ -4037,7 +4037,7 @@ am a (b,s) = do
-- as any annotations that may arise in the binds. This will include open
-- and closing braces if they are used to delimit the let expressions.
--
ams :: Located a -> [AddAnn] -> P (Located a)
ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
amsL :: SrcSpan -> [AddAnn] -> P ()
......
compiler/parser/RdrHsSyn.hs
View file @ 10d70b9d
......@@ -15,6 +15,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsOpApp,
......@@ -53,10 +54,10 @@ module RdrHsSyn (
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
checkPattern_msg,
bang_RDR,
isBangRdr,
isTildeRdr,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
......@@ -88,7 +89,9 @@ module RdrHsSyn (
-- Expression/command ambiguity resolution
PV,
ExpCmdP(ExpCmdP, runExpCmdP),
runPV,
ExpCmdP(ExpCmdP, runExpCmdPV),
runExpCmdP,
ExpCmdI(..),
ecFromExp,
ecFromCmd,
......@@ -127,6 +130,7 @@ import Data.List
import DynFlags ( WarningFlag(..) )
import Control.Monad
import Control.Monad.Trans.Reader
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import qualified Data.Monoid as Monoid
......@@ -970,11 +974,11 @@ 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.
checkExpBlockArguments :: LHsExpr GhcPs -> P ()
checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> P ()
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
HsDo _ DoExpr _ -> check "do block" expr
HsDo _ MDoExpr _ -> check "mdo block" expr
......@@ -986,7 +990,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsProc {} -> check "proc expression" expr
_ -> return ()
checkCmd :: LHsCmd GhcPs -> P ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
HsCmdLam {} -> check "lambda command" cmd
HsCmdCase {} -> check "case command" cmd
......@@ -995,7 +999,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
HsCmdDo {} -> check "do command" cmd
_ -> return ()
check :: (HasSrcSpan a, Outputable a) => String -> a -> P ()
check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
......@@ -1052,38 +1056,39 @@ checkNoDocs msg ty = go ty
-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.
checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern msg e = checkLPat msg e
checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern = runPV . checkLPat
checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs]
checkPatterns msg es = mapM (checkPattern msg) es
checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern_msg msg = runPV_msg msg . checkLPat
checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkLPat msg e@(dL->L l _) = checkPat msg l e []
checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs)
checkLPat e@(dL->L l _) = checkPat l e []
checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> P (LPat GhcPs)
checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args
checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args
| isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c =
patFail (text "Perhaps you intended to use RecursiveDo") l e
checkPat msg loc e args -- OK to let this happen even if bang-patterns
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l e
checkPat loc e args -- OK to let this happen even if bang-patterns
-- are not enabled, because there is no valid
-- non-bang-pattern parse of (C ! e)
| Just (e', args') <- splitBang e
= do { args'' <- checkPatterns msg args'
; checkPat msg loc e' (args'' ++ args) }
checkPat msg loc (dL->L _ (HsApp _ f e)) args
= do p <- checkLPat msg e
checkPat msg loc f (p : args)
checkPat msg loc (dL->L _ e) []
= do p <- checkAPat msg loc e
= do { args'' <- mapM checkLPat args'
; checkPat loc e' (args'' ++ args) }
checkPat loc (dL->L _ (HsApp _ f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
checkPat loc (dL->L _ e) []
= do p <- checkAPat loc e
return (cL loc p)
checkPat msg loc e _
= patFail msg loc (unLoc e)
checkPat loc e _
= patFail loc (unLoc e)
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
checkAPat msg loc e0 = do
checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs)
checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
EWildPat _ -> return (WildPat noExt)
......@@ -1104,16 +1109,16 @@ checkAPat msg loc e0 = do
SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
| bang == bang_RDR
-> do { hintBangPat loc e0
; e' <- checkLPat msg e
; e' <- checkLPat e
; addAnnotation loc AnnBang lb
; return (BangPat noExt e') }
ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt))
EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n)
ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt))
EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
EViewPat _ expr patE -> checkLPat msg patE >>=
EViewPat _ expr patE -> checkLPat patE >>=
(return . (\p -> ViewPat noExt expr p))
ExprWithTySig _ e t -> do e <- checkLPat msg e
ExprWithTySig _ e t -> do e <- checkLPat e
return (SigPat noExt e t)
-- n+k patterns
......@@ -1124,34 +1129,34 @@ checkAPat msg loc e0 = do
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
l <- checkLPat msg l
r <- checkLPat msg r
l <- checkLPat l
r <- checkLPat r
return (ConPatIn (cL cl c) (InfixCon l r))
OpApp {} -> patFail msg loc e0
OpApp {} -> patFail loc e0
ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
ExplicitList _ _ es -> do ps <- mapM checkLPat es
return (ListPat noExt ps)
HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt))
HsPar _ e -> checkLPat e >>= (return . (ParPat noExt))
ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM (checkLPat msg)
| all tupArgPresent es -> do ps <- mapM checkLPat
[e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
| otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
$$ ppr e0)
ExplicitSum _ alt arity expr -> do
p <- checkLPat msg expr
p <- checkLPat expr
return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
-> do fs <- mapM (checkPatField msg) fs
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE _ s | not (isTypedSplice s)
-> return (SplicePat noExt s)
_ -> patFail msg loc e0
_ -> patFail loc e0
placeHolderPunRhs :: LHsExpr GhcPs
-- The RHS of a punned record field will be filled in by the renamer
......@@ -1169,15 +1174,13 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR)
checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs)
-> P (LHsRecField GhcPs (LPat GhcPs))
checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld)
return (cL l (fld { hsRecFieldArg = p }))
checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs)
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
return (cL l (fld { hsRecFieldArg = p }))
patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a
patFail msg loc e = addFatalError loc err
where err = text "Parse error in pattern:" <+> ppr e
$$ msg
patFail :: SrcSpan -> HsExpr GhcPs -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
......@@ -1186,28 +1189,26 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
checkValDef :: SDoc
-> SrcStrictness
checkValDef :: SrcStrictness
-> LHsExpr GhcPs
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef msg _strictness lhs (Just sig) grhss
checkValDef _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (cL (combineLocs lhs sig)
= checkPatBind (cL (combineLocs lhs sig)
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss))
checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind msg strictness ann (getLoc lhs)
checkFunBind strictness ann (getLoc lhs)
fun is_infix pats (cL l grhss)
Nothing -> checkPatBind msg lhs g }
Nothing -> checkPatBind lhs g }
checkFunBind :: SDoc
-> SrcStrictness
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
......@@ -1215,8 +1216,8 @@ checkFunBind :: SDoc
-> [LHsExpr GhcPs]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
= do ps <- checkPatterns msg pats
checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss)
= do ps <- mapM checkPattern pats
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
......@@ -1241,12 +1242,11 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
checkPatBind :: SDoc
-> LHsExpr GhcPs
checkPatBind :: LHsExpr GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind msg lhs (dL->L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
checkPatBind lhs (dL->L _ (_,grhss))
= do { lhs <- checkPattern lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
......@@ -1284,7 +1284,7 @@ checkValSigLhs lhs@(dL->L l _)
checkDoAndIfThenElse'
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> P ()
=> a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
......@@ -1876,7 +1876,10 @@ checkMonadComp = do
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
newtype ExpCmdP =
ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs))
runExpCmdP p = runPV (runExpCmdPV p)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp a = ExpCmdP (ecFromExp' a)
......@@ -1910,7 +1913,7 @@ class ExpCmdI b where
checkBlockArguments :: Located (b GhcPs) -> PV ()
-- | Check if -XDoAndIfThenElse is enabled.
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
-> Bool -> Located (b GhcPs) -> P ()
-> Bool -> Located (b GhcPs) -> PV ()
instance ExpCmdI HsCmd where
ecFromCmd' = return
......@@ -2661,7 +2664,30 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
-----------------------------------------------------------------------------
-- Misc utils
type PV = P -- See Note [Parser-Validator]
-- See Note [Parser-Validator] and Note [Parser-Validator ReaderT SDoc]
newtype PV a = PV (ReaderT SDoc P a)
deriving (Functor, Applicative, Monad)
runPV :: PV a -> P a
runPV (PV m) = runReaderT m empty
runPV_msg :: SDoc -> PV a -> P a
runPV_msg msg (PV m) = runReaderT m msg
localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
localPV_msg f (PV m) = PV (local f m)
instance MonadP PV where
addError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
addFatalError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
getBit ext =
PV $ ReaderT $ \_ -> getBit ext
addAnnsAt loc anns =
PV $ ReaderT $ \_ -> addAnnsAt loc anns
addAnnotation l a v =
PV $ ReaderT $ \_ -> addAnnotation l a v
{- Note [Parser-Validator]
~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2693,8 +2719,50 @@ not consume any input, but may fail or use other effects. Thus we have:
-}
{- Note [Parser-Validator ReaderT SDoc]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A PV computation is parametrized by a hint for error messages, which can be set
depending on validation context. We use this in checkPattern to fix #984.
Consider this example, where the user has forgotten a 'do':
f _ = do
x <- computation
case () of
_ ->
result <- computation
case () of () -> undefined
GHC parses it as follows:
f _ = do
x <- computation
(case () of
_ ->
result) <- computation
case () of () -> undefined
Note that this fragment is parsed as a pattern:
case () of
_ ->
result
We attempt to detect such cases and add a hint to the error messages:
T984.hs:6:9:
Parse error in pattern: case () of { _ -> result }
Possibly caused by a missing 'do'?
The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
via ReaderT SDoc in PV. When validating in a context other than 'bindpat' (a
pattern to the left of <-), we set the hint to 'empty' and it has no effect on
the error messages.
-}
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
......
includes/rts/storage/ClosureMacros.h
View file @ 10d70b9d
......@@ -184,8 +184,8 @@ STATIC_LINK(const StgInfoTable *info, StgClosure *p)
case IND_STATIC:
return IND_STATIC_LINK(p);
default:
return &(p)->payload[info->layout.payload.ptrs +
info->layout.payload.nptrs];
return &p->payload[info->layout.payload.ptrs +
info->layout.payload.nptrs];
}
}
......
rts/sm/Evac.c
View file @ 10d70b9d
......@@ -333,7 +333,7 @@ evacuate_static_object (StgClosure **link_field, StgClosure *q)
StgWord link = (StgWord)*link_field;
// See Note [STATIC_LINK fields] for how the link field bits work
if ((((StgWord)(link)&STATIC_BITS) | prev_static_flag) != 3) {
if (((link & STATIC_BITS) | prev_static_flag) != 3) {
StgWord new_list_head = (StgWord)q | static_flag;
#if !defined(THREADED_RTS)
*link_field = gct->static_objects;
......
rts/sm/GC.c
View file @ 10d70b9d
......@@ -281,7 +281,7 @@ GarbageCollect (uint32_t collect_gen,
// lose locality by moving cached data into another CPU's cache
// (this effect can be quite significant).
//
// We could have a more complex way to deterimine whether to do
// We could have a more complex way to determine whether to do
// work stealing or not, e.g. it might be a good idea to do it
// if the heap is big. For now, we just turn it on or off with
// a flag.
......