Rework parser to allow use with DynFlags

Split out the options needed by the parser from DynFlags, making the
parser more friendly to standalone usage.

Test Plan: validate

Reviewers: simonmar, alanz, bgamari, austin, thomie

Reviewed By: simonmar, alanz, bgamari, thomie

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2208

GHC Trac Issues: #10961

3 files changed, 102 insertions, 40 deletions

diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index 175259a3e9..82f7bee965 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -25,6 +25,7 @@ module CmmLex (
 import CmmExpr
 
 import Lexer
+import CmmMonad
 import SrcLoc
 import UniqFM
 import StringBuffer
@@ -182,13 +183,13 @@ data CmmToken
 -- -----------------------------------------------------------------------------
 -- Lexer actions
 
-type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
+type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
 
 begin :: Int -> Action
-begin code _span _str _len = do pushLexState code; lexToken
+begin code _span _str _len = do liftP (pushLexState code); lexToken
 
 pop :: Action
-pop _span _buf _len = popLexState >> lexToken
+pop _span _buf _len = liftP popLexState >> lexToken
 
 special_char :: Action
 special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
@@ -286,45 +287,47 @@ tok_string str = CmmT_String (read str)
 setLine :: Int -> Action
 setLine code span buf len = do
   let line = parseUnsignedInteger buf len 10 octDecDigit
-  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-        -- subtract one: the line number refers to the *following* line
-  -- trace ("setLine "  ++ show line) $ do
-  popLexState >> pushLexState code
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+          -- subtract one: the line number refers to the *following* line
+    -- trace ("setLine "  ++ show line) $ do
+    popLexState >> pushLexState code
   lexToken
 
 setFile :: Int -> Action
 setFile code span buf len = do
   let file = lexemeToFastString (stepOn buf) (len-2)
-  setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
-  popLexState >> pushLexState code
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+    popLexState >> pushLexState code
   lexToken
 
 -- -----------------------------------------------------------------------------
 -- This is the top-level function: called from the parser each time a
 -- new token is to be read from the input.
 
-cmmlex :: (Located CmmToken -> P a) -> P a
+cmmlex :: (Located CmmToken -> PD a) -> PD a
 cmmlex cont = do
   (L span tok) <- lexToken
   --trace ("token: " ++ show tok) $ do
   cont (L (RealSrcSpan span) tok)
 
-lexToken :: P (RealLocated CmmToken)
+lexToken :: PD (RealLocated CmmToken)
 lexToken = do
   inp@(loc1,buf) <- getInput
-  sc <- getLexState
+  sc <- liftP getLexState
   case alexScan inp sc of
     AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
-                  setLastToken span 0
+                  liftP (setLastToken span 0)
                   return (L span CmmT_EOF)
-    AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
     AlexSkip inp2 _ -> do
         setInput inp2
         lexToken
     AlexToken inp2@(end,_buf2) len t -> do
         setInput inp2
         let span = mkRealSrcSpan loc1 end
-        span `seq` setLastToken span len
+        span `seq` liftP (setLastToken span len)
         t span buf len
 
 -- -----------------------------------------------------------------------------
@@ -352,9 +355,9 @@ alexGetByte (loc,s)
         loc' = advanceSrcLoc loc c
         s'   = stepOn s
 
-getInput :: P AlexInput
-getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
+getInput :: PD AlexInput
+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
 
-setInput :: AlexInput -> P ()
-setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
+setInput :: AlexInput -> PD ()
+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
 }
diff --git a/compiler/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
new file mode 100644
index 0000000000..af018fcd5a
--- /dev/null
+++ b/compiler/cmm/CmmMonad.hs
@@ -0,0 +1,58 @@
+-----------------------------------------------------------------------------
+-- A Parser monad with access to the 'DynFlags'.
+--
+-- The 'P' monad  only has access to the subset of of 'DynFlags'
+-- required for parsing Haskell.
+
+-- The parser for C-- requires access to a lot more of the 'DynFlags',
+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
+-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module CmmMonad (
+    PD(..)
+  , liftP
+  ) where
+
+import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
+
+import DynFlags
+import Lexer
+
+newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
+
+instance Functor PD where
+  fmap = liftM
+
+instance Applicative PD where
+  pure = returnPD
+  (<*>) = ap
+
+instance Monad PD where
+  (>>=) = thenPD
+  fail = failPD
+
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail PD where
+  fail = failPD
+#endif
+
+liftP :: P a -> PD a
+liftP (P f) = PD $ \_ s -> f s
+
+returnPD :: a -> PD a
+returnPD = liftP . return
+
+thenPD :: PD a -> (a -> PD b) -> PD b
+(PD m) `thenPD` k = PD $ \d s ->
+        case m d s of
+                POk s1 a         -> unPD (k a) d s1
+                PFailed span err -> PFailed span err
+
+failPD :: String -> PD a
+failPD = liftP . fail
+
+instance HasDynFlags PD where
+   getDynFlags = PD $ \d s -> POk s d
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 81e62c2a29..e07e0a65c8 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -228,6 +228,7 @@ import CmmLex
 import CLabel
 import SMRep
 import Lexer
+import CmmMonad
 
 import CostCentre
 import ForeignCall
@@ -339,7 +340,7 @@ import qualified Data.Map as M
         INT             { L _ (CmmT_Int         $$) }
         FLOAT           { L _ (CmmT_Float       $$) }
 
