Desugar: Refactor initDs
authorBen Gamari <bgamari.foss@gmail.com>
Tue, 7 Mar 2017 19:30:38 +0000 (14:30 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 7 Mar 2017 19:31:44 +0000 (14:31 -0500)
As far as I can tell we were unnecessarily building a new TcgEnv when we
already had one on hand. TcRnMonad now sports an initTcWithGbl function,
which allows us to run a TcM monad in the context of this TcgEnv. This
appears to simplify things nicely.

Test Plan: Validate

Reviewers: austin

Subscribers: dfeuer, simonpj, thomie

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

compiler/deSugar/Desugar.hs
compiler/deSugar/DsMonad.hs
compiler/typecheck/TcRnMonad.hs
compiler/vectorise/Vectorise/Monad.hs

index 1458b91..f3ad8dc 100644 (file)
@@ -20,7 +20,7 @@ import DynFlags
 import HscTypes
 import HsSyn
 import TcRnTypes
-import TcRnMonad ( finalSafeMode, fixSafeInstances )
+import TcRnMonad  ( finalSafeMode, fixSafeInstances )
 import TcRnDriver ( runTcInteractive )
 import Id
 import Name
@@ -124,9 +124,7 @@ deSugar hsc_env
                               then addTicksToBinds hsc_env mod mod_loc
                                        export_set (typeEnvTyCons type_env) binds
                               else return (binds, hpcInfo, Nothing)
-        ; (msgs, mb_res)
-            <- initDs hsc_env mod rdr_env type_env
-                      fam_inst_env complete_matches $
+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
                        do { ds_ev_binds <- dsEvBinds ev_binds
                           ; core_prs <- dsTopLHsBinds binds_cvr
                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
index 2d85711..940b8a2 100644 (file)
@@ -6,12 +6,12 @@
 @DsMonad@: monadery used in desugaring
 -}
 
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
 
 module DsMonad (
         DsM, mapM, mapAndUnzipM,
-        initDs, initDsTc, initTcDsForSolver, fixDs,
+        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
         Applicative(..),(<$>),
 
@@ -63,7 +63,6 @@ import TcMType ( checkForLevPolyX, formatLevPolyErr )
 import LoadIface
 import Finder
 import PrelNames
-import RnNames
 import RdrName
 import HscTypes
 import Bag
@@ -153,55 +152,76 @@ type DsWarning = (SrcSpan, SDoc)
         -- and we'll do the print_unqual stuff later on to turn it
         -- into a Doc.
 
-initDs :: HscEnv
-       -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-       -> [CompleteMatch]
-       -> DsM a
-       -> IO (Messages, Maybe a)
--- Print errors and warnings, if any arise
-
-initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches thing_inside
-  = do  { msg_var <- newIORef (emptyBag, emptyBag)
-        ; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches
-        ; pm_iter_var      <- newIORef 0
-        ; let dflags                   = hsc_dflags hsc_env
-              (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
-                                                  fam_inst_env msg_var
-                                                  pm_iter_var all_matches
-
-        ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env
-                          $ initDPH
-                          $ tryM thing_inside     -- Catch exceptions (= errors during desugaring)
-
-        -- Display any errors and warnings
-        -- Note: if -Werror is used, we don't signal an error here.
-        ; msgs <- readIORef msg_var
-
-        ; let final_res | errorsFound dflags msgs = Nothing
-                        | otherwise = case either_res of
-                                        Right res -> Just res
-                                        Left exn  -> pprPanic "initDs" (text (show exn))
-                -- The (Left exn) case happens when the thing_inside throws
-                -- a UserError exception.  Then it should have put an error
-                -- message in msg_var, so we just discard the exception
-
-        ; return (msgs, final_res)
-        }
+-- | Run a 'DsM' action inside the 'TcM' monad.
 initDsTc :: DsM a -> TcM a
 initDsTc thing_inside
-  = do  { this_mod <- getModule
-        ; tcg_env  <- getGblEnv
-        ; msg_var  <- getErrsVar
-        ; dflags   <- getDynFlags
-        ; pm_iter_var      <- liftIO $ newIORef 0
-        ; let type_env = tcg_type_env tcg_env
-              rdr_env  = tcg_rdr_env tcg_env
-              fam_inst_env = tcg_fam_inst_env tcg_env
-              complete_matches = tcg_complete_matches tcg_env
-              ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
-                                  msg_var pm_iter_var complete_matches
-        ; setEnvs ds_envs thing_inside
-        }
+  = do { tcg_env  <- getGblEnv
+       ; msg_var  <- getErrsVar
+       ; hsc_env  <- getTopEnv
+       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; setEnvs envs $ initDPH thing_inside
+       }
+
+-- | Run a 'DsM' action inside the 'IO' monad.
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs hsc_env tcg_env thing_inside
+  = do { msg_var <- newIORef emptyMessages
+       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; runDs hsc_env envs thing_inside
+       }
+
+-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
+mkDsEnvsFromTcGbl :: MonadIO m
+                  => HscEnv -> IORef Messages -> TcGblEnv
+                  -> m (DsGblEnv, DsLclEnv)
+mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+  = do { pm_iter_var <- liftIO $ newIORef 0
+       ; let dflags   = hsc_dflags hsc_env
+             this_mod = tcg_mod tcg_env
+             type_env = tcg_type_env tcg_env
+             rdr_env  = tcg_rdr_env tcg_env
+             fam_inst_env = tcg_fam_inst_env tcg_env
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ tcg_complete_matches tcg_env
+       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+                           msg_var pm_iter_var complete_matches
+       }
+
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs hsc_env (ds_gbl, ds_lcl) thing_inside
+  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
+                              (initDPH $ tryM thing_inside)
+       ; msgs   <- readIORef (ds_msgs ds_gbl)
+       ; let final_res
+               | errorsFound dflags msgs = Nothing
+               | Right r <- res          = Just r
+               | otherwise               = panic "initDs"
+       ; return (msgs, final_res)
+       }
+  where dflags = hsc_dflags hsc_env
+
+-- | Run a 'DsM' action in the context of an existing 'ModGuts'
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts hsc_env guts thing_inside
+  = do { pm_iter_var <- newIORef 0
+       ; msg_var <- newIORef emptyMessages
+       ; let dflags   = hsc_dflags hsc_env
+             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+             rdr_env  = mg_rdr_env guts
+             fam_inst_env = mg_fam_inst_env guts
+             this_mod = mg_module guts
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ mg_complete_sigs guts
+
+             bindsToIds (NonRec v _)   = [v]
+             bindsToIds (Rec    binds) = map fst binds
+             ids = concatMap bindsToIds (mg_binds guts)
+
+             envs  = mkDsEnvs dflags this_mod rdr_env type_env
+                              fam_inst_env msg_var pm_iter_var
+                              complete_matches
+       ; runDs hsc_env envs thing_inside
+       }
 
 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
 -- Spin up a TcM context so that we can run the constraint solver
@@ -229,7 +249,8 @@ initTcDsForSolver thing_inside
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef Int -> [CompleteMatch]
          -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar complete_matches
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
+         complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
index 1c84b40..cb90ba5 100644 (file)
@@ -10,7 +10,7 @@ Functions for working with the typechecker environment (setters, getters...).
 
 module TcRnMonad(
   -- * Initalisation
-  initTc, initTcInteractive, initTcForLookup, initTcRnIf,
+  initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf,
 
   -- * Simple accessors
   discardResult,
@@ -200,15 +200,12 @@ initTc :: HscEnv
                 -- (error messages should have been printed already)
 
 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
- = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
-        tvs_var      <- newIORef emptyVarSet ;
-        keep_var     <- newIORef emptyNameSet ;
+ = do { keep_var     <- newIORef emptyNameSet ;
         used_gre_var <- newIORef [] ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
         th_locs_var  <- newIORef Set.empty ;
         infer_var    <- newIORef (True, emptyBag) ;
-        lie_var      <- newIORef emptyWC ;
         dfun_n_var   <- newIORef emptyOccSet ;
         type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
@@ -301,7 +298,23 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_static_wc      = static_wc_var,
                 tcg_complete_matches = []
              } ;
-             lcl_env = TcLclEnv {
+        } ;
+
+        -- OK, here's the business end!
+        initTcWithGbl hsc_env gbl_env loc do_this
+    }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+              -> TcGblEnv
+              -> RealSrcSpan
+              -> TcM r
+              -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { tvs_var      <- newIORef emptyVarSet
+      ; lie_var      <- newIORef emptyWC
+      ; errs_var     <- newIORef (emptyBag, emptyBag)
+      ; let lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
                 tcl_loc        = loc,     -- Should be over-ridden very soon!
                 tcl_ctxt       = [],
@@ -315,31 +328,29 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcl_tyvars     = tvs_var,
                 tcl_lie        = lie_var,
                 tcl_tclvl      = topTcLevel
-             } ;
-        } ;
+                }
 
