Migrate cvs diff from fptools-assoc branch

[ghc-hetmet.git] / compiler / typecheck / TcRnMonad.lhs

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index ff1979b..0b5e4fc 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -11,27 +11,25 @@ import TcRnTypes    -- Re-export all
 import IOEnv           -- Re-export all
 
 #if defined(GHCI) && defined(BREAKPOINT)
 import IOEnv           -- Re-export all
 
 #if defined(GHCI) && defined(BREAKPOINT)

-import TypeRep          ( Type(..), liftedTypeKind, TyThing(..) )
+import TypeRep          ( Type(..), liftedTypeKind )

 import Var              ( mkTyVar, mkGlobalId )
 import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
 import OccName          ( mkOccName, tvName )
 import SrcLoc           ( noSrcLoc  )
 import Var              ( mkTyVar, mkGlobalId )
 import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
 import OccName          ( mkOccName, tvName )
 import SrcLoc           ( noSrcLoc  )

-import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy )
-import PrelNames        ( breakpointJumpName )
+import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy, boolTy )
+import PrelNames        ( breakpointJumpName, breakpointCondJumpName )

 import NameEnv          ( mkNameEnv )
 #endif
 
 import HsSyn           ( emptyLHsBinds )
 import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),
 import NameEnv          ( mkNameEnv )
 #endif
 
 import HsSyn           ( emptyLHsBinds )
 import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),

-                         TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
-                         isHsBoot, ModSummary(..),
+                         TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,

                          ExternalPackageState(..), HomePackageTable,
                          Deprecs(..), FixityEnv, FixItem, 
                          ExternalPackageState(..), HomePackageTable,
                          Deprecs(..), FixityEnv, FixItem, 

-                         lookupType, unQualInScope )
-import Module          ( Module, unitModuleEnv )
-import RdrName         ( GlobalRdrEnv, emptyGlobalRdrEnv,      
-                         LocalRdrEnv, emptyLocalRdrEnv )
-import Name            ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
+                         mkPrintUnqualified )
+import Module          ( Module, moduleName )
+import RdrName         ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
+import Name            ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )

 import Type            ( Type )
 import TcType          ( tcIsTyVarTy, tcGetTyVar )
 import NameEnv         ( extendNameEnvList, nameEnvElts )
 import Type            ( Type )
 import TcType          ( tcIsTyVarTy, tcGetTyVar )
 import NameEnv         ( extendNameEnvList, nameEnvElts )

@@ -43,7 +41,6 @@ import VarEnv         ( TidyEnv, emptyTidyEnv, extendVarEnv )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
                          mkWarnMsg, printErrorsAndWarnings,
                          mkLocMessage, mkLongErrMsg )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
                          mkWarnMsg, printErrorsAndWarnings,
                          mkLocMessage, mkLongErrMsg )

-import Packages                ( mkHomeModules )

 import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv         ( emptyNameEnv )
 import NameSet         ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
 import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv         ( emptyNameEnv )
 import NameSet         ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )

@@ -51,8 +48,10 @@ import OccName               ( emptyOccEnv, tidyOccName )
 import Bag             ( emptyBag )
 import Outputable
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import Bag             ( emptyBag )
 import Outputable
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )

+import UniqFM          ( unitUFM )

 import Unique          ( Unique )
 import Unique          ( Unique )

-import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set,
+                         dopt_unset, GhcMode ) 

 import StaticFlags     ( opt_PprStyle_Debug )
 import Bag             ( snocBag, unionBags )
 import Panic           ( showException )
 import StaticFlags     ( opt_PprStyle_Debug )
 import Bag             ( snocBag, unionBags )
 import Panic           ( showException )

