From 53fe941370fd7fc90bf2e725f0f0b7c0382ceb4e Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 24 Feb 2004 15:57:59 +0000 Subject: [PATCH] [project @ 2004-02-24 15:57:52 by simonpj] --------------------------------------- Record dependency on Template Haskell package --------------------------------------- An unforseen consequence of making the Template Haskell package separate is that we need to record dependency on the package, even if no TH module is imported. So we carry round (another) mutable variable tcg_th_used in the tyepchecker monad, and zap it when $(...) and [| ... |] are used. I did a little tidy-up and documentation in ListSetOps too --- ghc/compiler/deSugar/Desugar.lhs | 15 +++++++++++++-- ghc/compiler/main/HscTypes.lhs | 1 + ghc/compiler/rename/RnNames.lhs | 10 ++++++---- ghc/compiler/typecheck/TcRnMonad.lhs | 5 +++++ ghc/compiler/typecheck/TcRnTypes.lhs | 7 +++++++ ghc/compiler/typecheck/TcSplice.lhs | 18 +++++++++++------- ghc/compiler/utils/ListSetOps.lhs | 22 ++++++++++++---------- 7 files changed, 55 insertions(+), 23 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 599c759..5f8192e 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -36,13 +36,16 @@ import VarSet import Bag ( Bag, isEmptyBag, mapBag, emptyBag, bagToList ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars ) +import Packages ( thPackage ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, mkWarnMsg, errorsFound, WarnMsg ) +import ListSetOps ( insertList ) import Outputable import UniqSupply ( mkSplitUniqSupply ) import SrcLoc ( Located(..), SrcSpan, unLoc ) import DATA_IOREF ( readIORef ) import FastString +import Data.List ( sort ) \end{code} %************************************************************************ @@ -62,6 +65,7 @@ deSugar hsc_env tcg_exports = exports, tcg_dus = dus, tcg_inst_uses = dfun_uses_var, + tcg_th_used = th_var, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_deprecs = deprecs, @@ -92,10 +96,17 @@ deSugar hsc_env ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used ; let used_names = allUses dus `unionNameSets` dfun_uses ; usages <- mkUsageInfo hsc_env imports used_names + + ; th_used <- readIORef th_var ; let + pkgs | th_used = insertList thPackage (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), - dep_pkgs = imp_dep_pkgs imports, - dep_orphs = imp_orphs imports } + dep_pkgs = sort pkgs, + dep_orphs = sort (imp_orphs imports) } + -- sort to get into canonical order + mod_guts = ModGuts { mg_module = mod, mg_exports = exports, diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 20e2fb1..a40b006 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -658,6 +658,7 @@ type IsBootInterface = Bool -- in the import hierarchy. See TcRnTypes.ImportAvails for details. -- -- Invariant: the dependencies of a module M never includes M +-- Invariant: the lists are unordered, with no duplicates data Dependencies = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies dep_pkgs :: [PackageName], -- External package dependencies diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 62cb2db..7be2214 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -54,7 +54,7 @@ import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, import BasicTypes ( DeprecTxt ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull, isSingleton ) -import List ( partition, insert ) +import List ( partition ) import IO ( openFile, IOMode(..) ) \end{code} @@ -192,7 +192,9 @@ importsFromImportDecl this_mod let -- Compute new transitive dependencies - orphans | is_orph = insert imp_mod_name (dep_orphs deps) + + orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) ) + imp_mod_name : dep_orphs deps | otherwise = dep_orphs deps (dependent_mods, dependent_pkgs) @@ -208,8 +210,8 @@ importsFromImportDecl this_mod = -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - -- from imp_mod - ([], insert (mi_package iface) (dep_pkgs deps)) + ASSERT( not (mi_package iface `elem` dep_pkgs deps) ) + ([], mi_package iface : dep_pkgs deps) not_self (m, _) = m /= this_mod_name diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 86af49a..fe410c6 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -74,6 +74,7 @@ initTc hsc_env mod do_this tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; dfuns_var <- newIORef emptyNameSet ; + th_var <- newIORef False ; let { gbl_env = TcGblEnv { @@ -85,6 +86,7 @@ initTc hsc_env mod do_this tcg_type_env_var = type_env_var, tcg_inst_env = mkImpInstEnv hsc_env, tcg_inst_uses = dfuns_var, + tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, tcg_dus = emptyDUs, @@ -733,6 +735,9 @@ setLclTypeEnv lcl_env thing_inside %************************************************************************ \begin{code} +recordThUse :: TcM () +recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } + getStage :: TcM ThStage getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 8fa34ff..e5a8e1c 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -156,6 +156,13 @@ data TcGblEnv -- rather like the free variables of the program, but -- are implicit instead of explicit. + tcg_th_used :: TcRef Bool, -- True <=> Template Haskell syntax used + -- We need this so that we can generate a dependency on the + -- Template Haskell package, becuase the desugarer is going to + -- emit loads of references to TH symbols. It's rather like + -- tcg_inst_uses; the reference is implicit rather than explicit, + -- so we have to zap a mutable variable. + -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index fc95be0..ddd7ace 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -100,6 +100,7 @@ tcBracket brack res_ty -- Typecheck expr to make sure it is valid, -- but throw away the results. We'll type check -- it again when we actually use it. + recordThUse `thenM_` newMutVar [] `thenM` \ pending_splices -> getLIEVar `thenM` \ lie_var -> @@ -159,8 +160,8 @@ tcSpliceExpr (HsSplice name expr) res_ty Just next_level -> case level of { - Comp -> do { e <- tcTopSplice expr res_ty ; - returnM (unLoc e) }; + Comp -> do { e <- tcTopSplice expr res_ty + ; returnM (unLoc e) } ; Brack _ ps_var lie_var -> -- A splice inside brackets @@ -226,16 +227,19 @@ tcTopSpliceExpr expr meta_ty = checkNoErrs $ -- checkNoErrs: must not try to run the thing -- if the type checker fails! - setStage topSpliceStage $ + setStage topSpliceStage $ do - -- Typecheck the expression - getLIE (tcCheckRho expr meta_ty) `thenM` \ (expr', lie) -> + + do { recordThUse -- Record that TH is used (for pkg depdendency) + -- Typecheck the expression + ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty) + -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> + ; const_binds <- tcSimplifyTop lie -- And zonk it - zonkTopLExpr (mkHsLet const_binds expr') + ; zonkTopLExpr (mkHsLet const_binds expr') } \end{code} diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index db43da5..8d4912d 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -5,7 +5,7 @@ \begin{code} module ListSetOps ( - unionLists, minusList, + unionLists, minusList, insertList, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, @@ -30,22 +30,24 @@ import List ( union ) %************************************************************************ %* * -\subsection{Treating lists as sets} + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered %* * %************************************************************************ \begin{code} -unionLists :: (Eq a) => [a] -> [a] -> [a] -unionLists = union -\end{code} +insertList :: Eq a => a -> [a] -> [a] +-- Assumes the arg list contains no dups; guarantees the result has no dups +insertList x xs | isIn "insert" x xs = xs + | otherwise = x : xs -Everything in the first list that is not in the second list: +unionLists :: (Eq a) => [a] -> [a] -> [a] +-- Assumes that the arguments contain no duplicates +unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys -\begin{code} minusList :: (Eq a) => [a] -> [a] -> [a] -minusList xs ys = [ x | x <- xs, x `not_elem` ys] - where - not_elem = isn'tIn "minusList" +-- Everything in the first list that is not in the second list: +minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys] \end{code} -- 1.7.10.4