-        -- OK, here's the business end!
-        maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
                      do { r <- tryM do_this
                         ; case r of
                           Right res -> return (Just res)
-                          Left _    -> return Nothing } ;
+                          Left _    -> return Nothing }
 
         -- Check for unsolved constraints
-        lie <- readIORef lie_var ;
-        if isEmptyWC lie
+      ; lie <- readIORef (tcl_lie lcl_env)
+      ; if isEmptyWC lie
            then return ()
-           else pprPanic "initTc: unsolved constraints" (ppr lie) ;
+           else pprPanic "initTc: unsolved constraints" (ppr lie)
 
         -- Collect any error messages
-        msgs <- readIORef errs_var ;
+      ; msgs <- readIORef (tcl_errs lcl_env)
 
-        let { final_res | errorsFound dflags msgs = Nothing
-                        | otherwise               = maybe_res } ;
-
-        return (msgs, final_res)
-    }
+      ; let { final_res | errorsFound dflags msgs = Nothing
+                        | otherwise               = maybe_res }
 
+      ; return (msgs, final_res)
+      }
+  where dflags = hsc_dflags hsc_env
 
 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
 -- Initialise the type checker monad for use in GHCi
index c7909ef..b49e8d5 100644 (file)
@@ -27,6 +27,7 @@ import Vectorise.Builtins
 import Vectorise.Env
 
 import CoreSyn
