summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Cmm')
-rw-r--r--compiler/GHC/Cmm/Lexer.x8
-rw-r--r--compiler/GHC/Cmm/Parser.y26
-rw-r--r--compiler/GHC/Cmm/Parser/Monad.hs5
3 files changed, 26 insertions, 13 deletions
diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index 85b06ea624..bf379ec7da 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -26,7 +26,9 @@ import GHC.Types.Unique.FM
import GHC.Data.StringBuffer
import GHC.Data.FastString
import GHC.Parser.CharClass
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr ()
+import GHC.Utils.Error
import GHC.Utils.Misc
--import TRACE
@@ -326,7 +328,9 @@ lexToken = do
AlexEOF -> do let span = mkPsSpan loc1 loc1
liftP (setLastToken span 0)
return (L span CmmT_EOF)
- AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])
+ AlexError (loc2,_) ->
+ let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer
+ in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg
AlexSkip inp2 _ -> do
setInput inp2
lexToken
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index a83feff8cf..d182a6f714 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -239,7 +239,8 @@ import qualified GHC.Cmm.Parser.Monad as PD
import GHC.Cmm.CallConv
import GHC.Runtime.Heap.Layout
import GHC.Parser.Lexer
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Parser.Errors.Ppr
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
@@ -918,7 +919,7 @@ getLit _ = panic "invalid literal" -- TODO messy failure
nameToMachOp :: FastString -> PD (Width -> MachOp)
nameToMachOp name =
case lookupUFM machOps name of
- Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []
+ Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
Just m -> return m
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
@@ -1083,12 +1084,14 @@ parseSafety :: String -> PD Safety
parseSafety "safe" = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
-parseSafety str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []
+parseSafety str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+ PsErrCmmParser (CmmUnrecognisedSafety str)
parseCmmHint :: String -> PD ForeignHint
parseCmmHint "ptr" = return AddrHint
parseCmmHint "signed" = return SignedHint
-parseCmmHint str = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []
+parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+ PsErrCmmParser (CmmUnrecognisedHint str)
-- labels are always pointers, so we might as well infer the hint
inferCmmHint :: CmmExpr -> ForeignHint
@@ -1115,7 +1118,7 @@ happyError = PD $ \_ _ s -> unP srcParseFail s
stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
stmtMacro fun args_code = do
case lookupUFM stmtMacros fun of
- Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []
+ Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)
Just fcode -> return $ do
args <- sequence args_code
code (fcode args)
@@ -1218,7 +1221,8 @@ foreignCall conv_string results_code expr_code args_code safety ret
= do conv <- case conv_string of
"C" -> return CCallConv
"stdcall" -> return StdCallConv
- _ -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []
+ _ -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
+ PsErrCmmParser (CmmUnknownCConv conv_string)
return $ do
platform <- getPlatform
results <- sequence results_code
@@ -1296,7 +1300,7 @@ primCall results_code name args_code
= do
platform <- PD.getPlatform
case lookupUFM (callishMachOps platform) name of
- Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []
+ Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
Just f -> return $ do
results <- sequence results_code
args <- sequence args_code
@@ -1451,7 +1455,11 @@ initEnv profile = listToUFM [
where platform = profilePlatform profile
-parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))
+parseCmmFile :: DynFlags
+ -> Module
+ -> HomeUnit
+ -> FilePath
+ -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))
parseCmmFile dflags this_mod home_unit filename = do
buf <- hGetStringBuffer filename
let
@@ -1474,7 +1482,7 @@ parseCmmFile dflags this_mod home_unit filename = do
return (cmm ++ cmm2, used_info)
(cmm, _) = runC dflags no_module st fcode
(warnings,errors) = getMessages pst
- if not (isEmptyBag errors)
+ if not (isEmptyMessages errors)
then return (warnings, errors, Nothing)
else return (warnings, errors, Just cmm)
where
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
index 77124ad1b2..4a72780c2f 100644
--- a/compiler/GHC/Cmm/Parser/Monad.hs
+++ b/compiler/GHC/Cmm/Parser/Monad.hs
@@ -27,7 +27,8 @@ import Control.Monad
import GHC.Driver.Session
import GHC.Parser.Lexer
-import GHC.Parser.Errors
+import GHC.Parser.Errors.Types
+import GHC.Types.Error ( MsgEnvelope )
import GHC.Types.SrcLoc
import GHC.Unit.Types
import GHC.Unit.Home
@@ -47,7 +48,7 @@ instance Monad PD where
liftP :: P a -> PD a
liftP (P f) = PD $ \_ _ s -> f s
-failMsgPD :: (SrcSpan -> PsError) -> PD a
+failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a
failMsgPD = liftP . failMsgP
returnPD :: a -> PD a
View Lorry Controller Status