-%monad { P } { >>= } { return }
+%monad { PD } { >>= } { return }
 %lexer { cmmlex } { L _ CmmT_EOF }
 %name cmmParse cmm
 %tokentype { Located CmmToken }
@@ -368,7 +369,7 @@ cmmtop  :: { CmmParse () }
         | cmmdata                       { $1 }
         | decl                          { $1 } 
         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
-                {% withThisPackage $ \pkg -> 
+                {% liftP . withThisPackage $ \pkg ->
                    do lits <- sequence $6;
                       staticClosure pkg $3 $5 (map getLit lits) }
 
@@ -389,7 +390,7 @@ cmmdata :: { CmmParse () }
 
 data_label :: { CmmParse CLabel }
     : NAME ':'  
-                {% withThisPackage $ \pkg -> 
+                {% liftP . withThisPackage $ \pkg ->
                    return (mkCmmDataLabel pkg $1) }
 
 statics :: { [CmmParse [CmmStatic]] }
@@ -448,14 +449,14 @@ maybe_body :: { CmmParse () }
 
 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
         : NAME
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do   newFunctionName $1 pkg
                         return (mkCmmCodeLabel pkg $1, Nothing, []) }
 
 
         | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, closure type, description, type
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
                           rep  = mkRTSRep (fromIntegral $9) $
@@ -471,7 +472,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
         
         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                 -- ptrs, nptrs, closure type, description, type, fun type
-                {% withThisPackage $ \pkg -> 
+                {% liftP . withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
                           ty   = Fun 0 (ArgSpec (fromIntegral $15))
@@ -489,7 +490,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
 
         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, tag, closure type, description, type
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $13 $15
                           ty  = Constr (fromIntegral $9)  -- Tag
@@ -508,7 +509,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
         
         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- selector, closure type, description, type
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $9 $11
                           ty  = ThunkSelector (fromIntegral $5)
@@ -522,7 +523,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
                 -- closure type (no live regs)
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do let prof = NoProfilingInfo
                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                       return (mkCmmRetLabel pkg $3,
@@ -533,7 +534,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
                 -- closure type, live regs
-                {% withThisPackage $ \pkg ->
+                {% liftP . withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       live <- sequence $7
                       let prof = NoProfilingInfo
@@ -871,13 +872,13 @@ getLit (CmmLit l) = l
 getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
 getLit _ = panic "invalid literal" -- TODO messy failure
 
-nameToMachOp :: FastString -> P (Width -> MachOp)
+nameToMachOp :: FastString -> PD (Width -> MachOp)
 nameToMachOp name =
   case lookupUFM machOps name of
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
         Just m  -> return m
 
-exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
+exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
 exprOp name args_code = do
   dflags <- getDynFlags
   case lookupUFM (exprMacros dflags) name of
@@ -1007,13 +1008,13 @@ callishMachOps = listToUFM $
         -- in the MO_* constructor. In order to do this, however, we
         -- must intercept the arguments in primCall.
 
-parseSafety :: String -> P Safety
+parseSafety :: String -> PD Safety
 parseSafety "safe"   = return PlaySafe
 parseSafety "unsafe" = return PlayRisky
 parseSafety "interruptible" = return PlayInterruptible
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
-parseCmmHint :: String -> P ForeignHint
+parseCmmHint :: String -> PD ForeignHint
 parseCmmHint "ptr"    = return AddrHint
 parseCmmHint "signed" = return SignedHint
 parseCmmHint str      = fail ("unrecognised hint: " ++ str)
@@ -1034,13 +1035,13 @@ isPtrGlobalReg CurrentNursery        = True
 isPtrGlobalReg (VanillaReg _ VGcPtr) = True
 isPtrGlobalReg _                     = False
 
-happyError :: P a
-happyError = srcParseFail
+happyError :: PD a
+happyError = PD $ \_ s -> unP srcParseFail s
 
 -- -----------------------------------------------------------------------------
 -- Statement-level macros
 
-stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
+stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
@@ -1140,7 +1141,7 @@ foreignCall
         -> [CmmParse (CmmExpr, ForeignHint)]
         -> Safety
         -> CmmReturnInfo
-        -> P (CmmParse ())
+        -> PD (CmmParse ())
 foreignCall conv_string results_code expr_code args_code safety ret
   = do  conv <- case conv_string of
           "C" -> return CCallConv
@@ -1218,7 +1219,7 @@ primCall
         :: [CmmParse (CmmFormal, ForeignHint)]
         -> FastString
         -> [CmmParse CmmExpr]
-        -> P (CmmParse ())
+        -> PD (CmmParse ())
 primCall results_code name args_code
   = case lookupUFM callishMachOps name of
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
@@ -1382,7 +1383,7 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
         init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
-  case unP cmmParse init_state of
+  case unPD cmmParse dflags init_state of
     PFailed span err -> do
         let msg = mkPlainErrMsg dflags span err
         return ((emptyBag, unitBag msg), Nothing)
@@ -1390,7 +1391,7 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
         st <- initC
         let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
             (cmm,_) = runC dflags no_module st fcode
-        let ms = getMessages pst
+        let ms = getMessages pst dflags
         if (errorsFound dflags ms)
          then return (ms, Nothing)
          else do