@@ -96,17 +95,16 @@ initTc hsc_env hsc_src mod do_this
             gbl_env = TcGblEnv {
                tcg_mod      = mod,
                tcg_src      = hsc_src,
             gbl_env = TcGblEnv {
                tcg_mod      = mod,
                tcg_src      = hsc_src,

-               tcg_rdr_env  = emptyGlobalRdrEnv,
+               tcg_rdr_env  = hsc_global_rdr_env hsc_env,

                tcg_fix_env  = emptyNameEnv,
                tcg_default  = Nothing,
                tcg_fix_env  = emptyNameEnv,
                tcg_default  = Nothing,

-               tcg_type_env = emptyNameEnv,
+               tcg_type_env = hsc_global_type_env hsc_env,

                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
                tcg_inst_uses = dfuns_var,
                tcg_th_used   = th_var,
                tcg_exports  = emptyNameSet,
                tcg_imports  = init_imports,
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
                tcg_inst_uses = dfuns_var,
                tcg_th_used   = th_var,
                tcg_exports  = emptyNameSet,
                tcg_imports  = init_imports,

-               tcg_home_mods = home_mods,

                tcg_dus      = emptyDUs,
                 tcg_rn_imports = Nothing,
                 tcg_rn_exports = Nothing,
                tcg_dus      = emptyDUs,
                 tcg_rn_imports = Nothing,
                 tcg_rn_exports = Nothing,

@@ -139,17 +137,23 @@ initTc hsc_env hsc_src mod do_this
                           unique <- newUnique ;
                           let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                 tyvar = mkTyVar var liftedTypeKind;
                           unique <- newUnique ;
                           let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                 tyvar = mkTyVar var liftedTypeKind;

-                                breakpointJumpType = mkGlobalId
-                                                     (VanillaGlobal)
-                                                     (breakpointJumpName)
-                                                     (FunTy intTy
-                                                      (FunTy (mkListTy unitTy)
-                                                       (FunTy stringTy
-                                                        (ForAllTy tyvar
-                                                         (FunTy (TyVarTy tyvar)
-                                                          (TyVarTy tyvar))))))
-                                                     (vanillaIdInfo);
-                                new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+                                basicType extra = (FunTy intTy
+                                                   (FunTy (mkListTy unitTy)
+                                                    (FunTy stringTy
+                                                     (ForAllTy tyvar
+                                                      (extra
+                                                       (FunTy (TyVarTy tyvar)
+                                                        (TyVarTy tyvar)))))));
+                                breakpointJumpType
+                                    = mkGlobalId VanillaGlobal breakpointJumpName
+                                                 (basicType id) vanillaIdInfo;
+                                breakpointCondJumpType
+                                    = mkGlobalId VanillaGlobal breakpointCondJumpName
+                                                 (basicType (FunTy boolTy)) vanillaIdInfo;
+                                new_env = mkNameEnv [(breakpointJumpName
+                                                     , ATcId breakpointJumpType topLevel False)
+                                                     ,(breakpointCondJumpName
+                                                     , ATcId breakpointCondJumpType topLevel False)];

                               };
                           r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
 #else
                               };
                           r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
 #else

@@ -169,17 +173,8 @@ initTc hsc_env hsc_src mod do_this
        return (msgs, final_res)
     }
   where
        return (msgs, final_res)
     }
   where

-    home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env))
-       -- A guess at the home modules.  This will be correct in
-       -- --make and GHCi modes, but in one-shot mode we need to 
-       -- fix it up after we know the real dependencies of the current
-       -- module (see tcRnModule).
-       -- Setting it here is necessary for the typechecker entry points
-       -- other than tcRnModule: tcRnGetInfo, for example.  These are
-       -- all called via the GHC module, so hsc_mod_graph will contain
-       -- something sensible.
-
-    init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet}
+    init_imports = emptyImportAvails {imp_env = 
+                                       unitUFM (moduleName mod) emptyNameSet}

        -- Initialise tcg_imports with an empty set of bindings for
        -- this module, so that if we see 'module M' in the export
        -- list, and there are no bindings in M, we don't bleat 
        -- Initialise tcg_imports with an empty set of bindings for
        -- this module, so that if we see 'module M' in the export
        -- list, and there are no bindings in M, we don't bleat 