+import TcRnMonad
 import DsMonad
 import HscTypes hiding ( MonadThings(..) )
 import DynFlags
@@ -44,6 +45,7 @@ import ErrUtils
 import Outputable
 import Module
 
+import Control.Monad (join)
 
 -- |Run a vectorisation computation.
 --
@@ -55,18 +57,14 @@ initV :: HscEnv
 initV hsc_env guts info thing_inside
   = do { dumpIfVtTrace "Incoming VectInfo" (ppr info)
 
-       ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
-       ; (_, Just res) <- initDs hsc_env (mg_module guts)
-                                         (mg_rdr_env guts) type_env
-                                         (mg_fam_inst_env guts) [] go
-
-       ; case res of
+       ; (_, res) <- initDsWithModGuts hsc_env guts go
+       ; case join res of
            Nothing
              -> dumpIfVtTrace "Vectorisation FAILED!" empty
            Just (info', _)
              -> dumpIfVtTrace "Outgoing VectInfo" (ppr info')
 
-       ; return res
+       ; return $ join res
        }
   where
     dflags = hsc_dflags hsc_env
@@ -125,7 +123,6 @@ initV hsc_env guts info thing_inside
 
     invalidInstance = "Invalid DPH instance (overlapping in head constructor)"
 
-
 -- Builtins -------------------------------------------------------------------
 
 -- |Lift a desugaring computation using the `Builtins` into the vectorisation monad.