@@ -194,15 +189,6 @@ initTcPrintErrors env mod todo = do
   (msgs, res) <- initTc env HsSrcFile mod todo
   printErrorsAndWarnings (hsc_dflags env) msgs
   return res
   (msgs, res) <- initTc env HsSrcFile mod todo
   printErrorsAndWarnings (hsc_dflags env) msgs
   return res

-
--- mkImpTypeEnv makes the imported symbol table
-mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
-            -> Name -> Maybe TyThing
-mkImpTypeEnv pcs hpt = lookup 
-  where
-    pte = eps_PTE pcs
-    lookup name | isInternalName name = Nothing
-               | otherwise           = lookupType hpt pte name

 \end{code}
 
 
 \end{code}
 
 

@@ -283,6 +269,10 @@ setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                         env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
 
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                         env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
 

+unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+                        env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
+

 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()    -- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
                                if b then thing_inside else return () }
 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()    -- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
                                if b then thing_inside else return () }

@@ -338,17 +328,28 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 
 \begin{code}
 newUnique :: TcRnIf gbl lcl Unique
 
 \begin{code}
 newUnique :: TcRnIf gbl lcl Unique

-newUnique = do { us <- newUniqueSupply ; 
-                return (uniqFromSupply us) }
+newUnique
+ = do { env <- getEnv ;
+       let { u_var = env_us env } ;
+       us <- readMutVar u_var ;
+        case splitUniqSupply us of { (us1,_) -> do {
+       writeMutVar u_var us1 ;
+       return $! uniqFromSupply us }}}
+   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
+   -- a chain of unevaluated supplies behind.
+   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
+   -- throw away one half of the new split supply.  This is safe because this
+   -- is the only place we use that unique.  Using the other half of the split
+   -- supply is safer, but slower.

 
 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 newUniqueSupply
  = do { env <- getEnv ;
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;
 
 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 newUniqueSupply
  = do { env <- getEnv ;
        let { u_var = env_us env } ;
        us <- readMutVar u_var ;

-       let { (us1, us2) = splitUniqSupply us } ;
+        case splitUniqSupply us of { (us1,us2) -> do {

        writeMutVar u_var us1 ;
        writeMutVar u_var us1 ;

-       return us2 }
+       return us2 }}}

 
 newLocalName :: Name -> TcRnIf gbl lcl Name
 newLocalName name      -- Make a clone
 
 newLocalName :: Name -> TcRnIf gbl lcl Name
 newLocalName name      -- Make a clone

@@ -390,7 +391,7 @@ traceOptTcRn flag doc = ifOptM flag $ do
 
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
 
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;

-                   ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+                   ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }

 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)

@@ -488,7 +489,7 @@ addLongErrAt loc msg extra
   = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
         errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
   = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
         errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;

-        let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
+        let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;

         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns, errs `snocBag` err) }
 
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns, errs `snocBag` err) }
 

@@ -504,7 +505,7 @@ addReportAt :: SrcSpan -> Message -> TcRn ()
 addReportAt loc msg
   = do { errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
 addReportAt loc msg
   = do { errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;

-        let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
+        let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;

         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns `snocBag` warn, errs) }
 
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns `snocBag` warn, errs) }
 

@@ -1011,8 +1012,10 @@ forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
 forkM_maybe doc thing_inside
  = do {        unsafeInterleaveM $
        do { traceIf (text "Starting fork {" <+> doc)
 forkM_maybe doc thing_inside
  = do {        unsafeInterleaveM $
        do { traceIf (text "Starting fork {" <+> doc)

-          ; mb_res <- tryM thing_inside ;
-            case mb_res of
+          ; mb_res <- tryM $
+                      updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
+                      thing_inside
+          ; case mb_res of

                Right r  -> do  { traceIf (text "} ending fork" <+> doc)
                                ; return (Just r) }
                Left exn -> do {
                Right r  -> do  { traceIf (text "} ending fork" <+> doc)
                                ; return (Just r) }
                Left exn -> do {